
+--------------------------------------------------------------------------------------+
|                                                                                      |
|                                                                                      |
|                  PASCAL COMPUTER LANGUAGE PROGRAMMING INFORMATION                    |
|                                                                                      |
|             ========================================================                 |
|             U S U S    P A S C A L    L I B R A R Y    A R C H I V E                 |
|             ========================================================                 |
|                                                                                      |
|                                     COURTESY OF                                      |
|                                                                                      |
|                                    DAVID T CRAIG                                     |
|                                                                                      |
|                                    09 APRIL 2004                                     |
|                                                                                      |
|                                                                                      |
+--------------------------------------------------------------------------------------+


========================================================================================
DOCUMENT Jefferson Computer Museum - UCS
========================================================================================

http://www.threedee.com/jcm/usus/
09 April 2004

USUS SOFTWARE LIBRARY
IN THE WEST WING OF THE JEFFERSON COMPUTER MUSEUM

TERAK MUSEUM - UCSD PASCAL MUSEUM - USUS LIBRARY
ANCIENT ALPHABETIC ART - LIBRARY - ALTAIR AND IMSAI EMULATORS
REVIVING CASSETTE DATA - DISK UTILITIES - COMPUTER RESCUE
WHAT'S WRONG WITH THIS PICTURE
------------------------------------------------------------------------

What was the USUS Software Library?
Once upon a time there was a user group known as the UCSD p-System System Users Society (USUS). They maintained a library of Pascal floppy disks containing source code and programs.

I have found several people who own all or portions of the collection.  Someone sent me the disk images for volumes 1 through 29 of the US library, and volumes 3 and 4 of the USUS UK collection. Using my disk utilities, I have burst these P-System disk images into their native files.

I put all the files of all the disks in a single Zip file that you may download. Note that the conversion process was aimed at producing an archive of text files in directories with long filenames with DOS line endings. The few .CODE program files in the library have been rendered useless by this process.

You may also grab the raw disk images if you want to mount them directly on a P-System machine, or if you want to select different options for my disk utilities to preserve the .CODE programs or other files with hidden header blocks.

What happened to USUS?
There's few traces of them on the Web, and in several years of casual research, I've been unable to find anyone who admits to being the last of these Mohicans.  They were once reachable at USUS, Box 1148, La Jolla, CA 92038, or at Datamed Research, or at Softech MicroSystems. According to the Apple II FAQ, Keith Frederick was once secretary, and the group was described as "an international non-profit organization dedicated to promoting and influencing software standards to aid in the development of portable software. They have a large software library including a lot of source code (for almost every language or computer)." 

According to a history of the Texas Instruments TI-99/4A computer, which could run the P-System, Robert Peterson was voted president of USUS in September 1982, in Dallas, Texas.

What's the copyright status of these files?
Back in those wild and wooly days, computer users were not as stringent about copyright as we are today. In this case, it means the USUS disks contained less-than-precise messages about copyright. The most common message is "For not-for-profit use by USUS members only. May be used and distributed only according to stated policy and the author's wishes." I suspect that USUS once tried to control the sale of disks from its collection as a means of fundraising.
------------------------------------------------------------------------

Return to the main page of the Jefferson Computer Museum.

Copyright 2003 jfoust@threedee.com, All Rights Reserved. THIS PAGE MAY NOT BE USED OR PUBLISHED IN ANY FORM (WRITTEN, CD-ROM, ETC.) WITHOUT EXPRESS WRITTEN (HARDCOPY) PERMISSION FROM JOHN FOUST. 

www.threedee.com - www.goJefferson.com - www.foust.org - www.saltglaze.com

========================================================================================
DOCUMENT :usus Folder:readme.doc.txt
========================================================================================


December 16, 1999

This Zip contains the USUS Software Library, volumes 1 through 29
plus USUS UK volumes UK3 and UK4.  

This archive was derived from .SVOL disk images that are available
on my web site.  All files were translated from UCSD P-System text
file format to DOS format, which means the .CODE files are present
but not intact.  Using the utilities on my web site, you can burst
the disk images in a different fashion if you like.

John Foust
jfoust@threedee.com

http://www.threedee.com/jcm/


========================================================================================
DOCUMENT :usus Folder:VOL01:catalog1.text
========================================================================================


                VOLUME ONE, UCSD PASCAL USERS' GROUP -- CATALOG

     NOTE WELL:  Let it be said here for all the files on this disk that UCSD 
Pascal is a trademark of the Regents of the University of California.  All
software on this disk may be given away but NOT sold without prior arrangement
with SofTec and/or Datamed Research.

CATALOG1.TEXT.......what you're reading now.
COMBINE.TEXT........a simple little thing to combine 2 or more text files.
CPM.DOC.TEXT........documentation of 8080/Z-80 interfaces and programs.
CPMCOPY.TEXT........an all-Pascal CP/M file copier.
CRC16.TEXT..........assembly-language CRC generator/checker for MODEM.TEXT.
CRT.I.O.TEXT........very powerful, crash-proof data entry UNIT for CRT menus.
DISKREAD.TEXT.......assembly-language direct track/sector disk reader.
FORMAT.DOC.TEXT.....documentation (from Pascal News) for FORMAT.
FORMAT.TEXT.........large, wonderful Pascal program prettyprinter.
FORMAT1.TEXT........part of FORMAT.TEXT (subfile).
FORMAT2.TEXT........part of FORMAT.TEXT (subfile).
GETCPM.TEXT.........reads CP/M files --> UCSD-format disks.
GETCPM2.TEXT........another version of GETCPM.TEXT.
GOTCHA.DOC.TEXT.....read all about UCSD's hidden gotchas for 8080/Z-80 users.
INITVAR.TEXT........part of PRETTY.TEXT (subfile).
INOUTREADY.TEXT.....assembly-language routines: read/write to i/o port, etc.
INTRODUCTN.TEXT.....a statement of purpose--why we are here, how we work.
L.TEXT..............a short but effective text printer with several options.
MODEM.TEXT..........1st of 2 D.C. Hayes Modem drivers (S-100 version).
MODEM1.TEXT.........the second   "        "      "       "       "   .
PRETTY.TEXT.........the second Pascal prettyprinter, from the Pascal News.
PRETTY.DOC.TEXT.....documentation for both FORMAT and PRETTY.
RWCPM.TEXT..........assembly-language direct disk reading/writing.
SIMP.TEXT...........cute program to produce random text; sounds "professional."
TYPESET.TEXT........takes text from editors & right-justifies it.
UNITS.DOC.TEXT......re UNITS, SEGMENTS, & EXTERNAL routines.
VOLUME1.TEXT........how this disk is organized (more detail).

     Have fun!  Let me know if you spot bugs or errors in any software or docu-
mentation on this disk, or if you can clear up further mysteries of UCSD Pascal.
     
     Jim Gagne, DATAMED RESEARCH
     

========================================================================================
DOCUMENT :usus Folder:VOL01:combine.text
========================================================================================


PROGRAM Combine;

VAR  i: integer;
     yn: char;
     Fileno: string [6];
     Infilename, Outfilename: string [20];
     s: string[200];
     Infile1, Infile2, Infile3, Infile4, Outfile: text;

BEGIN
   Writeln ('This program combines 2 to 4 textfiles.');
   Writeln (
      'Please note that the filetype ".TEXT" is assumed, and should NOT'
   );
   WRITELN ('be included when you type the file names.');
   Writeln;
   Write ('Please type the name of the OUTPUT file:  ');
   READLN (Outfilename);
   Outfilename := CONCAT (outfilename, '.TEXT');
   REWRITE (outfile, outfilename);
   Writeln;
   Write ('Please type the name of the first file to be combined:  ');
   READLN (infilename);
   Infilename := CONCAT (infilename, '.TEXT');
   reset (Infile1, infilename);
j  WHILE NOT eof (Infile1) DO
      BEGIN
         Readln (Infile1, s);
         Writeln (Outfile, s)
      END;
   Writeln ('File copied.');
   yn := 'Y';
   i := 1;
   While ((yn = 'Y') or (yn = 'y')) AND (i < 4) do
      BEGIN
         i := succ (i);
         CASE i OF
            2: Fileno := 'second';
            3: Fileno := 'third';
            4: Fileno := 'fourth'
         END;
         Write ('Please type the name of the ',
                Fileno, ' file you wish to add:  ');
         READLN (Infilename);
         Infilename := CONCAT (Infilename, '.TEXT');
         CASE i OF
            2: BEGIN
                  RESET (Infile2, Infilename);
                  WHILE NOT eof (Infile2) DO
                     BEGIN
                        Readln (Infile2, s);
                        Writeln (Outfile, s)
                     END
               END;
            3: BEGIN
                  RESET (Infile3, Infilename);
                  WHILE NOT eof (Infile3) DO
                     BEGIN
                        Readln (Infile3, s);
                        Writeln (Outfile, s)
                     END
               END;
            4: BEGIN
                  RESET (Infile4, Infilename);
                  WHILE NOT eof (Infile4) DO
                     BEGIN
                        Readln (Infile4, s);
                        Writeln (Outfile, s)
                     END
               END
         END (*case*);
         Write ('File copied.  Got more files (y/n)? ');
         READ (yn);
      END;
   CLOSE (outfile, lock)
END.

========================================================================================
DOCUMENT :usus Folder:VOL01:cpm.doc.text
========================================================================================


             SOME MISCELLANEOUS 8080/Z-80 INTERPRETER DOCUMENTATION
       PLUS NOTES ON THE 8080 I/O ROUTINES AND CP/M-UCSD DISK CONVERSIONS

     THE INTERPRETER does not use ANYTHING in page 0 (0000 to 00FF hex) except 
the BIOS jump address at location 0001 and 0002.  This area is available for
your use.

     The cold start and warm reboot jump vectors at the start of a standard 
CP/M BIOS jump vector table are used only as place holders; to save space, 
place any initializing code within the PINIT.ASM file, where it will be 
overwritten by SYSTEM.PASCAL once the interpreter has been read in.  It's best 
if those first two jump vectors jump to a RETurn instruction somewhere in your 
BIOS.

     Location 200 hex contains a jump vector that will always send you back 
into whatever the system was supposed to be doing at the moment.  I've found 
it useful, for instance, if I tried to save something I was editing with the 
disks out of the drives, and the system crashed.  After stopping the 
processor and reinserting the disks, I can generally get going again by 
starting up at location 200, unless the whole thing is dead.

     The closest thing to a warm reboot is a reinitialization, which occurs if 
a) a run-time error occurs or b) you type an "I" while at the system Command 
level.  Useful if your system is behaving strangely after something went 
wrong.

     The only way I know of to get going again after you've hung up in some
way (ie, infinite loop in a program) is to totally reboot.

     
     THE 8080/Z-80 ASSEMBLY LANGUAGE I/O ROUTINES ON THIS DISK consist of two
or three sets of everything, by different authors.  INOUTREADY.TEXT contains
two versions of console status checking (whether a character has been typed)
and direct port i/o routines. Direct disk reading (to a numbered track and
sector) is provided by DISKREAD.TEXT, READCPM.TEXT, and RWCPM.TEXT.  Only the
last file allows direct writing to a numbered track and sector, but the others
should be easily altered.  Most of these routines require an intact CP/M-style
jump vector table at the start of the BIOS, which I have dispensed with in
reorganizing the i/o section of the interpreter (see the file BOOTER.ASM on
a subsequent disk), so I have not personally checked them out.  Assemble them
and stick them in your SYSTEM.LIBRARY.


     THERE ARE TWO CP/M-UCSD disk conversion programs on this disk, both
written primarily in Pascal but calling assembly language routines to do the
actual reading and writing.  You'll need to have included the necessary 
routines in your SYSTEM.LIBRARY as noted above.

     The first program consists of GETCPM.TEXT, also present as GETCPM2.TEXT, 
both written by Barry Cole.  I have not tried them myself but understand that 
they work well.  Documentation on program workings is sparce.

     The second is written entirely in Pascal, CPMCOPY.TEXT, by J. M. Wierda, 
and is well documented.

========================================================================================
DOCUMENT :usus Folder:VOL01:cpmcopy.text
========================================================================================

PROGRAM cpmcopy;

(*Written by J. M. Wierda

     This program will transfer a CP/M file from a disk in unit 5 to a Pascal
disk in unit 4. Note that when the filename is requested, it must be 11
characters long and include all spaces. This program does not remove the LFs
from the CP/M file as the transfer is made, so a replace command in the Pascal
editor should be used to delete the LFs. During successful file transfers the
program prints an expanded CP/M directory of the file being tranferred.
Attempts to transfer empty or non-existent files are ignored.*)

CONST 
      blkslip = 2;
      quadsperblk = 4;
      trkslip = 6;
      blkspertrk = 6.5;
      secpergrp = 8;
      lastsec = 26;
      lasttrk = 76;

TYPE
    groupbuffer = packed array[0..1023] of char;
    
VAR 
    sectortbl : ARRAY[1..lastsec] OF integer;
    grptrk : ARRAY[1..secpergrp] OF integer;
    grpsec : ARRAY[1..secpergrp] OF integer;
    quadmap : ARRAY[1..lastsec] OF integer;
    blockmap : ARRAY[1..lastsec] OF integer;
    blockbuffer : PACKED ARRAY[0..511] OF char;
    directbuffer : groupbuffer;
    transferbuffer : groupbuffer;
    prevtrk, filectr : integer;
    currfile, filename : string;
    outfile : string;
    file2 : text;

PROCEDURE trackmap(track : integer);

VAR 
    sector,sect,blk,quad,firstsect : integer;
    firstblkquad : real;

BEGIN
  IF track <> prevtrk
  THEN
    BEGIN
      firstblkquad := (track-1)*blkspertrk;
      blk := trunc(firstblkquad);
      firstsect := (((track-1)*trkslip)+1) MOD lastsec;
      quad := trunc((firstblkquad-blk)*quadsperblk);
      sect := firstsect;
      FOR sector := 1 TO lastsec DO
        BEGIN
          blockmap[sect] := blk;
          quadmap[sect] := quad;
          sect := (sect + blkslip) MOD lastsec;
          IF sect = 0
          THEN
            sect := lastsec;
          IF sect = firstsect
          THEN
            sect := sect + 1;
          quad := (quad+1) MOD quadsperblk;
          IF quad = 0
          THEN
            blk := blk + 1
        END
    END
END;

PROCEDURE initsectbl;
BEGIN
  sectortbl[1] := 1;
  sectortbl[2] := 7;
  sectortbl[3] := 13;
  sectortbl[4] := 19;
  sectortbl[5] := 25;
  sectortbl[6] := 5;
  sectortbl[7] := 11;
  sectortbl[8] := 17;
  sectortbl[9] := 23;
  sectortbl[10] := 3;
  sectortbl[11] := 9;
  sectortbl[12] := 15;
  sectortbl[13] := 21;
  sectortbl[14] := 2;
  sectortbl[15] := 8;
  sectortbl[16] := 14;
  sectortbl[17] := 20;
  sectortbl[18] := lastsec;
  sectortbl[19] := 6;
  sectortbl[20] := 12;
  sectortbl[21] := 18;
  sectortbl[22] := 24;
  sectortbl[23] := 4;
  sectortbl[24] := 10;
  sectortbl[25] := 16;
  sectortbl[lastsec] := 22
END;

PROCEDURE cpmgrp(group : integer);

VAR 
    j, track, sector : integer;

BEGIN
  track := ((group * 8) DIV lastsec) + 2;
  sector := ((group * 8) MOD lastsec) + 1;
  FOR j := 1 TO secpergrp DO
    BEGIN
      grptrk[j] := track;
      grpsec[j] := sectortbl[sector];
      sector := sector + 1;
      IF sector > lastsec
      THEN
        BEGIN
          sector := 1;
          track := track + 1
        END
    END
END;

procedure readgroup(group : integer; VAR buffer : groupbuffer);
var
   j, k, l : integer;
begin
  cpmgrp(group);
  l := 0;
  for j := 1 to secpergrp do
    begin
      trackmap(grptrk[j]);
      unitread(5,blockbuffer,512,blockmap[grpsec[j]],0);
      for k := ((quadmap[grpsec[j]])*128) to k+127 do
        begin
          buffer[l] := blockbuffer[k];
          l := l+1
        end
    end
end;

PROCEDURE printentries;

VAR 
    j, k : integer;

begin
  j := 0;
  while j < 1024 do
    BEGIN
      IF (ord(directbuffer[j]) = 0) AND (ord(directbuffer[j+12]) = 0)
         AND (directbuffer[j+1] IN [' '..'Z'])
      THEN
        BEGIN
          FOR k := j+1 TO j+11 DO
            write(directbuffer[k]);
          filectr := filectr + 1;
          IF (filectr MOD 4) = 0
          THEN
            writeln
          ELSE
            write('        ')
        END;
      j := j+32
    END
end;

PROCEDURE findentry;

VAR 
    extent, sectors, j, k, l : integer;
    eoffound : boolean;
BEGIN
  j := 0;
  WHILE j < 1024  DO
    BEGIN
      IF ord(directbuffer[j]) = 0
      THEN
        BEGIN
          currfile := '           ';
          extent := ord(directbuffer[j+12]);
          sectors := ord(directbuffer[j+15]);
          FOR k := j+1 TO j+11 DO
            currfile[k-j] := directbuffer[k];
          IF (currfile = filename) AND (sectors > 0)
          THEN
            BEGIN
              IF extent = 0
              THEN
                BEGIN
                  write('Output Filename.Ext ? ');
                  readln(outfile);
                  rewrite(file2, outfile);
                  writeln(currfile);
                  writeln('Ex Sec Groups')
                END;
              write(extent: 2,sectors: 4);
              FOR k := j+16 TO (k+((sectors-1) DIV 8)) DO
                begin
                  write(ord(directbuffer[k]): 4);
                  readgroup(ord(directbuffer[k]), transferbuffer);
                  l := 0;
                  eoffound := false;
                  WHILE l <= 1023 DO
                    begin
                      IF (ord(transferbuffer[l]) <> 26) and (not eoffound)
                      then
                        write(file2, transferbuffer[l])
                      else
                        begin
                          eoffound := true;
                          write(file2, chr(0))
                        end;
                      l := l + 1
                    end;
                end;
              IF sectors < 128
              THEN
                close(file2,lock);
              writeln
            END
        END;
      j := j+32
    END
END;

BEGIN
  filectr := 0;
  prevtrk := 0;
  initsectbl;
  writeln('CP/M File Transfer, 7-Jun-79');
  readgroup(0, directbuffer);
  printentries;
  readgroup(1, directbuffer);
  printentries;
  writeln;
  writeln(filectr,' Files');
  REPEAT
    REPEAT
      writeln;
      write('Transfer which file ? ');
      readln(filename);
      IF NOT (length(filename) IN [0,11])
      THEN
        BEGIN
          write('Enter 11 character filename exactly as listed');
          writeln(', including spaces,');
          writeln('or CR to exit program.')
        END
    UNTIL length(filename) IN [0,11];
    IF length(filename) = 11
    THEN
      BEGIN
        readgroup(0, directbuffer);
        findentry;
        readgroup(1, directbuffer);
        findentry
      END;
  UNTIL length(filename) = 0;
END
.

========================================================================================
DOCUMENT :usus Folder:VOL01:crc16.text
========================================================================================

;       COMPUTE CRC16 {INTERMEDIATE CALC FOR ONE BYTE}
;       ARGUMENTS ARE THE OLD CRC {TWO BYTES PASSED AS CHAR}
;       AND NEWCHR {THE NEXT BYTE TO BE INCLUDED IN CRC}
;       FUNCTION RETURNS UPDATED CRC AS AN INTEGER
;
;       NEWCRC:=CRC16(CRC0,CRC1,NEWCHR:CHAR):INTEGER
;

        .FUNC    CRC16,3
        .PRIVATE RETADDR
        POP     HL              ;RET ADDR
        LD      (RETADDR),HL     ;SAVE IT
        POP     HL
        POP     HL              ;TWO ZEROS
        POP     DE              ;NEW CHARACTER
        POP     BC              ;FIRST BYTE TO C
        POP     HL
        LD      B,L             ;SECOND BYTE TO B
        LD      HL,0A001H       ;GENERATING POLYNOMIAL
        LD      A,E             ;NEW CHARACTER TO A
        LD      E,8H            ;COUNT OF BITS IN CHAR
CRCY:   RRA                     ;ROTATE RIGHT THRU CARRY
        LD      D,A             ;SAVE IN D
        LD      A,C
        RRA
        LD      C,A             ;SHIFT RIGHTMOST BIT INTO BYTE IN C
        LD      A,B             ;NOW DO 2ND BYTE OF CRC
        RRA
        LD      B,A
        JP      NC,CRCZ         ;NO DIVISION IF NO CARRY
        XOR     L               ;EXCLUSIVE OR WITH L
        LD      B,A
        LD      A,C
        XOR     H               ;EXCLUSIVE OR WITH H
        LD      C,A
CRCZ:   LD      A,D             ;NEW BYTE BACK TO A
        DEC     E               ;DECR BIT COUNT
        JP      NZ,CRCY         ;ITERATE FOR 8 BITS
        LD      HL,(RETADDR)    ;GET BACK RETURN ADDR
        LD      D,C
        LD      E,B             ;SWITCH BYTES
        PUSH    DE              ;FUNCTION RETURN BACK ON STACK
        JP      (HL)            ;BYE
        .END


========================================================================================
DOCUMENT :usus Folder:VOL01:crt.i.o.text
========================================================================================

UNIT CRTINPUT;
  INTERFACE
  
    VAR
        Infilename : string [30];
        Typed: string;
        Infile: text;
    
    PROCEDURE ClearScreen;
    PROCEDURE GetString (x,y, maxlength: integer);
    PROCEDURE GetFile;
    PROCEDURE GetNo (x,y, LowerLimit, UpperLimit: integer;
                 VAR DesiredNo: integer);
    PROCEDURE GetBoolean (x, y: integer;
                      VAR DesiredValue: boolean);
    
    
IMPLEMENTATION

PROCEDURE ClearScreen (*allpurpose, hardware independent*);
VAR Fillcr: ARRAY [1..24] OF char;
    i: integer;
BEGIN
  Gotoxy (0,23);
  FOR i := 1 TO 24 DO Fillcr [i] := CHR (13);
  UNITWRITE (1, Fillcr, 24);
  Gotoxy (0,0)
END;


PROCEDURE GetString;
VAR j, k: integer;
    Gotstring: boolean;
    bell: char;
BEGIN
  bell := CHR (7);
  Gotstring := false;
  REPEAT
    Gotoxy (x,y);
    FOR j := 1 TO maxlength DO write ('.');
    Gotoxy (x,y);
    Readln (typed);
    k := length (typed);
    IF k > maxlength
      THEN BEGIN
        Gotoxy (x,y);
        Write (' ':k);
        Gotoxy (0,23);
        Write (bell, 'You have entered too many characters in this line.  ',
               'Please try again.')
      END
      ELSE Gotstring := true
  UNTIL Gotstring;
  Gotoxy ((x+k),y);
  Write (' ':(maxlength - k));
  Gotoxy (2,22);
  Write (' ':70);
  Gotoxy (0,73);
  Write (' ':70)
END (*GetString*);


PROCEDURE GetFile;

VAR gotfn: boolean;
    bell, response: char;
  
BEGIN
  Bell := CHR (7);
  REPEAT
    Gotoxy (11,20);
    Write ('Please type the name of the file you wish to print.');
    Gotoxy (15,21);
    Write ('-->      ');
    Gotoxy (11,22);
    Write ('  (Or just press the <return> key if you wish to quit.)');
    Typed := '';
    GetString (20,21, 23);
    IF LENGTH (typed) = 0
      THEN BEGIN
        Gotoxy (11,23);
        Write ('Would you prefer to quit this program (Y/N)?     ');
        Read (Keyboard, response);
        Gotoxy (11,23);
        Write (' ':47);
        IF (Response = 'Y') OR (Response = 'y')
          THEN EXIT (Program)
      END
      ELSE BEGIN
        Infilename := Typed;
        (*$I-*)
        Reset (Infile, Infilename);
        IF IORESULT > 0 THEN Reset (Infile, CONCAT (Infilename, '.TEXT'));
        (*$I+*)
        Gotfn := IORESULT = 0;
        IF NOT Gotfn
          THEN BEGIN
            Gotoxy (0,23);
            Write (bell, '<<**** ERROR ****>>   ',
                   'Wrong volume or file name.  Type <space> to continue.');
            REPEAT Read (Keyboard, Response) UNTIL Response = ' ';
            Gotoxy (0,23);
            Write (' ':78)
          END
      END(*else*)
  UNTIL Gotfn;
END (*GetFile*);
  
  
PROCEDURE GetInteger (x,y, LowerLimit, UpperLimit: Integer
                      VAR DesiredNo: Integer);
VAR ch, cr, bell, escape, Backspace: char;
    TypedEscape, Gotit: boolean;
    NumberEntered: integer;
BEGIN
  Backspace := CHR (8);
  Bell := CHR (7);
  cr := CHR (13);
  escape := CHR (27);
  TypedEscape := false;
  Gotit := false;
  WHILE NOT Gotit OR TypedEscape DO
    BEGIN
      NumberEntered := 0;
      REPEAT 
        READ (KEYBOARD, ch);
        IF ch = cr THEN ch := ' ';
        IF (ch IN ['0'..'9']) AND (NumberEntered*10 <= Maxint)
          THEN NumberEntered := NumberEntered*10 + ORD (ch) - ORD ('0');
        IF ch = BackSpace
          THEN BEGIN  (* dump a digit and keep going *)
            ch := '0'     (* stay in this loop *);
            NumberEntered := NumberEntered DIV 10
          END;
        Gotoxy (x,y);
        Write (NumberEntered:3)
      UNTIL (NumberEntered >= UpperLimit) OR NOT (ch IN ['0'..'9']);
      IF ch = escape 
        THEN BEGIN
          Gotoxy (0,23);
          Write (' ':40);
          EXIT (Getinteger)
        END;
      IF (NumberEntered = 0) AND NOT (ch IN [' ', '0'..'9'])
        THEN BEGIN
          Gotoxy (0,23);
          Write (' ':78);
          Gotoxy (0,23);
          Write (bell, 'Please enter a NUMBER between ', LowerLimit, ' and ',
                 UpperLimit);
          Gotoxy (x,y);
          Write ('   ');
          Gotoxy (x,y)
        END
        ELSE IF NumberEntered < LowerLimit
            THEN BEGIN
              Gotoxy (0,23);
              WRITE (' ':40);
              Gotoxy (0,23);
              WRITE (bell, 'Please type a number greater than ', 
                     LowerLimit-1, ': ');
              Gotoxy (x,y)
            END 
            ELSE IF NumberEntered > UpperLimit
              THEN BEGIN
                Gotoxy (0,23);
                WRITE (' ':40);
                Gotoxy (0,23);
                WRITE (bell, 'Please type a number less than ',
                       UpperLimit+1, ': ');
                Gotoxy (x,y)
              END ELSE Gotit := true
      END; (*while*)
  Gotoxy (0,23);
  Write (' ':40);
  DesiredNo := NumberEntered
END; (*GetInteger*)


PROCEDURE GetNo;
BEGIN
  Gotoxy (2,22);
  Write ('Type the desired number, then a space.  To leave unchanged,');
  Write (' type <escape>.');
  Gotoxy (x+3,y);
  GetInteger (x,y, lowerlimit, upperlimit, DesiredNo);
  Gotoxy (2,22);
  Write (' ':76);
  Gotoxy (x,y);
  Write (DesiredNo:3)
END;

PROCEDURE GetBoolean;
VAR ch, escape: char;
BEGIN
  escape := CHR (27);
  Gotoxy (2,22);
  ch := '0';
  Write ('Type "Y" for yes, or "N" for no.', ' ':40);
  Gotoxy (x,y);
  WHILE NOT (ch IN ['Y', 'y', 'N', 'n', escape]) DO Read (keyboard, ch);
  CASE ch OF
    'Y', 'y': BEGIN
                Write ('YES');
                DesiredValue := true
              END;
    'N', 'n': BEGIN
                Write (' no');
                DesiredValue := false
              END
  END;
  Gotoxy (2,22);
  Write (' ':32)
END;


END.


========================================================================================
DOCUMENT :usus Folder:VOL01:diskread.text
========================================================================================

 
 ;  FUNCTION  DISKREAD(TRACK,SECTOR,DISKNO)
 ;
 ;  THIS ROUTINE CALLS THE BIOS ROUTINES TO READ THE SPECIFIED SECTOR
 ;  FROM THE SPECIFIED DISK. THE 128 BYTES READ ARE RETURNED TO A
 ;  PUBLIC ARRAY NAMED IOBUFFER. THIS DISK PRIMITIVE IS PRIMARILY
 ;  INTENDED TO ALLOW PASCAL PROGRAMS TO ACCESS CP/M FILES.
 ;  THE DISK NUMBER MAY BE SPECIFIED EITHER AS 0 OR 1 AS IN THE BIOS
 ;  OR AS 4 OR 5 AS USED BY PASCAL. THE FUNCTION RETURNS A BOOLEAN
 ;  FUNCTION AS AN ERROR CODE. TRUE IF NO ERROR, FALSE FOR ANY DISK
 ;  ERROR.
 ;
        
        .FUNC   DISKREAD,3      ;THREE ARGUMENT
        .PRIVATE RETADDR,DISKNO,SECTOR,TRACK
        .PUBLIC  IOBUFFER
        POP     HL              ;RETURN ADDR
        LD      (RETADDR),HL    ;SAVE RETURN
        POP     HL
        POP     HL              ;TWO ZEROS
        POP     HL              ;DISK NUMBER
        LD      (DISKNO),HL     ;SAVE IT
        LD      A,L             ;DISK NO
        AND     1               ;EXTRACT LEAST SIGNIFICANT BIT
        LD      C,A             ;MOVE IT TO C
        LD      L,1BH           ;SELECT DISK
        CALL    BIOS
        POP     HL              ;SECTOR
        LD      (SECTOR),HL     ;SAVE IT
        LD      A,L             ;SECTOR NO
        CP      28              ;CHECK SIZE
        JP      P,ERROR         ;EXIT ON ERROR
        LD      C,A             ;MOVE TO C
        LD      L,21H           ;SET SECTOR ENTRY
        CALL    BIOS            ;SET SECTOR
        POP     HL              ;TRACK NO
        LD      (TRACK),HL      ;SAVE IT
        LD      A,L             ;TRACK NO
        CP      77              ;CHECK LIMIT
        JP      P,ERROR         ;ERROR IF > 76
        LD      C,A             ;TO C
        LD      L,1EH           ;SET TRACK ENTRY
        CALL    BIOS            ;SELECT TRACK
        LD      BC,IOBUFFER     ;POINT TO INPUT BUFFER
        LD      L,24H           ;SET DMA ENTRY
        CALL    BIOS            ;SET DMA ADDR
        LD      L,27H           ;DISK READ ENTRY
        CALL    BIOS
        OR      A               ;TEST RETURN FLAG
        JP      NZ,ERROR        ;ERROR IF NOT ZERO
EXIT:   LD      HL,(RETADDR)    ;GET BACK RETURN ADDR
        PUSH    DE              ;RETURN ARGUMENT
        JP      (HL)            ;EXIT
ERROR:  LD      DE,0            ;RETURN FALSE
        JP      EXIT
BIOS:   LD`     A,(0002H)       ;PAGE NO IN LOCATION 02H
        LD      H,A
        JP      (HL)
        .END


========================================================================================
DOCUMENT :usus Folder:VOL01:format.doc.text
========================================================================================


     
                              FORMAT DOCUMENTATION

     The following text accompanied the program listing in Pascal News, No. 13 
(December 1978).  For further comments, see "PRETTY.DOC.TEXT" elsewhere on 
this disk.

     
     
What Format Does

     Format is a flexible prettyprinter for Pascal programs.  It takes as 
input a syntactically correct Pascal program and produces as output an 
equivalent but reformatted Pascal program.  The resulting program consists of 
the same sequence of Pascal symbols and comments, but they are rearranged with 
respect to line boundaries and columns for readability.

     Format maintains consistent spacing between symbols, breaks control and 
data structures onto new lines if necessary, indents lines to reflect the 
syntactic level of statements and declarations, and more.  Miscellaneous 
features, such as supplying line numbers and automatic comments or deleting
all unnecessary blanks to save space, are described below.

     The flexibility of Format is accomplished by allowing you to supply 
various directives (options) which override the default values.  Rather than 
being a rigid prettyprinter which decides for you how your program is to be 
formatted, you have the ability to control how formatting is done, not only 
prior to execution, but also during execution through the use of prettyprinter 
directives embedded in your program.

     Experience with Format over the last three years has shown that most 
users can find a set of values for the directives which produce satisfactory 
results.  The default values are typical.

     
How To Use Format

     The use of Format will vary from implementation to implementation, but 
will involve one major input file containing a Pascal program and one output 
file for the reformatted program.  Additionally it may be possible to supply 
the initial values of directives to Format when it begins execution.
[NOTE to UCSD users: I did not implement this feature, though it should be
easy to do.]

     Directives to Format may always be specified in the program itself inside 
comments with a special syntax.  Thus the first line of a program is an ideal 
spot for a comment containing directives.  Subsequent use of embedded 
directives allows you to change the kind of formatting for different sections 
of your program.  The syntax of these special comments is given below (The 
syntax is given using "EBNF"--Extended Backus-Naur Form--see Communications 
ACM, November, 1977, page 822.):

DirectiveComment = "(*" DirectiveList "*)" |
                       "(*$" CompilerOptionList CommentText DirectiveList"*)".

   
   DirectiveList = "["  Directive  {"," Directive}  "]"  CommentText.

       Directive = Letter Setting.

          Letter = "A"| "B"| "C"| "D"| "E"| "F"| "G"| "H"|
                   "I"| "L"| "N"| "P"| "R"| "S"| "W".

         Setting = Switch | Value | Range.

          Switch = "+" | "-".

           Value = "=" Unsigned Integer.
      
           Range = "="UnsignedInteger "-" UnsignedInteger ["<" | ">"].
      
 UnsignedInteger = Digit(Digit).

     CommentText = (Any character except "]" or close-comment).

Note:  As defined above, a Directive may be within a comment specifying a 
Pascal CompilerOptionList.  On most implementations this is a "$" followed by 
a series of letters and values ("+", "-", or digits), separated by commas.  
See your local manual.

Examples of DirectiveComments:

     (*[A=15, E=3, N=1,1<]*) - good for publication quality.
     (*[G-0, W=1-100, C+]*) - good for compact storage.
     (*$U+ [R=1-72, I=2]*) - an example of a DirectiveList with a
                             CompilerOptionList.

     
Directives to Format.

A=n  Align declarations.
        The A directive forces the alignment of ":" and "=" in declarations.  
        If A is set to a value greater than O, then n should be equal to the
        maximum identifier length for that section of your program.  The A
        directive visually clarifies the declaration part of your program.  
        See example below.
        Default:  A=O (no alignment).

 B+ or B-  Bunch statements and declarations reasonably.
        B+ will place as many statements or declarations onto one line as will 
        fit within the specified write margins (W directive) subject to read-
        ability constraints.  Bunching (B+) when the display is off (D-) has 
        no effect.  In general, B+ saves paper and prevents your program from
        becoming overly stretched in the vertical direction.  See example  
        below.
        Default:  B- (one statement or statement part per line).
  
C+ or C-  Fully Compress program.
        C+ removes all non-essential blanks, end-of-lines, and comments from 
        your program.  A compilable, packed program will be written within the
        specified write margins (W directive).  The number of spaces specified
        by the G directive will still be written between symbols.  C+ might 
        save some space on long-term storage media such as disk; you might 
        store a program in compressed form and expand it later by reformatting
        with C-.
        Default:  C-.

D+ or D-  Turn Display on or off.
        D allows you to selectively display portions of your program during 
        formatting.  Therefore, D must be switched on and off with directives
        which are appropriately placed in your program.  D is perhaps useful
        to obtain program fragments for publication (such as one or more pro-
        cedures) without having to print the whole program.
        Default:  D+.
        
E=n  Supply END comments.
        The E directive generates comments after "END" symbols if none are 
        already there.  Common Pascal coding stylms frequently employ these
        comments.  E=1 creates comments after the "END" symbol in compound
        statements which are within structured statements, as well as those
        constituting procedure and function bodies.  The comments take the 
        form:  (*StatementPart*) or (*ProcedureName*).  E=2  creates comments
        after the "BEGIN" and "END" symbols constituting procedure and func-
        tion bodies only.  E=O creates no comments at all.  E=3 means E=1
        and E=2.  See example below.
        Default:  E=2.
        
F+ or F-  Turn Formatting on or off.
        F allows you to format selected portions of your program.  F- causes
        Format to copy the input program directly with no changes.  Therefore
        by switching F on and off with directives which are appropriately
        placed in your program, you can preserve text which is already 
        properly formatted (such as comments).
        Default:  F+ (of course!).
        
G=n  Specify symbol Gap.
        The G directive determines the number of spaces placed between Pascal
        symbols during formatting.  G=O still places one space between two 
        identifiers and reserved words.  The symbols [] () , and : are handled 
        independently of G.  
        Default:  G=1.
        
I=n  Specify Indent tab. 
        I indents each nesting level of statements and declarations a given
        number of columns.  Using  I=2  or  I=1 helps prevent excessively-
        narrow lines within the specified write margins (W directive) where 
        there are heavily-nested constructs.  
        Default:  I=3.
        
L=n  Specify Line-wraparound indent tab.
        L  determines the indentation of the remainder of statements or 
        declarations which are too long to fit on one line.
        Default:  L=3.
        
N=x-y< or N=x-y>  Generate line-numbers on the left or right.
        The N directive indicates the starting line-number (x) and the incre-
        ment (y) for each succeeding line-number.  If y > O then line-numbers
        are written outside the specified write margins for the formatted pro-
        gram in sequential order starting at x; y = O shuts off line-number-
        ing.  "<" writes up to 4-digit, right-justified line numbers together 
        with a trailing space ot the left of each line.  ">" writes 6-digit, 
        zero-filled line numbers to the right of each line.  Use the N 
        directive along with the W directive.
        Default:  N=0-0> (no line numbers).
        
P=n  Specify spacing between Procedure and function declarations.
        The P directive determines the number of blank lines to be placed 
        between procedure and function declarations.  n>2 makes procedures and 
        functions visually stand out.
        Default:  P=2.
        
R=x-y  Specify Read margins.
        The R directive indicates which columns are significant when Format 
        reads from the input file.  R allows Format to accept files which have 
        line numbers in the first (x-1) columns or after the y~h column.
        Default:  R=1-999 (large enough to read end-of-line in most cases).
        
S=n  Specify Statement separation.
        The S directive determines the number of spaces between statements 
        bunched on the same line by the use of the B+ directive.  Note that 
        this directive is in effect only if B+ is used.
        Default:  S=3.
        
W=x-y  Specify Write margins.
        The W directive indicates which columns are used for writing the 
        reformatted program on the output file.  Any line numbers generated (N 
        directive) are written outside these margins.
        Default:  N=1-72.
        


EXAMPLES
        

The A directive.
        
Here is a sample program fragment before using Format:
     
     PROGRAM SAMPLE(OUTPUT);
     CONST A=6; ABC='LETTERS'; THREE=3;
     TYPE RANGE=1..6;
     COLOR=(RED,BLUE);
     VAR
     I,I2,I33,I444,I555:RANGE;
     YES,NO,MAYBE:BOOLEAN;
     BEGIN END.
     
Here is the output from Format with all defaults set:
     
     PROGRAM SAMPLE(OUTPUT);
     
     CONST
        A = 6;
        ABC = 'LETTERS';
        THREE = 3;
     
     TYPE
        RANGE = 1 .. 6;
        COLOR =
           (RED, BLUE);
           
     VAR
        I, I2, I33, I444, I5555: RANGE;
        YES, NO, MAYBE: BOOLEAN;
        
     BEGIN
     END (*SAMPLE*).
     
Here is the output from Format with an added A=5 directive:

     (*[A=5] ALIGN DECLARATIONS.  *)
     PROGRAM SAMPLE(OUTPUT);
     
     CONST
            A = 6;
          ABC = 'LETTERS';
        THREE = 3;
     
     TYPE
        RANGE = 1 .. 6;
        COLOR = (RED, BLUE);
           
     VAR
             I, 
            I2, 
           I33, 
          I444, 
         I5555: RANGE;
           YES, 
            NO, 
         MAYBE: BOOLEAN;
        
     BEGIN
     END (*SAMPLE*).
     
     
The B Directive.

If the input to Format is:

     PROGRAM T(OUTPUT);
     CONST INCREMENT = 5;
     VAR I,J,N:INTEGER;
     BEGIN
     N:=0;
     J:=3; I:=SQR(N); N:=N+INCREMENT;
     IF N>73 THEN BEGIN DOTHIS; DOTHAT END ;
     IF N>5 THEN  IF J>6 THEN DOSOMETHINGELSE;
     END.
     
then the output from Format (using the default, B-) is:

     PROGRAM T(OUTPUT);
     
     CONST
        INCREMENT = 5;
      
     VAR
        I,J,N:INTEGER;
     
     BEGIN
        N:=0;
        J:=3; 
        I:=SQR(N); 
        N:=N + INCREMENT;
        IF N>73 THEN
           BEGIN
              DOTHIS; 
              DOTHAT
           END;
        IF N>5 THEN
           IF J>6 THEN
              DOSOMETHINGELSE;
     END (*T*).
     
and the output from Format with B directives embedded is:

     (*[B+] BUNCH STATEMENTS.  *)
     PROGRAM T(OUTPUT);
     
     CONST
        INCREMENT = 5;
      
     VAR
        I,J,N:INTEGER;
     
     BEGIN
        N:=0;   J:=3;   I:=SQR(N);   N:=N + INCREMENT;
        IF N>73   THEN BEGIN DOTHIS;   DOTHAT END;
     (*[B-] UNBUNCH.  *)
        IF N>5 THEN
           IF J>6 THEN
              DOSOMETHINGELSE;
     END (*T*).
     

The E Directive.

Suppose that a Pascal program fragment looked like:

     PROCEDURE SAMPLE;
       PROCEDURE INNER;
       BEGIN END;
     BEGIN
       IF X=3 THEN
                 BEGIN X := 1; I := I+1
                 END
              ELSE
                BEGIN X := X+I; I := 0
                END;
       WHILE (CH <> 'X') AND FLAG1 DO
         BEGIN I := I+3; INNER END; END;
         
 then using Format with E=3 produces:
 
     PROCEDURE SAMPLE;
       
       
       PROCEDURE INNER;
       
       
          BEGIN 
          END (*INNER*);
     
     
     BEGIN (*SAMPLE*)
        IF X=3 
        THEN
           BEGIN
              X := 1; 
              I := I+1
           END (*IF*)
        ELSE
           BEGIN
              X := X+I; 
              I := 0
           END (*ELSE*);
        WHILE (CH <> 'X') AND FLAG1 DO
           BEGIN
              I := I+3; 
              INNER 
           END (*WHILE*); 
     END (*SAMPLE*);
         
         
 How Format Works.
 
     Format parses your program by performing syntax analysis similar to the 
Pascal compiler:  recursive descent within nested declarations and statements. 
It gathers characters into a buffer in which the indenting count of each 
character is maintained.  The characters are being continually emptied from 
the buffer as new ones are added.

     Format has limited error-recovery facilities, and no results are 
guaranteed if a syntactically incorrect program is input.

     The bane of most Pascal prettyprinters is the treatment of comments.  
Format considers them in the context of a declaration or statement.  Therefore 
using comments like:

     CONST LS=6 (*LINESIZE*);

is a good idea because Format will carry the comment along with the 
declaration.  Similarly:

     BEGIN (* 'Z' < CH <= ' ' *)

is also okay.

     Stand-alone comments, however, receive rough treatment from Format.  The 
first line of such comments is always left justified and placed on a separate 
line.  See the F directive.  Thus:

     CONST LS=6; (*LINESIZE*)

will be reformatted as:

     CONST
        LS = 6;
     (*LINESIZE*)

     Proper treatment of comments is certainly an area of future development 
for Format.

     
Error Messages.

     Format issues the following error messages:

1.  " *** 'PROGRAM' EXPECTED."
     The Pascal program you fed to Format did not contain a Standard Pascal 
program declaration.

2.  " *** ERRORS FOUND IN PASCAL PROGRAM."
     Your program is syntactically incorrect.  The output from Format probably 
does not contain all of the text from your input file.  The cause could be any 
syntactic error, most commonly unmatched "BEGIN-END" pairs or the lack of 
semicolons, string quotation marks, or the final period.

3.  " *** STRING TOO LONG."
     Your program contains a character string (including both the quotes) 
which is wider than the specified write margins (W directive).

4.  " *** NO PROGRAM FOUND TO FORMAT."
     The input file is empty.


========================================================================================
DOCUMENT :usus Folder:VOL01:format.text
========================================================================================

(* PROGRAM Format *)

(*$IFORMAT1.TEXT*)
(*$IFORMAT2.TEXT*)

    
  BEGIN (*DoStatment*)
    BlksOnCurrntLine := 0;  Successful := false;
    BlksAddedByThisStmt := 0;
    ChangeMarginTo (ActualLeftMargin + IndentIndex);
    StartNewLineAndIndent;  StatmtBeginning := CharCount;
    IF SymbolIsNumber
      THEN BEGIN
        WITH UnWritten [Oldest] DO
          BEGIN
            IndentAfterEOL := IndentAfterEOL - 1 - Length - SymbolGap;
            IF IndentAfterEOL < 0 THEN IndentAfterEOL := 0
          END;
        WriteSymbol;  ReadSymbol (*Write LABEL*);  WriteSymbol;
        ReadSymbol (*Write COLON*)
      END;
    CASE StatementTypeOf [SymbolName] OF
      ForWithWhileStatement:
           BEGIN
             (* PACK (Symbol, 1, StatmtSymbol [1]);  EQUIVALENT: *)
             FOR I := 1 TO AlfaLeng DO StatmtSymbol [1, I] := Symbol [I];
             StmtSymLength := Length;
             REPEAT WriteSymbol;  ReadSymbol
             UNTIL SymbolName = DoSymbol;
             WriteSymbol;  ReadSymbol;  StatmtPart [1] := CharCount + 1;
             DoStatement (AddedBlanks, StatmtSymbol, StmtSymLength);
             BlksOnCurrntLine := BlksOnCurrntLine + AddedBlanks;
             BlksAddedByThisStmt := BlksAddedByThisStmt + AddedBlanks;
             Bunch (StatmtBeginning, StatmtPart [1], CharCount, SymbolGap)
           END;
      RepeatStatemtnt:
           DoStmtList (UntilSymbol);
      IfStatement:
           BEGIN
             (* PACK (Symbol, 1, StatmtSymbol [1]);  EQUIVALENT:  *)
             FOR I := 1 TO AlfaLeng DO StatmtSymbol [1, I] := Symbol [I];
             StmtSymLength := Length;
             REPEAT WriteSymbol;  ReadSymbol
             UNTIL SymbolName = ThenSymbol;
             StartNewLineAndIndent;  StatmtPart [1] := CharCount;
             WriteSymbol;  ReadSymbol;  StatmtPart [2] := CharCount + 1;
             DoStatement (AddedBlanks, StatmtSymbol, StmtSymLength);
             BlksOnCurrntLine := AddedBlanks;
             BlksAddedByThisStmt := AddedBlanks;
             Bunch (StatmtPart [1], StatmtPart [2], CharCount, SymbolGap);
             IF Successful
               THEN Bunch (StatmtBeginning, StatmtPart [1], CharCount,
                 StatmtSeparation)
               ELSE IfThenBunchNeeded := true;
             If SymbolName = ElseSymbol
               THEN BEGIN
                 (* PACK (Symbol, 1, StatmtSymbol [1]);  EQUIVALENT:  *)
                 FOR I := 1 TO AlfaLeng DO StatmtSymbol [1, I] := Symbol [I];
                 StmtSymLength := Length;  IfThenBunchNeeded := false;
                 StartNewLineAndIndent;  StatmtPart [3] := CharCount;
                 WriteSymbol;  ReadSymbol;  StatmtPart [4] := CharCount + 1;
                 DoStatement (AddedBlanks, StatmtSymbol, StmtSymLength);
                 BlksOnCurrntLine := AddedBlanks;
                 BlksAddedByThisStmt := BlksAddedByThisStmt + AddedBlanks;
                 Bunch (StatmtPart [3], StatmtPart [4], CharCount, SymbolGap);
                 BlksOnCurrntLine := BlksAddedByThisStmt;
                 IF Successful
                   THEN Bunch (StatmtBeginning, StatmtPart [3], CharCount,
                     StatmtSeparation)
               END
               ELSE IF (CharCount - StatmtBeginning) < BufferSize
                 THEN BEGIN
                   BunchWanted := NOT BunchWanted;
                   BlksOnCurrntLine := 0;
                   Bunch (StatmtBeginning, StatmtPart [1], StatmtPart [2],
                     SymbolGap);
                   BunchWanted := NOT BunchWanted;
                 END;
             IfThenBunchNeeded := false
           END (*IfStatement*);
      CaseStatement:
           BEGIN
             REPEAT WriteSymbol;  ReadSymbol
             UNTIL SymbolName = OfSymbol;
             WriteSymbol;  ReadSymbol;
             ChangeMarginTo (ActualLeftMargin + IndentIndex);
             WHILE SymbolName <> EndSymbol DO
               BEGIN
                 StartNewLineAndIndent;  StatmtPart [1] := CharCount;
                 (* FOR I := 0 TO (Length - 1) DIV AlfaLeng DO
                   PACK (Symbol, (I + AlfaLeng + 1), StatmtSymbol [I + 1]);*)
                 (* EQUIVALENT:  *)
                 FOR I := 0 TO (Length - 1) DIV AlfaLeng DO
                   FOR J := 1 TO AlfaLeng DO
                   StatmtSymbol [I + 1, J] := Symbol [J + I * AlfaLeng];
                 StmtSymLength := Length;
                 REPEAT WriteSymbol;  ReadSymbol
                 UNTIL SymbolName = ColonSymbol;
                 WriteSymbol;  ReadSymbol;
                 IF NOT (SymbolName IN [Semicolon, EndSymbol])
                   THEN BEGIN
                     StatmtPart [2] := CharCount + 1;
                     DoStatement (AddedBlanks, StatmtSymbol, StmtSymLength);
                     BlksOnCurrntLine := AddedBlanks;
                     BlksAddedByThisStmt := BlksAddedByThisStmt + AddedBlanks;
                     Bunch (StatmtPart [1], StatmtPart [2], CharCount, SymbolGap);
                   END;
                 IF SymbolName = Semicolon
                   THEN BEGIN WriteSymbol;  ReadSymbol END
               END (*while*);
             ChangeMarginTo (ActualLeftMargin - IndentIndex);
             StartNewLineAndIndent;  WriteSymbol;  ReadSymbol;
             IF EndCommentsWanted AND (LastSymbol = EndSymbol)
               THEN BEGIN
                 StatmtSymbol [1] := 'CASE      ';  StmtSymLength := 4;
                 WriteComment
               END
           END (*CaseStatement*);
      OtherStatement:
           WHILE NOT (SymbolName IN [Semicolon, UntilSymbol, EndSymbol,
               ElseSymbol]) DO
             BEGIN  WriteSymbol;  ReadSymbol  END;
      CompoundStatement:
           DoStmtList (EndSymbol)
    END (*main case *);
    AddedBlanks := BlksAddedByThisStmt;
    ChangeMarginTo (ActualLeftMargin - IndentIndex);
  END (*DoStatement*);
  

BEGIN (*DoBlock*)
  IF CharCount > BufferSize * 2
    THEN CharCount := (CharCount MOD BufferSize) + BufferSize;
  LastProgPartWasBody := LastProgPartWasBody AND (SymbolName = BeginSymbol);
  IF SymbolName = LabelSymbol THEN DoDeclarationUntil (EndLabel);
  IF SymbolName = ConstSymbol THEN DoDeclarationUntil (EndConst);
  IF SymbolName =  TypeSymbol THEN DoDeclarationUntil (EndType );
  IF SymbolName =   VarSymbol THEN DoDeclarationUntil (EndVar  );
  WHILE SymbolName IN [FuncSymbol, ProcSymbol] DO DoProcedures;
  IF SymbolName = BeginSymbol
    THEN BEGIN
      IF LastProgPartWasBody
        THEN FOR I := 2 TO ProcSeparation DO StartNewLineAndIndent;
      IfThenBunchNeeded := false;  AtProcBeginning := true;
      ChangeMarginTo (ActualLeftMargin - IndentIndex);
      DoStatement (I, BlockName, BlockNmLength) (*I is dummy param*);
      LastProgPartWasBody := true;
      ChangeMarginTo (ActualLeftMargin + IndentIndex)
    END
    ELSE BEGIN  WriteSymbol;  ReadSymbol (*Write FORWARD *) END
END (*DoBlock*);


PROCEDURE Initialize;

VAR I: Width;
    InfileName, OutfileName:  string [25];

BEGIN (*Constants:*)
  Digits := ['0'..'9'];  Letters := ['A'..'Z', 'a'..'z'];
  LettersAndDigits := Letters + Digits;
  AlphaSymbols := [ProgSymbol, BeginSymbol, EndSymbol, ConstSymbol,
      TypeSymbol, RecordSymbol, CaseSymbol, IfSymbol, ThenSymbol,
      ElseSymbol, DoSymbol, OfSymbol, ForSymbol, WithSymbol,
      WhileSymbol, RepeatSymbol, UntilSymbol, Identifier, VarSymbol,
      ProcSymbol, FuncSymbol, LabelSymbol, AlphaOperator];
  EndLabel := [ConstSymbol, TypeSymbol, VarSymbol, ProcSymbol,
      FuncSymbol, BeginSymbol];
  EndConst := EndLabel - [ConstSymbol];
  EndType := EndConst - [TypeSymbol];
  EndVar := EndConst - [VarSymbol];
(* Initialize Column Data: *)
  WriteColumn := 0;  LeftMargin := 0;  ActualLeftMargin := 0;
  OutputCol := 1;  ReadLeftCol := 1;  ReadRightCol := MaxReadRightCol;
  WriteLeftCol := 1;  WriteRightCol := MaxWriteRightCol;  Oldest := 1;
  CharCount := 1;  LineNumber := 0;  Increment := 0;
(* Initialize Boolean Parameters: *)
  PackerIsOff := true;  BunchWanted := false;  DisplayIsOn := true;
  ProcNamesWanted := true;  EndCommentsWanted := false;
  NoFormatting := false;
(* Initialize Numeric Parameters: *)
  IndentIndex := 3;  LongLineIndent := 3;  ProcSeparation := 2;
  SymbolGap := 1;  StatmtSeparation := 3;  DeclarAlignment := 0;
(* Initialize Input Context Data: *)
  ReadColumn := 1;  ChIsEOL := false;  NextChIsEOL := false;
  FOR I := 0 TO BufferSize DO Symbol [I] := ' ';
  LastSymbol := PeriodSymbol;  LastProgPartWasBody := false;
(* Now get filenames *)
  Writeln;
  Writeln ('Welcome to the     P a s c a l   F O R M A T T E R.':60);
  I := 1;
  REPEAT
    Writeln;
    Write ('Please type input file name --> ');
    Readln (Infilename);
    IF Infilename = '' THEN EXIT (Program);
    (*$I-*)
    Reset (Infile, Infilename);
    (*$I+*)
    I := IORESULT;
    IF I > 0 
      THEN BEGIN
        Writeln ('Oops, something''s wrong.  IORESULT = ', I);
        Writeln ('To exit the program, just type <RETURN>.');
      END
  UNTIL I = 0;
  Write ('Now the output filename ("PRINTER:" if you wish to print):  ');
  Readln (Outfilename);
  Rewrite (Outfile, outfilename);
END (*Initialize *);




BEGIN (*MAIN PROGRAM !!!*)
  ConstantsInitialization;  Initialize;
  IF eof(Input)
    THEN Writeln (' *** No Program Found To Format')
    ELSE BEGIN
      ReadACharacter;  ReadSymbol;
      IF SymbolName <> ProgSymbol
        THEN Writeln ('  ***  "PROGRAM" EXPECTED.')
        ELSE BEGIN
        
        
(********************************************************
 *                                                      *
 *      F O R M A T   T H E   P R O G R A M             *
 *      - - - - - -   - - -   - - - - - - -             *
 *                                                      *
 ********************************************************)
 
          StartNewLineAndIndent;  WriteSymbol;  ReadSymbol;
          (* FOR I := 0 TO (Length - 1) DIV AlfaLeng DO
            PACK (Symbol, (I * AlfaLeng + 1), Main [I + 1]); *)
          (*EQUIVALENT:*)
          FOR I := 0 TO (Length - 1) DIV AlfaLeng DO  FOR J := 1 TO AlfaLeng
            DO Main [I + 1, J] := Symbol [J + I * AlfaLeng];
          MainNmLength := Length;
          REPEAT WriteSymbol;  ReadSymbol  UNTIL SymbolName = Semicolon;
          WriteSymbol;  ReadSymbol;  StartNewLineAndIndent;
          DoBlock (Main, MainNmLength);  WriteA ('.');
          FlushUnwrittenBuffer;
          Close (Outfile, lock)
        END
    END
END (*main program *).
    

========================================================================================
DOCUMENT :usus Folder:VOL01:format1.text
========================================================================================

(*$S+*)
PROGRAM Format;

CONST  AlfaLeng = 10;
       MinChar = 0;
       MaxChar = 127;   (* minimum/max char values *)
       LastPascSymbol = 29;
       (* if needed, change the values on the following line TOGETHER *)
       BufferSize = 160; BuffSzP1 = 161; BuffSzM1 = 159; BuffSzDiv10 = 16;
       
       MaxReadRightCol = 999;
       MaxWriteRightCon = 72;
       
TYPE  Alfa = PACKED ARRAY [1..AlfaLeng] OF char;
      CharSet = SET OF char;
      StatmntTypes = (ForWithWhileStatement, RepeatStatement,
                      IfStatement, CaseStatement, CompoundStatement,
                      OtherStatement);
      Symbols = (ProgSymbol, Comment, BeginSymbol, EndSymbol,
                 SemiColon, ConstSymbol, TypeSymbol,
                 RecordSymbol, ColonSymbol, EqualSymbol,
                 PeriodSymbol, Range, CaseSymbol, OtherSymbol,
                 IfSymbol, ThenSymbol, ElseSymbol, DoSymbol,
                 OfSymbol, ForSymbol, WithSymbol, WhileSymbol,
                 RepeatSymbol, UntilSymbol, Identifier,
                 VarSymbol, ProcSymbol, FuncSymbol, LeftBracket,
                 RightBracket, CommaSymbol, LabelSymbol,
                 LeftParenth, RightParenth, AlphaOperator);
      Width = 0..BufferSize;
      Margins = -100..BufferSize;
      SymbolSet = SET OF Symbols;
      OptionSize = -99..99;
      CommentText = ARRAY [1..BuffSzDiv10] OF Alfa;
      SymbolString = ARRAY [Width] OF char; (*the only UNPACKED char array*)
      
VAR  ChIsEOL, NextChIsEOL: Boolean;
     I, J: Integer (*loop counters *);
     Character: char;
     ReadColumn, ReadRightCol: 0..1000;
     Length, Oldest: Width;
     
     OutputCol, WriteColumn, LeftMargin,
     ActualLeftMargin, ReadLeftCol, WriteLeftCol, WriteRightCol : Margins;
     
     DisplayIsOn, ProcNamesWanted, EndCommentsWanted,
     PackerIsOff, SavedBunch, BunchWanted, NoFormatting: boolean;
     
     LineNumber, Increment: integer;
     
     IndentIndex, LongLineIndent, SymbolGap,
     DeclarAlignment, StatmtSeparation, ProcSeparation: OptionSize;
     
     SymbolIsNumber, LastProgPartWasBody: Boolean;
     LastSymbol, SymbolName: Symbols;
     CharCount: integer;
     AlphaSymbols, EndLabel, EndConst, EndType, EndVar: SymbolSet;
     Symbol: SymbolString;
     Digits, Letters, LettersAndDigits: CharSet;
     Main: CommentText;
     MainNmLength: Width;
     Blanks, Zeroes: Alfa;
     UnWritten: ARRAY [Width] OF RECORD
                                   Ch: char;
                                   ChIsEndLine: boolean;
                                   IndentAfterEOL: margins
                                 END;
     PascalSymbol: ARRAY [1..LastPascSymbol] OF Alfa;
     PascSymbolName: ARRAY [1..LastPascSymbol] OF Symbols;
     NameOf: ARRAY [Char] OF Symbols;
     StatementTypeOf: ARRAY [Symbols] OF StatmntTypes;
     Infile, Outfile: text;
     
     
PROCEDURE Const1Init;

BEGIN
  Main [1] := 'MAIN      ';  MainNmLength := 4;
  Blanks := '          ';  Zeroes := '0000000000';
  FOR I := 0 TO BuffSzM1 DO
    WITH UnWritten [I] DO
      BEGIN ch := 'A'; ChIsEndLine := false; IndentAfterEOL := 0
      END;
  FOR Character := Chr (MinChar) TO chr (MaxChar) DO
    NameOf [Character] := OtherSymbol;
  Character := ' '; NameOf ['('] := LeftParenth;
  NameOf [')'] := RightParenth;  NameOf ['='] := EqualSymbol;
  NameOf [','] := CommaSymbol;   NameOf ['.'] := PeriodSymbol;
  NameOf ['['] := LeftBracket;   NameOf [']'] := RightBracket;
  NameOf [':'] := ColonSymbol;   NameOf ['<'] := EqualSymbol;
  NameOf ['>'] := EqualSymbol;   NameOf [';'] := Semicolon;
  PascalSymbol [ 1] := 'PROGRAM   ';  PascalSymbol [ 2] := 'BEGIN     ';
  PascalSymbol [ 3] := 'END       ';  PascalSymbol [ 4] := 'CONST     ';
  PascalSymbol [ 5] := 'TYPE      ';  PascalSymbol [ 6] := 'VAR       ';
  PascalSymbol [ 7] := 'RECORD    ';  PascalSymbol [ 8] := 'CASE      ';
  PascalSymbol [ 9] := 'IF        ';  PascalSymbol [10] := 'THEN      ';
  PascalSymbol [11] := 'ELSE      ';  PascalSymbol [12] := 'DO        ';
  PascalSymbol [13] := 'OF        ';  PascalSymbol [14] := 'FOR       ';
  PascalSymbol [15] := 'WHILE     ';  PascalSymbol [16] := 'WITH      ';
  PascalSymbol [17] := 'REPEAT    ';  PascalSymbol [18] := 'UNTIL     ';
  PascalSymbol [19] := 'PROCEDURE ';  PascalSymbol [20] := 'FUNCTION  ';
  PascalSymbol [21] := 'LABEL     ';  PascalSymbol [22] := 'IN        ';
  PascalSymbol [23] := 'MOD       ';  PascalSymbol [24] := 'DIV       ';
  PascalSymbol [25] := 'AND       ';  PascalSymbol [26] := 'OR        ';
  PascalSymbol [27] := 'NOT       ';  PascalSymbol [28] := 'ARRAY     ';
  PascalSymbol [29] := 'NOSYMBOL  ';   
END;


PROCEDURE ConstantsInitialization;
BEGIN
  Const1Init;
  PascSymbolName [ 1] :=  ProgSymbol;
  PascSymbolName [ 2] := BeginSymbol;  PascSymbolName [ 3] :=    EndSymbol;
  PascSymbolName [ 4] := ConstSymbol;  PascSymbolName [ 5] :=   TypeSymbol;
  PascSymbolName [ 6] :=   VarSymbol;  PascSymbolName [ 7] := RecordSymbol;
  PascSymbolName [ 8] :=  CaseSymbol;  PascSymbolName [ 9] :=     IfSymbol;
  PascSymbolName [10] :=  ThenSymbol;  PascSymbolName [11] :=   ElseSymbol;
  PascSymbolName [12] :=    DoSymbol;  PascSymbolName [13] :=     OfSymbol;
  PascSymbolName [14] :=   ForSymbol;  PascSymbolName [15] :=  WhileSymbol;
  PascSymbolName [16] :=  WithSymbol;  PascSymbolName [17] := RepeatSymbol;
  PascSymbolName [18] := UntilSymbol;  PascSymbolName [19] :=   ProcSymbol;
  PascSymbolName [20] :=  FuncSymbol;  PascSymbolName [21] :=  LabelSymbol;
  PascSymbolName [29] :=  Identifier;
  FOR I := 22 TO 28 DO PascSymbolName [I] := AlphaOperator;
  FOR SymbolName := ProgSymbol TO AlphaOperator DO
    StatementTypeOf [SymbolName] := OtherStatement;
  StatementTypeOf [ BeginSymbol] :=     CompoundStatement;
  StatementTypeOf [  CaseSymbol] :=         CaseStatement;
  StatementTypeOf [    IfSymbol] :=           IfStatement;
  StatementTypeOf [   ForSymbol] := ForWithWhileStatement;
  StatementTypeOf [ WhileSymbol] := ForWithWhileStatement;
  StatementTypeOf [  WithSymbol] := ForWithWhileStatement;
  StatementTypeOf [RepeatSymbol] :=       RepeatStatement;
END (*ConstantsInitialization*);


PROCEDURE WriteA (Character: char);
VAR  I: Width;
     TestNo: Integer;
BEGIN
  CharCount := CharCount + 1;  Oldest := CharCount MOD BufferSize;
  WITH UnWritten [Oldest] DO
    BEGIN
      IF CharCount > BuffSzP1
        THEN BEGIN
          IF ChIsEndLine
            THEN BEGIN
              IF IndentAfterEOL < 0
                THEN BEGIN
                  Write (Outfile, Blanks: - IndentAfterEOL);
                  OutputCol := OutputCol - IndentAfterEOL;
                END
                ELSE BEGIN
                  IF Increment < 0
                    THEN BEGIN
                      I := WriteRightCol - OutputCol + 1;
                      IF I > 0 THEN Write (Outfile, Blanks: I);
                      TestNo := LineNumber;  I := 0;
                      REPEAT TestNo := TestNo DIV 10;  I := I + 1;
                      UNTIL TestNo = 0;
                      Write (Outfile, Zeroes: (6 - I), LineNumber: I);
                      LineNumber := LineNumber + Increment;
                      IF LineNumber > 9999
                      THEN LineNumber := LineNumber - 10000;
                      Writeln (Outfile);
                    END
                    ELSE BEGIN
                      Writeln (Outfile);
                      IF Increment > 0
                        THEN BEGIN
                          Write (Outfile, LineNumber: 4,' ');
                          LineNumber := LineNumber + Increment;
                        END
                    END;
                  IF IndentAfterEOL > 0
                  THEN Write (Outfile, Blanks: IndentAfterEOL);
                  OutputCol := IndentAfterEOL + 1;
                END;
              ChIsEndLine := false;
            END (*IF ChIsEndLine*)
            ELSE BEGIN Write (Outfile, ch);  OutputCol := OutputCol + 1; END;
        END (*IF CharCount > *);
      Ch := Character;  WriteColumn := WriteColumn + 1;
    END (*with*)
END (*WriteA*);


PROCEDURE FlushUnwrittenBuffer;

BEGIN
  WriteA (' ');
  WITH UnWritten [Oldest] DO
    BEGIN  ChIsEndLine := true;  IndentAfterEOL := 0;  END;
  WriteColumn := 0;  FOR I := 0 TO BuffSzM1 DO WriteA (' ');
END;


PROCEDURE StartNewLineAndIndent;

BEGIN
  IF PackerIsOff AND DisplayIsOn
    THEN BEGIN
      WriteA (' '); LastSymbol := PeriodSymbol;
      WITH UnWritten [Oldest] DO
        BEGIN
          ChIsEndLine := true;
          IndentAfterEOL := WriteLeftCol + LeftMargin - 1;
        END;
      WriteColumn := WriteLeftCol + LeftMargin;
    END
END;


PROCEDURE ReadACharacter;

BEGIN
  IF ReadColumn > ReadRightCol
    THEN BEGIN
      IF ReadRightCol < MaxReadRightCol
        THEN BEGIN NextChIsEOL := true;  Readln (Infile)  END
        ELSE ReadColumn := 2
    END
    ELSE IF ReadColumn = 1 THEN
      WHILE ReadColumn < ReadLeftCol DO
        BEGIN
          IF EOLN (Infile) 
            THEN ReadColumn := 1
            ELSE BEGIN ReadColumn := ReadColumn + 1;  Get (Infile) END
        END;
  IF NextChIsEOL
    THEN BEGIN
      Character := ' ';  NextChIsEOL := false; ChIsEOL := true;
      ReadColumn := 1;
      IF NoFormatting
        THEN BEGIN
          WriteA (' ');
          WITH UnWritten [Oldest] DO
            BEGIN
              ChIsEndLine := true;
              IndentAfterEOL := WriteLeftCol - 1;
            END;
          WriteColumn := WriteLeftCol - 1;
        END;
    END
    ELSE IF NOT eof (Infile)
      THEN BEGIN
        Character := Infile^;  ReadColumn := ReadColumn + 1;
        NextChIsEOL := EOLN (Infile);  Get (Infie);  ChIsEOL := false;
        IF NoFormatting THEN WriteA (Character)
      END
      ELSE BEGIN FlushUnwrittenBuffer; EXIT (Program) END
END (*ReadACharacter*);
                                                                                   

PROCEDURE WriteSymbol;

VAR  I: Width;
     NumberBlanksToWrite: OptionSize;

BEGIN
  IF DisplayIsOn
    THEN BEGIN
      NumberBlanksToWrite := SymbolGap;
      IF (LastSymbol IN [LeftParenth, LeftBracket, PeriodSymbol]) OR
          (SymbolName IN [Semicolon, RightParenth, RightBracket,
          CommaSymbol, PeriodSymbol, ColonSymbol]) OR (SymbolName IN
          [LeftBracket, LeftParenth]) AND (LastSymbol = Identifier)
        THEN NumberBlanksToWrite := 0
        ELSE IF (SymbolName IN AlphaSymbols) AND (LastSymbol IN
                AlphaSymbols)
          THEN IF WriteColumn <= WriteRightCol
            THEN BEGIN
              WriteA (' ');  NumberBlanksToWrite := SymbolGap - 1;
            END;
      IF WriteColumn + Length + NumberBlanksToWrite - 1 >
          WriteRightCol
        THEN BEGIN
          WriteA (' ');
          WITH UnWritten [Oldest] DO
            BEGIN
              ChIsEndLine := true;
              IF PackerIsOff
                THEN BEGIN
                  IF WriteLeftCol + LeftMargin + LongLineIndent +
                      Length - 1 > WriteRightCol
                    THEN Length := 10;
                  IndentAfterEOL := WriteLeftCol - 1 + LeftMargin +
                    LongLineIndent;
                  WriteColumn := WriteLeftCol + LeftMargin +
                    LongLineIndent
                END
                ELSE BEGIN
                  IF Length > WriteRightCol - WriteLeftCol + 1
                    THEN Length := WriteRightCol - WriteLeftCol + 1;
                  IndentAfterEOL := WriteLeftCol - 1;
                  WriteColumn := WriteLeftCol
                END;
            END (*with*);
        END (*then*)
        ELSE FOR I := 1 TO NumberBlanksToWrite DO WriteA (' ');
      FOR I := 1 TO Length DO WriteA (Symbol [I]);
    END (*IF DisplayIsOn*);
  LastSymbol := SymbolName
END (*WriteSymbol*);


PROCEDURE CopyACharacter;

BEGIN
  IF DisplayIsOn
    THEN BEGIN
      IF WriteColumn > WriteRightCol
        THEN BEGIN
          WHILE (Character = ' ') AND NOT ChIsEOL DO
            ReadACharacter;
          IF NOT ChIsEOL THEN StartNewLineAndIndent
        END;
      IF ChIsEOL
        THEN BEGIN
          LeftMargin := 0;  StartNewLineAndIndent;
          LeftMargin := ActualLeftMargin
        END
        ELSE WriteA (Character)
    END;
  ReadACharacter
END (*CopyACharacter*);




PROCEDURE DoFormatterDirectives;

CONST  Invalid = -1;
TYPE  ParamCount = 1..2;
      Params = ARRAY [ParamCount] OF integer;
VAR  Specification: Params;
     FormatOption: char;
     PrevDisplay, PrevNoFormatting: boolean;
     EndDirectiv: CharSet;


PROCEDURE ReadIn (N: ParamCount; VAR Specification: Params);

VAR I: ParamCount;

BEGIN
  FOR I := 1 TO N DO
    BEGIN
      WHILE NOT (Character IN (Digits + EndDirectv)) DO CopyACharacter;
      Specification [I] := 0;
      IF NOT (Character IN EndDirectiv)
        THEN 
          REPEAT
            Specification [I] := 10 * Specification [I] + ORD (Character)
              - ORD ('0');
            CopyACharacter
          UNTIL NOT (Character IN Digits)
        ELSE Specification [I] := Invalid;
    END
END (*ReadIn*);


BEGIN (*DoFormatterDirectives*);
  EndDirective := ['*', ']'];
  REPEAT IF Character IN ['A'..'G', 'I', 'L', 'N', 'P', 'R', 'S', 'W']
    THEN BEGIN
      FormatOption := Character;
      CASE FormatOption OF
        'A', 'E', 'I', 'G', 'P', 'L', 'S':
          BEGIN
            ReadIn (1, Specification);
            IF (Specification [1] < WriteRightCol - WriteLeftCol - 9)
                OR (FormatOption = 'P')
              THEN CASE FormatOption OF
                'A':  DeclarAlignment := Specification [1];
                'E':  IF Specification [1] < 4
                        THEN BEGIN
                          ProcNamesWanted := Specification [1] > 1;
                          EndCommentsWanted := Odd(Specification [1])
                        END;
                'G':  SymbolGap := Specification [1];
                'I':  IndentIndex := Specification [1];
                'L':  LongLineIndent := Specification [1];
                'P':  ProcSeparation := Specification [1];
                'S':  StatmtSeparation := Specification [1]
              END (*case*)
          END (*1st 7 letters*);
        'W', 'R', 'N':
          BEGIN
            ReadIn (2, Specification);
            IF Specification [2] <> Invalid
              THEN CASE FormatOption OF
                'W':  IF (Specification [1] > 0) AND (Specification [2] <
                          BufferSize - 2) AND (Specification [2] -
                          Specification [1] > 8)
                        THEN BEGIN
                          WriteLeftCol := Specification [1];
                          WriteRightCol := Specification [2]
                        END;
                'R':  IF (Specification [1] > 0) AND (Specification [2] -
                          Specification [1] > 8)
                        THEN BEGIN
                          ReadLeftCol := Specification [1];
                          ReadRightCol := Specification [2]
                        END;
                'N':  BEGIN
                        LineNumber := Specification [1];
                        Increment := Specification [2];
                        WHILE NOT (Character IN (['<'] + EndDirectv))
                            AND (Character <> '>') DO
                          CopyACharacter;
                        IF Character = '>' THEN Increment := - Increment
                      END
              END (*case*);
          END (*Next 2 letters*);
        'B', 'C', 'D', 'F':
          BEGIN
            REPEAT CopyACharacter
            UNTIL Character IN (['+', '-'] + EndDirectv);
            IF Character IN ['+', '-']
              THEN CASE FormatOption OF
                'B':  IF DisplayIsOn THEN BunchWanted := Character = '+';
                'C':  PackerIsOff := Character = '-';
                'D':  BEGIN
                        PrevDisplay := DisplayIsOn;
                        DisplayIsOn := Character = '+';
                        IF PrevDisplay AND NOT DisplayIsOn
                          THEN BEGIN
                            WriteA ('*'); WriteA (')');
                            SavedBunch := BunchWanted;
                            BunchWanted := false
                          END
                          ELSE IF NOT PrevDisplay AND DisplayIsOn
                            THEN BEGIN
                              StartNewLineAndIndent;  WriteA ('(');
                              WriteA ('*');  BunchWanted := SavedBunch
                            END
                      END;
                'F':  BEGIN
                        PrevNoFormatting := NoFormatting;
                        NoFormatting := Character = '-';
                        DisplayIsOn := NOT NoFormatting;
                        IF PrevNoFormatting AND NOT NoFormatting
                          THEN ReadACharacter;
                        IF NOT PrevNoFormatting AND NoFormatting
                          THEN WriteA ('-');
                      END
              END (*case*)
          END (*boolean parameters*)
      END (*main case statement*);
    END (*then*)
    ELSE IF NOT (Character IN EndDirectv) THEN CopyACharacter
  UNTIL Character IN EndDirectv;
  IF Character = ']' THEN CopyACharacter
END (*DoFormatterDirectives*);




PROCEDURE ReadSymbol;

CONST  ReadNextCh = true;
       DontReadNextCh = false;
VAR  TestSymbol: Alfa;
     CharNumber, I: Width;



PROCEDURE SkipComment;
BEGIN
  REPEAT WHILE Character <> '*' DO ReadACharacter; ReadACharacter
  UNTIL Character = ')';
  ReadACharacter; LastSymbol := comment; ReadSymbol
END;



PROCEDURE DoComment;

VAR  I: OptionSize;

PROCEDURE CompilerDirectives;
BEGIN REPEAT CopyACharacter UNTIL Character IN ['[', '*'] END;

BEGIN (*DoComment*)
  BEGIN
    IF LastSymbol IN [Comment, Semicolon]
      THEN BEGIN
        LeftMargin := 0;  StartNewLineAndIndent;
        LeftMargin := ActualLeftMargin
      END;
    WriteSymbol;  If Character = '$' THEN CompilerDirectives;
    IF Character = '[' THEN DoFormatterDirectives;
    REPEAT WHILE Character <> '*' DO CopyACharacter;  CopyACharacter
    UNTIL Character = ')';
    CopyACharacter;  LastSymbol := Comment;  ReadSymbol
  END
END (*DoComment*);


PROCEDURE CheckFor (SecondChar: char; TwoCharSymbol: Symbols;
  ReadAllowed: Boolean);
BEGIN
  IF ReadAllowed
    THEN BEGIN
      Length := 1;  Symbol[1] := Character;
      SymbolName := NameOf [Character];  ReadACharacter
    END;
  IF Character = SecondChar
    THEN BEGIN
      Symbol [2] := Character;  Length := 2;
      SymbolName := TwoCharSymbol;  ReadACharacter;
      IF (NOT PackerIsOff) AND (SymbolName = Comment) THEN Length := 0
    END
END (*CheckFor*);



========================================================================================
DOCUMENT :usus Folder:VOL01:format2.text
========================================================================================


BEGIN (*ReadSymbol*)
  IF (Character IN Letters)
    THEN BEGIN
      CharNumber := 1;  SymbolIsNumber := false;
      REPEAT
        Symbol [CharNumber] := Character;  ReadACharacter;
        CharNumber := CharNumber + 1
      UNTIL NOT (Character IN LettersAndDigits);
      Length := CharNumber - 1;
      FOR CharNumber := CharNumber TO AlfaLeng DO
        Symbol [CharNumber] := ' ';
        (* PACK (Symbol, 1, TestSymbol); *) 
        (*EQUIVALENT (WITH ADDED UPPER/LOWER CASE TRANSPARENCY):  *)
        FOR I := 1 TO AlfaLeng DO
          BEGIN
            TestSymbol [I] := Symbol [I];
            IF (TestSymbol [I] IN ['a'..'z'])
              THEN TestSymbol [I] := CHR (ORD (TestSymbol [I]) + ORD ('A') -
                ORD ('a'))
          END;
      I := 1;
      PascalSymbol [LastPascSymbol] := TestSymbol;
      WHILE PascalSymbol [I] <> TestSymbol DO I := I + 1;
      SymbolName := PascSymbolName [I]
    END (*letters*)
  ELSE IF (Character IN ['0'..'9', ' ', '(', '.', ':', '''', '<', '>'])
    THEN CASE Character OF
      '(':  BEGIN
              CheckFor ('*', Comment, ReadNextCh);
              IF (SymbolName = Comment) AND PackerIsOff
                THEN DoComment
                ELSE IF SymbolName = Comment THEN SkipComment
            END;
      '0', '1', '2', '3', '4', '5', '6', '7', '8', '9':
            BEGIN
              SymbolIsNumber := true;  CharNumber := 1;
              REPEAT
                Symbol [CharNumber] := Character;  ReadACharacter;
                CharNumber := CharNumber + 1
              UNTIL NOT (Character IN Digits + ['.']);
              IF Character IN ['B', 'E']
                THEN BEGIN
                  Symbol [CharNumber] := Character;  ReadACharacter;
                  CharNumber := CharNumber + 1;
                  IF Character IN Digits + ['+', '-']
                    THEN REPEAT
                      Symbol [CharNumber] := Character;  ReadACharacter;
                      CharNumber := CharNumber + 1
                    UNTIL NOT (Character IN Digits)
                END;
              Length := CharNumber - 1;  SymbolName := Identifier;
            END (*numbers*);
      ' ':  BEGIN
              REPEAT ReadACharacter UNTIL Character <> ' ';  ReadSymbol
            END;
      '>', ':':
            CheckFor ('=', OtherSymbol, ReadNextCh);
      '<':  BEGIN
              CheckFor ('=', OtherSymbol, ReadNextCh);
              IF SymbolName <> OtherSymbol 
                THEN CheckFor ('>', OtherSymbol, DontReadNextCh)
            END;
      '.':  IF LastSymbol <> EndSymbol
              THEN CheckFor ('.', Range, ReadNextCh)
              ELSE SymbolName := PeriodSymbol;
      '''': BEGIN
              CharNumber := 1;
              REPEAT
                REPEAT
                  Symbol [CharNumber] := Character;
                  CharNumber := CharNumber + 1;  ReadACharacter
                UNTIL Character = '''';
                Symbol [CharNumber] := Character;
                CharNumber := CharNumber + 1;  ReadACharacter
              UNTIL Character <> '''';
              Length := CharNumber - 1;  SymbolName := OtherSymbol;
              IF Length > WriteRightCol - WriteLeftCol + 1
                THEN BEGIN
                  FlushUnwrittenBuffer;  WriteLn;
                  Writeln (' *** STRING TOO LONG.');
                  EXIT (Program)
                END;
            END (*string*)
    END (*then case*)
    ELSE BEGIN
      Symbol [1] := Character;  SymbolName := NameOf [Character];
      Length := 1;  ReadACharacter
    END
END (*ReadSymbol*);


PROCEDURE ChangeMarginTo (NewLeftMargin: Margins);

VAR  IndentedLeftMargin: Margins;

BEGIN
  ActualLeftMargin := NewLeftMargin;  LeftMargin := NewLeftMargin;
  IF LeftMargin < 0
    THEN LeftMargin := 0
    ELSE BEGIN
      IndentedLeftMargin := WriteRightCol - 9 - LongLineIndent;
      IF LeftMargin > IndentedLeftMargin THEN LeftMargin := IndentedLeftMargin
    END
END (*ChangeMarginTo*);





PROCEDURE DoDeclarationUntil (EndDeclaration: SymbolSet);




  PROCEDURE DoParentheses;
  
  VAR  SavedLgLnId: OptionSize;
  
  BEGIN
    SavedLgLnId := LongLineIndent;
    IF DeclarAlignment > 0
      THEN BEGIN
        LongLineIndent := WriteColumn + SymbolGap + 1 - LeftMargin -
            WriteLeftCol;
        REPEAT WriteSymbol;  ReadSymbol
        UNTIL SymbolName = RightParenth;
        WriteSymbol;  ReadSymbol
      END
      ELSE BEGIN
        LongLineIndent := 1;
        ChangeMarginTo (ActualLeftMargin + IndentIndex);
        StartNewLineAndIndent;
        REPEAT WriteSymbol;  ReadSymbol
        UNTIL SymbolName = RightParenth;
        WriteSymbol; ReadSymbol;
        ChangeMarginTo (ActualLeftMargin - IndentIndex);
      END;
    LongLineIndent := SavedLgLnId
  END (*DoParentheses*);
  
  
  PROCEDURE DoFieldListUntil (EndFieldList: SymbolSet);
  
  VAR  LastEOL: Margins;  AlignColumn: Width;
  
  
    PROCEDURE DoRecord;
    
    VAR SavedLeftMargin: Width;
    
    BEGIN
      SavedLeftMargin := ActualLeftMargin;  WriteSymbol;  ReadSymbol;
      ChangeMarginTo (WriteColumn - 6 + IndentIndex - WriteLeftCol);
      StartNewLineAndIndent;  DoFieldListUntil ([EndSymbol]);
      ChangeMarginTo (ActualLeftMargin - IndentIndex);
      StartNewLineAndIndent;  WriteSymbol;  ReadSymbol;
      ChangeMarginTo (SavedLeftMargin);
    END (*DoRecord*);
    
    
    PROCEDURE DoVariantRecordPart;
    
    VAR SavedLeftMargin, OtherSavedMargin:  Margins;
    
    BEGIN
      OtherSavedMargin := ActualLeftMargin;
      IF DeclarAlignment > 0
        THEN BEGIN
          REPEAT WriteSymbol;  ReadSymbol
          UNTIL SymbolName IN [ColonSymbol, OfSymbol];
          IF SymbolName = ColonSymbol
            THEN BEGIN
              WriteSymbol;  ReadSymbol;
              WITH UnWritten [LastEOL] DO
                BEGIN
                  IndentAfterEOL := IndentAfterEOL + AlignColumn -
                      WriteColumn;
                  IF IndentAfterEOL < 0 THEN IndentAfterEOL := 0
                END;
              WriteColumn := AlignColumn;
              ChangeMarginTo (ActualLeftMargin + AlignColumn - WriteColumn)
            END
        END (*then*);
      IF SymbolName <> OfSymbol THEN REPEAT WriteSymbol;  ReadSymbol
        UNTIL SymbolName = OfSymbol;
      ChangeMarginTo (ActualLeftMargin + IndentIndex);
      REPEAT
        WriteSymbol;  ReadSymbol;
        IF SymbolName <> EndSymbol
          THEN BEGIN
            StartNewLineAndIndent;
            REPEAT WriteSymbol;  ReadSymbol
            UNTIL SymbolName IN [LeftParenth, SemiColon, EndSymbol];
            IF SymbolName = LeftParenth
              THEN BEGIN
                WriteSymbol;  ReadSymbol;  SavedLeftMargin := ActualLeftMargin;
                ChangeMarginTo (WriteColumn - WriteLeftCol);
                DoFieldListUntil ([RightParenth]);  WriteSymbol;
                ReadSymbol;  ChangeMarginTo (SavedLeftMargin)
              END
          END;
      UNTIL SymbolName <> Semicolon;
      ChangeMarginTo (OtherSavedMargin)
    END (*DoVariantRecordPart*);
    
    
  BEGIN (*DoFieldListUntil*)
    LastEOL := Oldest;
    IF LastSymbol = LeftParenth
    THEN FOR I := 1 TO DeclarAlignment - Length DO WriteA (' ');
    AlignColumn := LeftMargin + WriteLeftCol + DeclarAlignment + 1;
    WHILE NOT (SymbolName IN EndFieldList) DO
      BEGIN
        IF LastSymbol IN [Semicolon, Comment] THEN IF SymbolName <> Semicolon
          THEN BEGIN StartNewLineAndIndent;  LastEOL := Oldest END;
        IF SymbolName IN [RecordSymbol, CaseSymbol, LeftParenth,
            CommaSymbol, ColonSymbol, EqualSymbol]
          THEN CASE SymbolName OF
            RecordSymbol:  DoRecord;
            CaseSymbol:    DoVariantRecordPart;
            LeftParenth:   DoParentheses;
            CommaSymbol, ColonSymbol, EqualSymbol:
                           BEGIN
                             WriteSymbol;
                             IF DeclarAlignment > 0
                               THEN IF NOT (EndLabel <= EndFieldList)
                                 THEN BEGIN
                                   WITH UnWritten [LastEOL] DO
                                     BEGIN
                                       IndentAfterEOL := IndentAfterEOL +
                                         AlignColumn - WriteColumn;
                                       IF IndentAfterEOL < 0
                                         THEN IndentAfterEOL := 0;
                                       WriteColumn := AlignColumn
                                     END;
                                   IF SymbolName = CommaSymbol
                                     THEN BEGIN
                                       StartNewLineAndIndent;  LastEOL := Oldest
                                     END
                                 END (*then*);
                             ReadSymbol
                           END (* , : = *)
          END (*case*)
          ELSE BEGIN WriteSymbol;  ReadSymbol END;
      END (*while*)
  END (*DoFieldListUntil*);
  
  
  
BEGIN (*DoDeclarationUntil*)
  StartNewLineAndIndent;  WriteSymbol;
  ChangeMarginTo (ActualLeftMargin + IndentIndex);
  StartNewLineAndIndent;  ReadSymbol;
  DoFieldListUntil (EndDeclaration);  StartNewLineAndIndent;
  ChangeMarginTo (ActualLeftMargin - IndentIndex)
END (*DoDeclarationUntil*);





PROCEDURE DoBlock (BlockName: CommentText;  BlockNmLength: Width);

VAR  I: Width;  IfThenBunchNeeded, AtProcBeginning: boolean;



  PROCEDURE DoProcedures;
  
  VAR  I: 0..20;
       ProcName: CommentText;
       ProcNmLenght: Width;
       
  BEGIN
    FOR I := 2 TO ProcSeparation DO StartNewLineAndIndent;
    StartNewLineAndIndent;  WriteSymbol;  ReadSymbol;
 (* FOR I := 0 TO (Length - 1) DIV AlfaLeng DO
      Pack (Symbol, I * AlfaLeng + 1, ProcName [I + 1]; *)
    (* Equivalent: *)
    FOR I := 0 TO (Length - 1) DIV AlfaLeng DO FOR J := 1 TO AlfaLeng DO
      ProcName [I + 1, J] := Symbol [J + I*AlfaLeng];
    ProcNmLength := Length;  WriteSymbol;  ReadSymbol;
    IF SymbolName = LeftParenth
      THEN BEGIN
        WriteSymbol;
        REPEAT ReadSymbol;  WriteSymbol
        UNTIL SymbolName = RightParenth;
        ReadSymbol
      END;
    IF SymbolName = ColonSymbol THEN
      REPEAT WriteSymbol;  ReadSymbol UNTIL SymbolName = Semicolon;
    WriteSymbol;  ReadSymbol;
    ChangeMarginTo (ActualLeftMargin + IndentIndex);
    StartNewLineAndIndent;  LastProgPartWasBody := true;
    ChangeMarginTo (ActualLeftMargin - IndentIndex);  WriteSymbol;
    ReadSymbol;  StartNewLineAndIndent
  END (*DoProcedures*);
  
  
  PROCEDURE DoStatement (VAR AddedBlanks: Width; StatmtSymbol:
    CommentText;  StmtSymLength: Width);
    
  VAR  I: Width;
       StatmtBeginning, BlksOnCurrntLine, BlksAddedByThisStmt: integer;
       StatmtPart:  ARRAY [1..4] OF integer;
       Successful: boolean;
       
       
       
    PROCEDURE Bunch (Beginning, Breakpt, Ending: integer;
      StatmtSeparation: OptionSize);
      
    BEGIN
      IF BunchWanted OR IfThenBunchNeeded
        THEN BEGIN
          IF StatmtSeparation < 1 THEN StatmtSeparation := 1;
          BlksOnCurrntLine := BlksOnCurrntLine + StatmtSeparation - 1;
          Successful := ((Ending - Beginning + BlksOnCurrntLine +
            UnWritten [Beginning MOD BufferSize].IndentAfterEOL) |
            WriteRightCol) AND (CharCount - Beginning < BufferSize);
          IF Successful
            THEN BEGIN
              BlksAddedByThisStmt := BlksAddedByThisStmt +
                StatmtSeparation - 1;
              UnWritten [Breakpt MOD BufferSize].IndentAfterEOL :=
                - StatmtSeparation;
            END
        END
    END (*bunch*);
    
    
    PROCEDURE WriteComment;
    
    VAR  I, SavedLength: Width;
         SavedSymbolName: Symbols;
         SavedChars:  SymbolString;
         
    BEGIN
      SavedSymbolName := SymbolName;
      FOR I := 1 TO Length DO SavedChars [I] := Symbol [I];
      SavedLength := Length;  SymbolName := OtherSymbol;
      Symbol [1] := '(';  Symbol [2] := '*';  Length := 2;  WriteSymbol;
   (* FOR I := 0 TO (StmtSymLength - 1) DIV AlfaLeng DO
        Unpack (StatmtSymbol [I + 1], Symbol, (I * AlfaLeng + 1));*)
      (* EQUIVALENT:  *)
      FOR I := 0 TO (StmtSymLength - 1) DIV AlfaLeng DO FOR J := 1 TO AlfaLeng
        DO Symbol [J + I * AlfaLeng] := StatmtSymbol [I + 1, J];
      Length := StmtSymLength;  SymbolName := PeriodSymbol;
      LastSymbol := PeriodSymbol;  WriteSymbol;  Symbol [1] := '*';
      Symbol[2] := ')';  Length := 2;  WriteSymbol;
      SymbolName := SavedSymbolName;  Length := SavedLength;
      FOR I := 1 TO Length DO Symbol [I] := SavedChars [I]
    END (*WriteComment*);
    
    
    PROCEDURE DoStmtList (EndList: Symbols);
    
    VAR  BlksAfterPrt2: Width;
         AtProcEnd: boolean;
    
    BEGIN
      AtProcEnd := AtProcBeginning;  WriteSymbol;  ReadSymbol;
      StatmtPart [1] := CharCount + 1;  StatmtPart [2] := StatmtPart [1];
      IF SymbolName <> EndList
        THEN BEGIN
          IF ProcNamesWanted THEN IF AtProcBeginning THEN IF
            LastProgPartWasBody THEN IF LastSymbol = BeginSymbol
              THEN WriteComment;
          AtProcBeginning := false;
          DoStatement (AddedBlanks, StatmtSymbol, StmtSymLength);
          BlksAfterPrt2 := AddedBlanks;
          BlksAddedByThisStmt := BlksAddedByThisStmt + AddedBlanks;
          WHILE SymbolName <> EndList DO
            BEGIN
              WriteSymbol;  ReadSymbol;
              IF SymbolName <> EndList
                THEN BEGIN
                  StatmtPart [3] := CharCount + 1;
                  DoStatement (AddedBlanks, StatmtSymbol, StmtSymLength);
                  BlksOnCurrntLine := AddedBlanks + BlksAfterPrt2;
                  BlksAddedByThisStmt := BlksAddedByThisStmt + AddedBlanks;
                  Bunch (StatmtPart [2], StatmtPart [3], CharCount,
                    StatmtSeparation);
                  IF NOT Successful
                    THEN BEGIN
                      BlksAfterPrt2 := AddedBlanks;
                      StatmtPart [2] := StatmtPart [3];
                    END
                    ELSE BlksAfterPrt2 := BlksOnCurrntLine;
                END (*then*)
            END (*while*)
        END (*main then*);
      BlksOnCurrntLine := BlksAddedByThisStmt;
      Bunch (StatmtBeginning, StatmtPart [1], CharCount, SymbolGap);
      StartNewLineAndIndent;  StatmtPart [1] := CharCount;
      REPEAT WriteSymbol;  ReadSymbol
      UNTIL SymbolName IN [Semicolon, UntilSymbol, EndSymbol, ElseSymbol,
          PeriodSymbol];
      IF Successful
        THEN BEGIN
          IF EndList = UntilSymbol
            THEN StatmtPart [4] := StatmtSeparation
            ELSE StatmtPart [4] := SymbolGap;
          Bunch (StatmtBeginning, StatmtPart [1], CharCount, StatmtPart [4]);
        END;
      IF NOT (Successful AND BunchWanted)
        THEN IF EndList = EndSymbol THEN IF LastSymbol = EndSymbol THEN
          IF AtProcEnd AND ProcNamesWanted THEN WriteComment
    END (*DoStmtList*);
  

========================================================================================
DOCUMENT :usus Folder:VOL01:getcpm.text
========================================================================================

PROGRAM GETCPM;
(* COPYRIGHT 1979 BY BARRY A. COLE *)
  CONST SPACES='            '; BUFSIZE=32750;
  VAR I,J,K,INDEX,NEXTEX,BIGP,BLANKS,BLOCKS,ROOM,COL: INTEGER;
      DISKBUF: PACKED ARRAY[0..1023] OF CHAR;
      BIGBUF: PACKED ARRAY[0..BUFSIZE] OF CHAR;
      F:FILE; DELAY: CHAR; CPMTITLE,PASCTITLE: STRING[13];
      EXTENTS: ARRAY[1..64] OF INTEGER;
      NEWLINE: BOOLEAN;

PROCEDURE READCPM(PARAM: INTEGER); EXTERNAL;
procedure tack(value:integer);
  begin
  if bigp=bufsize then begin write(chr(value));
    exit(tack); end;
  bigbuf[bigp]:=chr(value); bigp:=bigp+1; col:=col+1;
  end;
procedure putit(ind: integer);
  begin
  if ord(diskbuf[ind])<>0 then begin
    extents[nextex]:=ord(diskbuf[ind]); nextex:=nextex+1; end;
  end;
PROCEDURE SEARCH;
  VAR FOUND: BOOLEAN; K,BLOCK,I: INTEGER;
  BEGIN
  FOR BLOCK:=0 TO 1 DO BEGIN
    READCPM(BLOCK);
    FOR I:=0 TO 31 DO BEGIN FOUND:=TRUE;
      FOR J:=1 TO 11 DO 
        IF DISKBUF[32*I+J]<>CPMTITLE[J] THEN FOUND:=FALSE;
      IF FOUND THEN FOR K:=32*I+16 TO 32*I+31 DO PUTIT(K);
      END;
    END;
  END; {eop search}
procedure process;
  var i,tabcol: integer;
  begin
  for i:=1 to nextex-1 do
    begin
    READCPM(extents[i]);
    FOR J:=0 TO 1023 DO BEGIN
      K:=ORD(DISKBUF[J]);
      IF K=26 THEN EXIT(PROCESS); {EOF FOUND}
      IF (K<>32) AND NEWLINE THEN BEGIN 
        TACK(16); TACK(BL{NKS); COL:=BLANKS-32;
        BLANKS:=32; NEWLINE:=FALSE; END;
      IF (K=32) AND NEWLINE THEN BLANKS:=BLANKS+1
        ELSE IF K>=32 THEN TACK(K);
      IF K=9 THEN FOR TABCOL:=COL MOD 8 TO 7 DO TACK(32); {TAB}
      IF K=13 THEN BEGIN {CR}
        TACK(13); NEWLINE:=TRUE; BLANKS:=32;
        ROOM:=1024-(BIGP MOD 1024);
        IF ROOM<82 THEN REPEAT BEGIN
          TACK(0); ROOM:=ROOM-1; END UNTIL ROOM=0;
        END;
      END;
    end;
  end; {end of process }

  BEGIN
  REPEAT BEGIN
   WRITELN('PLACE CP/M DISK IN DRIVE A');
   WRITE('FILE NAME? '); READLN(CPMTITLE); I:=POS('.',CPMTITLE);
   END UNTIL (I>0) AND (I<10);
   {IF (I=0) OR (I>9) THEN WRITELN('ILLEGAL FILE NAME FORMAT')
     ELSE BEGIN }
  PASCTITLE:=CONCAT(COPY(CPMTITLE,1,I),'TEXT');
  CPMTITLE:=CONCAT(COPY(CPMTITLE,1,I-1),
  COPY(SPACES,1,9-I),COPY(CPMTITLE,I+1,3));
      {END;}
  WRITELN('SEARCHING FOR "',CPMTITLE,'"');
  BLANKS:=32; NEWLINE:=TRUE; BIGP:=0; NEXTEX:=1; SEARCH;
  IF NEXTEX=1 THEN WRITELN('FILE NOT FOUND')
  ELSE BEGIN
    WRITELN('FILE IS ',NEXTEX-1,' EXTENT(S) LONG');
    PROCESS;
    BLOCKS:=(BIGP DIV 512)+2;
    FOR I:=BIGP TO BLOCKS*512-1 DO BIGBUF[I]:=CHR(0);
    WRITELN('PLACE PASCAL DISK IN DRIVE A, HIT KEY WHEN READY');
    READ(DELAY); {SWITCH DISK DELAY }
    WRITELN('WRITING ',BLOCKS+2,' BLOCKS TO ',PASCTITLE);
    REWRITE(F,PASCTITLE);
    IF BLOCKS<31 THEN J:=BLOCKWRITE(F,BIGBUF,BLOCKS,2)
      ELSE BEGIN J:=BLOCKWRITE(F,BIGBUF,30,2);
           J:=BLOCKWRITE(F,BIGBUF[15360],BLOCKS-30,32); END;
    CLOSE(F,LOCK);
    END;
  END.


========================================================================================
DOCUMENT :usus Folder:VOL01:getcpm2.text
========================================================================================

PROGRAM GETCPM;
(* COPYRIGHT 1979 BY BARRY A. COLE *)
(*  GET SOURCE FILE FROM CPM DISK(#5)
      AND PUT ON PASCAL DISK(#4) *)
  CONST SPACES='            ';
  VAR I,J,K,INDEX,NEXTEX,BIGP,BLANKS,BLOKNUM,ROOM,COL: INTEGER;
      DISKBUF,BIGBUF: PACKED ARRAY[0..1023] OF CHAR;
      NEWLINE: BOOLEAN; F:FILE; CPMTITLE,PASCTITLE: STRING[13];
      EXTENTS: ARRAY[1..255] OF INTEGER;

PROCEDURE RWCPM(XTENT,RWFLAG: INTEGER); EXTERNAL;
procedure tack(value:integer);
  var retcd: integer;
  begin
  bigbuf[bigp]:=chr(value); bigp:=bigp+1; col:=col+1;
  if bigp=1024 then begin
    write('P'); retcd:=blockwrite(f,bigbuf,2,bloknum);
    bloknum:=bloknum+2; bigp:=0; end;
  end;
procedure putit(ind: integer);
  begin
  if ord(diskbuf[ind])<>0 then begin
    extents[nextex]:=ord(diskbuf[ind]); nextex:=nextex+1; end;
  end;
PROCEDURE SEARCH;
  VAR FOUND: BOOLEAN; K,BLOCK,I: INTEGER;
  BEGIN
  FOR BLOCK:=0 TO 1 DO BEGIN
    RWCPM(BLOCK,0);
    FOR I:=0 TO 31 DO BEGIN FOUND:=TRUE;
      FOR J:=1 TO 11 DO 
        IF DISKBUF[32*I+J]<>CPMTITLE[J] THEN FOUND:=FALSE;
      IF FOUND THEN FOR K:=32*I+16 TO 32*I+31 DO PUTIT(K);
      END;
    END;
  END; {eop search}
procedure process;
  var i,tabcol: integer;
  begin
  for i:=1 to nextex-1 do
    begin
    WRITE('C'); RWCPM(extents[i],0);
    FOR J:=0 TO 1023 DO BEGIN
      K:=ORD(DISKBUF[J]);
      IF K=26 THEN EXIT(PROCESS); {EOF FOUND}
      IF (K<>32) AND NEWLINE THEN BEGIN 
        TACK(16); TACK(BLANKS); COL:=BLANKS-32;
        BLANKS:=32; NEWLINE:=FALSE; END;
      IF (K=32) AND NEWLINE THEN BLANKS:=BLANKS+1
        ELSE IF K>=32 THEN TACK(K);
      IF K=9 THEN FOR TABCOL:=COL MOD 8 TO 7 DO TACK(32); {TAB}
      IF K=13 THEN BEGIN {CR}
        TACK(13); NEWLINE:=TRUE; BLANKS:=32;
        ROOM:=1024-(BIGP MOD 1024);
        IF ROOM<82 THEN REPEAT BEGIN
          TACK(0); ROOM:=ROOM-1; END UNTIL ROOM=0;
        END;
      END;
    end;
  end; {end of process }

  BEGIN
  REPEAT BEGIN
   WRITELN('PLACE CP/M DISK IN DRIVE B');
   WRITE('FILE NAME? '); READLN(CPMTITLE); I:=POS('.',CPMTITLE);
   END UNTIL (I>0) AND (I<10);
  PASCTITLE:=CONCAT(COPY(CPMTITLE,1,I),'TEXT');
  CPMTITLE:=CONCAT(COPY(CPMTITLE,1,I-1),
  COPY(SPACES,1,9-I),COPY(CPMTITLE,I+1,3));
  WRITELN('SEARCHING FOR "',CPMTITLE,'"');
  BLANKS:=32; NEWLINE:=TRUE; BIGP:=0; NEXTEX:=1; SEARCH;
  IF NEXTEX=1 THEN WRITELN('FILE NOT FOUND')
  ELSE BEGIN
    WRITELN('FILE IS ',NEXTEX-1,' EXTENT(S) LONG');
    REWRITE(F,PASCTITLE); BLOKNUM:=0;
    FOR I:=0 TO 1023 DO IF I=122 THEN TACK(63)
      ELSE IF I=124 THEN TACK(5) ELSE TACK(0);
    PROCESS;
    FOR I:=BIGP TO 1024 DO TACK(0); {PUT OUT LAST SECTION}
    CLOSE(F,LOCK); WRITELN;
    WRITELN(BLOKNUM,' BLOCKS HAVE BEEN WRITTEN TO ',PASCTITLE);
    END;
  END.


========================================================================================
DOCUMENT :usus Folder:VOL01:gotcha.doc.text
========================================================================================


     
             HIDDEN GOTCHA DOCUMENTATION FOR GETTING UP UCSD PASCAL

     I bought the first UCSD system advertised for the Z-80 nearly two years 
ago; it took me nearly six months to get it to run properly.  Many of the 
difficulties with which I had to contend are now adequately documented, but I
will present them here anyway for your edification.

     Most of my difficulties were in getting the CRT to handle the demands of 
the text editor.  I would recommend that you handle the maximum number of CRT 
character manipulation within your BIOS in machine code, for purposes of 
speed.  I had to contend with a memory-mapped video terminal, which did 
nothing but what was programmed; others have had to work their way around a 
"dumb" terminal, such as an ADM-3.  If you have one of the newer generation of 
CRT terminals with cursor addressing, line and screen erasure, and line 
insertion and deletion, then you should have no problem; just follow the 
directions in SETUP.  Don't forget to ensure that you save your product from 
your session with SETUP on the disk, and that this file is called
"SYSTEM.MISCINFO".  This file is read in at boot time and is used by the
editor.

     There are two other items to which you with the better terminals will
need to attend.  First, make sure that your screen is cleared if your BIOS
receives an ASCII FORMFEED (12 decimal; 0C hex): change this to whatever your
CRT actually requires within the BIOS.  Similarly, your printer driver should
cause a formfeed (go to the top of the next page) upon receipt of the same
character.  This way, your CRT and printer will respond appropriately if
someone writes a "PAGE (output)" within a Pascal program, and the hideous 
machination of having to rewrite a "ClearScreen" procedure for each program 
can finally end.

     Second, follow the directions in BINDER to set up a valid GOTOXY
procedure and bind it into the system.  Since the normal SYSTEM.EDITOR will do
<very> strange things until there is a valid GOTOXY within the SYSTEM.PASCAL,
you will have to use YALOE, the line editor, to write this program (either
temporarily rename this SYSTEM.EDITOR or get to it by typing "X" for X(ecute,
while at the Command level, then type "YALOE <return>").  Note that once the 
GOTOXY is present within your system, it can be used as a standard procedure 
within your programs, as well.

     However, there are several gotchas in writing the GOTOXY procedure: 1) it 
must be written in Pascal; there is no way that BINDER will accept an assembly 
language program.  2) The brute force way is to print a series of 
"nondestructive forward spaces" for the horizontal dimension (X), and a series 
of line feeds for Y.  While acceptable, this is too slow (the screen editor is 
always going to XY), and you have to avoid the mistake of writing SPACES for 
X, like I first did (and you can imagine that the guys at UCSD had NO idea 
what was wrong), erasing the first part of the line you are on.  3)The best 
way is to output a character or series of characters which toggle a GOTOXY
sequence, followed by the X and the Y dimensions.  You MUST, however, be sure 
to add 32 (20 hex) to both X and Y before sending them, and then remove this 
when forcing the GOTOXY in the BIOS.  (Most intellegent terminals require that
32 be added to both dimensions, so if you have one, don't you go stripping
this off in advance.)  The reason for this requirement is that the interpreter 
always adds a linefeed when it sees a 13 (hex 0D, ASCII carriage return), and 
treats a 16 (10H) as a special code indicating that the next character is the 
number of spaces to insert at this point.  Don't forget these two characters 
when designing your BIOS control characters, either.

     Once you have figured out the best way to set up a GOTOXY, write a Pascal 
procedure that will call it.  Don't forget to include range-checking somewhere 
in the system (IF x < 0 THEN x = 0;  IF x > MaxCharsPerLine THEN x = 
MaxCharsPerLine (*whatever this is in your system - substitute the real 
number*)).  When you type this in, call your procedure and your file "GOTOXY1"
or some other name not identical with "GOTOXY", or you will confuse the
system.  Further, the procedure must be part of a program or it will not
compile; start your text file with a program declaration (like "PROGRAM
DUMMY;") and end it with a dummy "BEGIN"-"END." pair (and don't forget the
period).  Finally, compile the program; make up a disk with nothing on it but
your program, SYSTEM.PASCAL and the BINDER.CODE (needs a lot of room); and
then X(ecute BINDER, giving it the name of your CODE file.  When you're all 
done, save the new SYSTEM.PASCAL on all your system disks;  make it the first 
file on the disk and you won't have to reboot every time you K(runch a disk.

     There is a table of reserved characters at the end of this file; be cer-
tain your system can handle them.

     
For those souls with dumb terminals or memory-mapped CRT's.

     First, if you skipped the above discussion, you'd better go back and read 
it; it applies to you, too.

     Next, it will be up to you to design a BIOS that will handle the demands 
of Pascal.  As it turns out, this is also useful if you use WordStar or 
certain other sophisticated CP/M text editors; your effort will net you many 
gains.

1.  Basic necessities.

     Your BIOS-terminal (or BIOS-CRT) combination will have to support the 
following basic commands:
        a.  GOTOXY (see the previous discussion).
        b.  One-character cursor movement in all 4 directions, without erasing
underlying text.  This works out to a backspace, a nondestructive-forward-
space, a line feed, and a reverse line feed.  Note that the horizontal 
movement should NOT take you off a given line, and that the reverse line feed 
need not bring you higher than the top of the screen (ie, no reverse scroll 
required, although if you have it is OK).  However, it is expected that if a
line feed occurs when the cursor is on the last line, the CRT will scroll and 
display a blank last line.
        c.  Automatic expansion of ASCII horizontal tabs (8) to the next eighth
column. Make sure underlying text is not erased (write nondestructive spaces
to the next eighth column).  Your PRINTER must handle this command, as well
(note the difference from CP/M).
        d.  Your system must either beep or do nothing upon receipt of an ASCII
bell (7), and is expected to do nothing if it receives a NUL (00).  One
recommendation: if your system makes a sound when it receives a bell
character, make sure it is pleasant -- UCSD uses it a lot.
        e. A home-cursor command (to the upper left corner).
        f.  Erase-to-end-of-line and erase-to-end-of-screen commands.  Cursor
location must not be disturbed.

     Next, NOTHING should take you to another line but a line feed or
vertical cursor movement.  In particular, horizontal cursor movement and text
hanging over the end of a line should be gobbled.  Otherwise, especially with
screen sizes smaller than 24x80, your displays will be very strange.

2.  Features desirable but not essential.

     The following commands are strongly advised.
        a.  Clear screen and home cursor, driven by an ASCII formfeed (12., 0C 
hex).
        b.  If easily implemented on your system, insert-line and delete-line 
commands.  These involve moving text below the line involved either down or
up one line, to either make room for the insertion or cover up the deletion, 
respectively.
        c.  Some way of stopping a display as it's going by, useful while 
examining files while in the F(iler.  For systems with an interrupt-driven 
keyboard, this is easy -- your interrupt handler simply examines whatever 
you've just typed; if it's your "freeze output" command, then the system hangs 
up until the command is typed a second time.  Usually, this command is a 
"control S" or 13 hex.  If you have a polled keyboard (the most common kind), 
then the simplest way to freeze your CRT is to see if a keyboard character has 
been typed at the time of each linefeed, and proceeding as for an interrupt-
driven system if so.
        d.  UCSD recommends a "dump output" command in addition to the "stop 
output" command.  "Dumping" output is just that -- any characters going to 
your CRT are ignored.  I haven't used this much, and I feel it would be much 
more important if you have a slow terminal, such as one that writes on paper.  
It is implemented in the same manner as noted above in c.
        e.  At the time you set up stop and/or dump output commands, it is 
simple to make the commands extend to the printer, as well.

     Finally, here is a list of embellishments:
        a.  I have an interrupt-driven keyboard, and I have found that a 
keyboard queue is extremely useful.  It works like this:  any characters I 
type, up to a maximum of 16, are accepted by the interrupt handler and stored 
in a buffer.  The characters are removed in a first-in, first-out fashion when 
the requesting program is ready to accept them by the console input routine. 
The advantages of this setup are two: 1) my system never drops characters if
it is in the middle of doing something while I am typing away, and 2) I can
type a series of those UCSD one-letter commands, each of which produces action
with the disk, and avoid slowing down the system performance which it is
waiting for me to type something after doing something.  Normally, you can
keep only one character ahead. 
        b.  I think it's useful to have a control-character toggle that
forces your printer to follow your CRT output.  This is helpful for recording
program bugs during compilation, for instance. 
        c.  My system has another toggle character which, together with a
series of secondary commands, allows you to: 1) slow down the rate of
scrolling as desired, and 2) switch to a page mode of text outputting, where
the screen is filled with text and the system waits until a character is typed
before erasing the screen and filling it up again.  In this mode, characters
hanging over the end of a line are moved to the start of the next one, so I
miss nothing.
        d.  Since normally, every ASCII carriage return (13, 0D hex) is
followed by an obligate line feed, I think it's useful to designate another
control character as an alternate carriage return.  This way, my printer can 
go over the same line of text to underline or retype for boldface.

     
     A TABLE OF RESERVED CONTROL CHARACTERS  -- UCSD PASCAL

     Character  Meaning                         Must be recognized by:
     (decimal)                                 CRT              PRINTER
        
        00      NUL (do nothing)                X                  X
        07      BEL (beep! or nothing)          X                  X
        08      HTAB (horizontal tab)           X                  X
        09      BACKSPACE                       X               optional
        10      LINEFEED                        X                  X
        12      FORMFEED                    recommended       recommended
        13      CARRIAGE RETURN                 X                  X
        16      compressed blanks symbol        no (handled by in- no
                        ** avoid **                  terpreter)
     
     
Some final remarks.

     Pascal uses a great deal of memory, and anything you can do to increase 
the RAM available to the UCSD system will repay you handsomely.  If you aren't 
doing much in the way of mathematics, reassemble the interpreter without the 
transcendental mathematical functions; the 1K space saved is worth the hassle 
of going to another disk with the complete system if you need it.  Because I 
have a memory-mapped terminal and most of my console and printer driver 
software on EPROM, taking up 8K of room, I am trying to get a bank switching 
scheme going so I can replace that 8K with RAM and then switch to the console 
drivers when needed, character by character.

     I recognize that for a novice without much programming experience, the 
above considerations must seem totally overwhelming.  You're probably better 
off buying a system that someone has already set up and has running.  However,
if you've had SOME assembly language experience, get the CP/M-compatible disk
from us that has complete BIOS drivers already present, with a good deal of
help on one of them (BOOTER) to assist you in reconfiguring the drivers to
your system.

========================================================================================
DOCUMENT :usus Folder:VOL01:initvar.text
========================================================================================

PROCEDURE Initvar1; (* initializing the following variables: *)
     (VAR topofstack, currlinepos, currmargin: integer; 
      VAR keyword         : keywordtable; VAR dblchars          : dblchrset;
      VAR dblchar         : dblchartable; VAR sglchar           : sglchartable;
      VAR recordseen      : boolean;      VAR currchar, nextchar: charinfo;
      VAR currsym, nextsym: symbolinfo);
BEGIN
  topofstack  := 0;
  currlinepos := 0;
  currmargin  := 0;
  recordseen  := false;
  
  keyword [progsym   ] := 'program   ';
  keyword [funcsym   ] := 'function  ';
  keyword [procsym   ] := 'procedure ';
  keyword [labelsym  ] := 'label     ';
  keyword [constsym  ] := 'const     ';
  keyword [typesym   ] := 'type      ';
  keyword [varsym    ] := 'var       ';
  keyword [beginsym  ] := 'begin     ';
  keyword [repeatsym ] := 'repeat    ';
  keyword [recordsym ] := 'record    ';
  keyword [casesym   ] := 'case      ';
  keyword [casevarsym] := 'case      ';
  keyword [ofsym     ] := 'of        ';
  keyword [forsym    ] := 'for       ';
  keyword [whilesym  ] := 'while     ';
  keyword [withsym   ] := 'with      ';
  keyword [dosym     ] := 'do        ';
  keyword [ifsym     ] := 'if        ';
  keyword [thensym   ] := 'then      ';
  keyword [elsesym   ] := 'else      ';
  keyword [endsym    ] := 'end       ';
  keyword [untilsym  ] := 'until     ';
  
  dblchars := [becomes, opencomment];
  dblchar [becomes ] := ':=' ;
  dblchar [opencomment] := '(*' ;
  
  sglchar [semicolon   ] := ';' ;
  sglchar [colon       ] := ':' ;
  sglchar [equals      ] := '=' ;
  sglchar [openparen   ] := '(' ;
  sglchar [closeparen  ] := ')' ;
  sglchar [openbracket ] := '{' ;
  sglchar [closebracket] := '}' ;
  sglchar [period      ] := '.' ;
END (*Initvar1*);
  
  
PROCEDURE Initvar2 (VAR ppoption: optiontable);
BEGIN
  WITH ppoption [progsym] DO 
    BEGIN
      optionsselected  := [blanklinebefore, spaceafter];
      dindentsymbols   := [];
      gobbleterminators:= []
    END;
  WITH ppoption [funcsym] DO 
    BEGIN
      optionsselected  := [blanklinebefore, dindentonkeys, spaceafter];
      dindentsymbols   := [labelsym, constsym, typesym, varsym];
      gobbleterminators:= []
    END;
  WITH ppoption [procsym] DO 
    BEGIN
      optionsselected  := [blanklinebefore, dindentonkeys, spaceafter];
      dindentsymbols   := [labelsym, constsym, typesym, varsym];
      gobbleterminators:= []
    END;
  WITH ppoption [labelsym] DO 
    BEGIN
      optionsselected  := [blanklinebefore, spaceafter, indenttoclp];
      dindentsymbols   := [];
      gobbleterminators:= []
    END;
  WITH ppoption [constsym] DO 
    BEGIN
      optionsselected  := [blanklinebefore, dindentonkeys, spaceafter,
                           indenttoclp];
      dindentsymbols   := [labelsym];
      gobbleterminators:= []
    END;
  WITH ppoption [typesym] DO 
    BEGIN
      optionsselected  := [blanklinebefore, dindentonkeys, spaceafter,
                           indenttoclp];
      dindentsymbols   := [labelsym, constsym];
      gobbleterminators:= []
    END;
  WITH ppoption [varsym] DO 
    BEGIN
      optionsselected  := [blanklinebefore, dindentonkeys, spaceafter,
                           indenttoclp];
      dindentsymbols   := [labelsym, constsym, typesym];
      gobbleterminators:= []
    END;
  WITH ppoption [beginsym] DO 
    BEGIN
      optionsselected  := [dindentonkeys, indentbytab, crafter];
      dindentsymbols   := [labelsym, constsym, typesym, varsym];
      gobbleterminators:= []
    END;
  WITH ppoption [repeatsym] DO 
    BEGIN
      optionsselected  := [indentbytab, crafter];
      dindentsymbols   := [];
      gobbleterminators:= []
    END;
  WITH ppoption [recordsym] DO 
    BEGIN
      optionsselected  := [indentbytab, crafter];
      dindentsymbols   := [];
      gobbleterminators:= []
    END;
  WITH ppoption [casesym] DO 
    BEGIN
      optionsselected  := [spaceafter, indentbytab, gobblesymbols, crafter];
      dindentsymbols   := [];
      gobbleterminators:= [ofsym]
    END;
  WITH ppoption [casevarsym] DO 
    BEGIN
      optionsselected  := [spaceafter, indentbytab, gobblesymbols, crafter];
      dindentsymbols   := [];
      gobbleterminators:= [ofsym]
    END;
  WITH ppoption [ofsym] DO 
    BEGIN
      optionsselected  := [crsuppress, spacebefore];
      dindentsymbols   := [];
      gobbleterminators:= []
    END;
  WITH ppoption [forsym] DO 
    BEGIN
      optionsselected  := [spaceafter, indentbytab, gobblesymbols, crafter];
      dindentsymbols   := [];
      gobbleterminators:= [dosym]
    END;
  WITH ppoption [whilesym] DO 
    BEGIN
      optionsselected  := [spaceafter, indentbytab, gobblesymbols, crafter];
      dindentsymbols   := [];
      gobbleterminators:= [dosym]
    END;
  WITH ppoption [withsym] DO 
    BEGIN
      optionsselected  := [spaceafter, indentbytab, gobblesymbols, crafter];
      dindentsymbols   := [];
      gobbleterminators:= [dosym]
    END;
  WITH ppoption [dosym] DO 
    BEGIN
      optionsselected  := [crsuppress, spacebefore];
      dindentsymbols   := [];
      gobbleterminators:= []
    END;
  WITH ppoption [ifsym] DO 
    BEGIN
      optionsselected  := [spaceafter, indentbytab, gobblesymbols, crafter];
      dindentsymbols   := [];
      gobbleterminators:= [thensym]
    END;
  WITH ppoption [thensym] DO 
    BEGIN
      optionsselected  := [indentbytab, crafter];
      dindentsymbols   := [];
      gobbleterminators:= []
    END;
  WITH ppoption [elsesym] DO 
    BEGIN
      optionsselected  := [crbefore, dindentonkeys, dindent, indentbytab,
                           crafter];
      dindentsymbols   := [ifsym, elsesym];
      gobbleterminators:= []
    END;
  WITH ppoption [endsym] DO 
    BEGIN
      optionsselected  := [crbefore, dindentonkeys, dindent, crafter];
      dindentsymbols   := [ifsym, thensym, elsesym, forsym, whilesym, withsym,
                           casevarsym, colon, equals];
      gobbleterminators:= []
    END;
  WITH ppoption [untilsym] DO 
    BEGIN
      optionsselected  := [crbefore, dindentonkeys, dindent, spaceafter,
                           gobblesymbols, crafter];
      dindentsymbols   := [ifsym, thensym, elsesym, forsym, whilesym, withsym,
                           colon, equals];
      gobbleterminators:= [endsym, untilsym, elsesym, semicolon]
    END
END (*Initvar2*);
  
    
PROCEDURE Initvar3 (VAR ppoption: optiontable);
BEGIN
  WITH ppoption [becomes] DO 
    BEGIN
      optionsselected  := [spacebefore, spaceafter, gobblesymbols];
      dindentsymbols   := [];
      gobbleterminators:= [endsym, untilsym, elsesym, semicolon]
    END;
  WITH ppoption [opencomment] DO 
    BEGIN
      optionsselected  := [crsuppress];
      dindentsymbols   := [];
      gobbleterminators:= []
    END;
  WITH ppoption [closecomment] DO 
    BEGIN
      optionsselected  := [crsuppress];
      dindentsymbols   := [];
      gobbleterminators:= []
    END;
  WITH ppoption [semicolon] DO 
    BEGIN
      optionsselected  := [crsuppress, dindentonkeys, crafter];
      dindentsymbols   := [ifsym, thensym, elsesym, forsym, whilesym, withsym,
                           colon, equals];
      gobbleterminators:= []
    END;
  WITH ppoption [colon] DO 
    BEGIN
      optionsselected  := [spaceafter, indenttoclp];
      dindentsymbols   := [];
      gobbleterminators:= []
    END;
  WITH ppoption [equals] DO 
    BEGIN
      optionsselected  := [spacebefore, spaceafter, indenttoclp];
      dindentsymbols   := [];
      gobbleterminators:= []
    END;
  WITH ppoption [openparen] DO 
    BEGIN
      optionsselected  := [gobblesymbols];
      dindentsymbols   := [];
      gobbleterminators:= [closeparen]
    END;
  WITH ppoption [closeparen] DO 
    BEGIN
      optionsselected  := [];
      dindentsymbols   := [];
      gobbleterminators:= []
    END;
  WITH ppoption [openbracket] DO 
    BEGIN
      optionsselected  := [crsuppress];
      dindentsymbols   := [];
      gobbleterminators:= []
    END;
  WITH ppoption [closebracket] DO 
    BEGIN
      optionsselected  := [crsuppress];
      dindentsymbols   := [];
      gobbleterminators:= []
    END;
  WITH ppoption [period] DO 
    BEGIN
      optionsselected  := [crsuppress];
      dindentsymbols   := [];
      gobbleterminators:= []
    END;
  WITH ppoption [endoffile] DO 
    BEGIN
      optionsselected  := [];
      dindentsymbols   := [];
      gobbleterminators:= []
    END;
  WITH ppoption [othersym] DO 
    BEGIN
      optionsselected  := [];
      dindentsymbols   := [];
      gobbleterminators:= []
    END;
END (* Initvar3 *);


========================================================================================
DOCUMENT :usus Folder:VOL01:inoutready.text
========================================================================================

 
 ;  FUNCTION INPUT(PORT) AND FUNCTION OUTPUT(PORT)
 ;  INPUT AND OUTPUT FROM SPECIFIED I/O PORTS. FUNCTIONS RETURN VALUES
 ;  AS INTEGERS FOR MORE CONVENIENT TESTING.
 ;  PORT RANGE MUST BE BETWEEN 0 AND 255. (NO TESTING IS DONE)
 ;  I:=INPUT(2)     J:=OUTPUT(10)
        
        .FUNC   INPUT,1         ;ONE ARGUMENT
        POP     HL              ;RETURN ADDR
        POP     DE              ;ZERO
        POP     DE              ;ZERO
        POP     DE              ;ARGUMENT
        LD      A,E             ;LOW BYTE TO A
        LD      ($+4),A         ;MAKE INPUT CMND
        IN      A,(0)           ;INPUT TO A
        LD      E,A             ;DATA INPUT TO E
        PUSH    DE              ;BACK ON STACK
        JP      (HL)            ;EXIT
        .END
 
 ;  PROCEDURE  OUTPUT(PORT,NUMBER)
 ;  INPUT AND OUTPUT FROM SPECIFIED I/O PORTS. FUNCTIONS RETURN VALUES
 ;  AS INTEGERS FOR MORE CONVENIENT TESTING.
 ;  PORT RANGE MUST BE BETWEEN 0 AND 255. (NO TESTING IS DONE)
 ;  OUTPUT(10,65)
        
        .PROC   OUTPUT,2        ;ONE ARGUMENT
        POP     HL              ;RETURN ADDR
        POP     BC              ;ARGUMENT 2 (NUMBER)
        POP     DE              ;ARGUMENT 1 (PORT)
        LD      A,E             ;LOW BYTE TO A
        LD      ($+5),A         ;MAKE OUTPUT CMND
        LD      A,C             ;NUMBER TO A
        OUT     (0),A           ;OUTPUT TO A
        JP      (HL)            ;EXIT
        .END

;  THIS FUNCTION CALLS THE CP/M CONSOLE READY ENTRY POINT AND RETURNS
;  A BOOLEAN VALUE (TRUE OR FALSE). CODE WILL OPERATE ON EITHER 8080 OR Z80
;

        .FUNC   READY           ;TESTS CONSOLE CHAR READY AND RETURNS T ! F
        POP     DE              ;RETURN ADDR
        POP     HL
        POP     HL              ;ZEROS
        LD      L,06H           ;CP/M CONSOLE READY ENTRY POINT
        CALL    BIOS
        LD      L,A
        PUSH    HL              ;BOOLEAN RESULT TO STACK
        EX      DE,HL           ;RETURN ADDR TO HL
HERE:   JP      (HL)            ;EXIT
BIOS:   LD      A,(0002H)       ;PAGE NO IN LOCATION 02H
        LD      H,A
        JP      (HL)
        .END

*****************************
What follows is another version of the above.
*****************************
        ;
        ;
        .FUNC   STAT,3
;
        POP     HL      ;GET RETURN ADDRESS
        POP     DE      ;GET ZERO
        POP     BC      ;GET ZERO
        POP     BC      ;GET MASK
        POP     DE      ;GET EXPECTED RESULT
        LD      D,C
        POP     BC      ;GET PORT
        LD      A,C     ;PUT PORT IN A
        LD      ($1+1),A  ;STUFF PORT
$1      IN      A,(0)     ;PORT LOADED ABOVE
        AND     D       ;AND DATA & MASK
        CP      E       ;COMPARE WITH EXPECTED RESULTS
        JP      NZ,$2
        LD      DE,1    ;LOAD BOOLEAN TRUE
        PUSH    DE      ;RETURN RESULT ON STACK
        JP      (HL)
$2      LD      DE,0    ;LOAD BOOLEAN FALSE
        PUSH    DE      ;RETURN RESULT ON STACK
        JP      (HL)    ;RETURN
;
;
        .FUNC   INPUT,2
        ;
        POP     HL      ;GET RETURN ADDRESS
        POP     DE      ;GET ZERO
        POP     BC      ;GET ZERO
        POP     DE      ;GET MASK
        POP     BC      ;GET INPUT PORT
        LD      A,C     ;PUT PORT IN A
        LD      ($1+1),A  ;STUFF PORT
$1      IN      A,(0)     ;PORT LOADED ABOVE
        AND     E       ;MASK DATA
        LD      E,A
        PUSH    DE      ;RETURN RESULT ON STACK
        JP      (HL)    ;RETURN
        ;
        ;
        .PROC   OUTPUT,2
        ;
        POP     HL      ;GET RETURN ADDRESS
        POP     DE      ;GET DATA
        POP     BC      ;GET OUTPUT PORT
        LD      A,C     ;PUT PORT IN A
        LD      ($1+1),A  ;STUFF PORT
        LD      A,E     ;PUT DATA IN A
$1      OUT     (0),A     ;PORT LOADED ABOVE
        JP      (HL)    ;RETURN
        ;
        ;
        .END
        


========================================================================================
DOCUMENT :usus Folder:VOL01:introductn.text
========================================================================================

Introduction.

     The UCSD Pascal language system is one of the most sophisticated
microcomputer software systems available today.  Because of the ease with
which one can write and maintain high quality programs of most types, from
systems software to business applications to games, the UCSD system promises
to be the vanguard of an enormous interest in Pascal in the coming decade. 
Already a number of other Pascal implementations have appeared for
microprocessors, though none so complete.  However, by the time you have 
received this disk, several full-standard native-code compilers will have been 
released for microprocessors.

     UCSD Pascal compiles its programs to P-code, designed for a hypothetical
16-bit stack machine that must be emulated in software on most
microprocessors.  Even though this P-code interpretation system runs three
times slower than assembly language, it is much faster than any other
interpretive language available for micros, and has the additional advantage
that P-code occupies approximately one third the space of native machine
language.  (Now, however, at least two manufacturers have produced computers
that execute P-code directly, as their machine language, offering extremely
rapid execution.)  In addition, once the P-code interpreter has been
installed, programs written in UCSD Pascal may be run on any microprocessor
without modification.  Even the disk formats are the same, except for the
minifloppies used for the Apple, North Star, or TRS-80.  So disk software in 
source or object form may be freely shared among users of such diverse
machines as a PDP-11 or an 8080.  

The Pascal Users Group.

     It would seem natural for a large users group to arise to share software.
To date, however, only the original Pascal Users Group ("PUG") serves this
function.  The PUG sprang into existence in 1976 to serve as a forum for the 
then few hundred Pascal programmers.  Primarily, they support the standard
language based on the Jensen and Wirth Pascal User Manual and Report, discuss
the horrors certain programmers would like to add to the language to make it
fit their needs, and report on available Pascal implementations and programmer
opportunities.  Only secondarily does the PUG disseminate software (based on
Jensen and Wirth Pascal), although since 1978 the PUG has published several
superb "software tools", such as automatic formatters to print programs
clearly and a large and extremely sophisticated text formatter.  They can be
reached c/o Rick Shaw, Digital Equipment Corporation, 5775 Peachtree Dunwoody 
Road, Atlanta, Georgia 30342.  A subscription is now $6 per academic year.  I
suggest you start your collection from the 1977-1978 year.  (Back issues are
available at $10 per academic year.)

     The PUG newsletter presents several difficulties to the user of UCSD
Pascal who wishes to share software.  First, relatively little software is
published, albeit that which does appear is of high quality.  Second, the
programs must be adapted for UCSD Pascal.  It turns out that this task is
trivial, and concerns primarily disk i/o.  Third, the programs are a little
slower because the nonstandard UCSD functions like strings aren't used;
strings run more quickly on a UCSD system than the character-by-character
approach needed by standard Pascal.  The overwhelming problem, however, is
that the Pascal Users Group publication, the "Pascal News," appears only on
PAPER (yecch!).  And even if they did use machine-readable media, most members
run large computers that talk to each other via tape.  So you have to type the
software into the machine on your own.  I can assure you, having done it, that
this is no mean task.

A UCSD Pascal Users Group on machine-readable media.

     In the interests of promoting the more widespread use of Pascal and
building up a sizable program base, Datamed Research has announced the
formation of a UCSD Pascal users' group.  It takes a form similar to the CP/M
Users Group: all offerings will be on 8-inch, single density, IBM-compatible
soft-sectored floppies, offered virtually at cost ($10 per disk).  Software
will be donated by interested users. Software donors will receive a free disk
volume of their choice in acknowledgement of their donation.  For software to
be accepted for distribution it MUST (a) work (no known bugs) and (b) come
with at least adequate documentation on the disk. Further, with rare
exceptions it must be supplied in source code to allow other users to adapt it
to their systems.  

     There is one exception to the requirement for source code.  If you were 
developing a sophisticated program that you hoped to sell, but needed
assistance in discovering remaining bugs and system incompatibilities, you
might donate the interim P-code to the users group.  Then, users who first
discovered a particular problem or gave other feedback you considered
valuable would receive an incentive such as a discount on the completed
program.  In the meantime, users would benefit from a program that worked most 
of the time.

     Potential sources of Pascal software abound; by no means must you donate
only original work.  There is a mountain of public-domain Basic software that
is easily adapted to Pascal.  In the process, you can usually spruce up the
program a good deal, because Pascal is so much easier to work with than
Basic.  It will be important, in addition, for the users to begin a library of
Pascal procedures and functions to handle the more common programming
problems.  For example, we need a set of mathematical functions for complex
variables, statistical functions, and basic business software support
(routines to translate integers into dollars and cents and vice versa) to
realize the full power of the langwage.  I am presently writing a program
which will automate the production of CRT screen masks and (more exciting)
handle data input from the CRT directly.  This program will accept in
simplified form the desired CRT mask directly from the system editor, plus
needed data about the variables to be typed in by the user.  The program will
generate Pascal source code for incorporation into your applications programs
and handle automatically things like goof proofing (preventing the program
from crashing if the wrong`types of data are entered), variable declarations,
saving the CRT mask data within the procedure or on the disk as you wished,
etc.

     By the way, since it is relatively trivial to transfer text from the UCSD
disk format (similar to the PDP-11 RT11 format) to CP/M, all volumes will also
be available on CP/M disks for those using CP/M-compatible Pascal.  However,
you will be on your own to get the programs to fit into your memory (remember
that native code versions are three times larger) and adapted to your system.
We will be happy, though, to accept Pascal software on CP/M disks if it can be
readily adapted to the UCSD system.

     Software already in the hopper as of February 15, 1980, includes:

     1.  The powerful pretty printer and formatting programs, to beautify
Pascal source code, from the Pascal News Vol 13.

     2.  A Pascal driver for a D.C. Hayes modem, so your computers can talk 
with one another.  This should not be hard to modify for other modems.  Two 
versions of this program have been prepared by different authors.

     3.  A file printer offering several options in page headings and page
numbering, as well as single to quad line spacing.  Good for programs and
manuscripts.

     4.  An assortment of games, ranging from CHASE to SKYLANES.  (As of yet,
no STARTREK.)

     5.  Two programs in Pascal to convert UCSD-format disks to the CP/M 
format, and vice versa.

     6.  A nifty restructuring of the 8080/Z-80 interpreter and BIOS to
support disks formatted with 512-byte blocks (single or double density), for
a 23% greater disk capacity and a breathtaking increasw in disk access speed,
as well as a slight shrinkage of the interpreter.  The modified BIOS accepts
128- byte and 512-byte sectored disks transparently, although you have to
reboot if you change disk density.  In addition, the BIOS contains complete 
cursor-handling routines for a dumb terminal such as an ADM-3A.

     Note that this offering will be on two disks:  one of UCSD format 
(interpreter sources, including <only> changes made to the original) and the 
other CP/M compatible, so your CP/M-based assemblers and editors can work on 
the code.  (However, the CP/M disk will be translated to UCSD format for those 
without CP/M.  Not recommended, however.)

     7.  If you've tried to get up UCSD Pascal in a CP/M environment, you've
noticed that the UCSD system is considerably more demanding of your BIOS than
was CP/M.  We have notes on providing the extra functions required, plus many
of the aspects of the 8080/Z-80 implementation not documented.

     
Possible future directions.

     Since there is little question that Pascal will grow by leaps and bounds, 
the major question is how to keep up with the machine-readable formats
required by the various micros and minis utilizing Pascal.  For now, we are 
limited to standard 8-inch floppies, and if there were enough demand I would 
consider distributing the volumes in hard-copy form at a modest increase in 
price for those who could not utilize full-size disks.  But perhaps there are
others with the hardware capabilities of transferring programs from one
format to another (e.g., to North Star or Apple disks) or who are willing to
copy the smaller disks for distribution.  If we can provide these services,
then other formats could be distributed as well.

     Although programs would be the main emphasis, I hope to have other
features on the disks as well as software.  Information on programming tips
would certainly be a useful addition.  For example, there are a number of
"hidden gotchas" in the UCSD system, as well as features that are inadequately
documented.  Also, I don't think it's clear just which programming
techniques are the most portable from system to system.  For example,
including a PAGE (OUTPUT) within a program in my system clears my screen or
causes a formfeed on the printer.  It does nothing in systems that do not
recognize an ASCII formfeed character (12 decimal).  One could clear the
screen on ANY UCSD system by jumping to the bottom of the screen, doing 24
WRITELN's, then jumping to the upper left of the screen.  Is there an easier
way that will always work?

     Finally, we should share algorithms and reviews of commercial Pascal
software.

     
For further information.

     You can find out more about the present status of the users group by
sending a self-addressed, stamped envelope to the following address:

     UCSD Pascal Users Group
     DATAMED RESEARCH
     1433 Roscomare Road
     Los Angeles, CA 90024

     Alternatively, 8-inch floppies can be ordered at $10 per volume.  Make
sure you specify UCSD or CP/M format.

========================================================================================
DOCUMENT :usus Folder:VOL01:l.text
========================================================================================

PROGRAM LISTFILE;

CONST linesperpage = 60;
      pagewidth = 80;      (* columns per line *)
      quarterwidth = 20;

VAR  printhead, printfname: boolean;
     i, pageno, startpage, endpage, LFname, Lmsg: integer;
     ioerror: 0..12;
     lineno: 0..70;
     spacing: 1..4;
     spaceL, spaceR: -15..pagewidth;
     formfeed: char; 
(* if your system needs nulls or other char to move your printer to the top of
   the next page, make formfeed an array and fill it with whatever you need. *)
     s: string [135];
     filename: string [25];
     msg: string;
     f, list: text;     
     
PROCEDURE INITIALIZE;
VAR  ch: char;
     successful: boolean;

BEGIN
  Formfeed := CHR (12); (* this is what my printer wants to start new page *)
  Successful := false;
  REPEAT
    Write ('Please type name of file to be listed -->  ');
    READLN (filename);
    LFname := LENGTH (filename);
    IF LFname = 0 THEN EXIT (Program);
    (*$I-*)
    RESET (f, filename);
    (*$I+*)
    ioerror := IORESULT;
    IF ioerror = 0 
      THEN successful := true
      ELSE BEGIN
        Writeln ('Oops, there''s a problem.  IORESULT = ', ioerror, '.');
        Writeln ('Try again.  To quit just type <return>');
        Writeln
      END
  UNTIL Successful;
  REWRITE (list, 'PRINTER:');
  Write ('Single-space each line?  ');
  Read (ch);  Writeln;
  IF (ch IN ['Y', 'y'])
    THEN Spacing := 1
    ELSE BEGIN
      REPEAT
        Write ('How many spaces per line (1 - 4)?  ');
        Read (ch); 
        Writeln
      UNTIL (ch IN ['1'..'4']);
      Spacing := ORD (ch) - ORD ('0')
    END;
  WRITE ('Do you wish a page heading?  ');
  READ (ch); WRITELN;
  Msg := '';    (* empty string *);
  IF (ch in ['Y', 'y'])
    THEN BEGIN
      printhead := TRUE;
      WRITELN ('If you wish a date or other heading or title,',
              ' type it here:  ');
      READLN (msg);
      Lmsg := LENGTH (msg);
      WRITE ('Do you want to include the filename in the heading?  ');
      READ (ch); WRITELN;
      IF (ch IN ['Y', 'y'])
        THEN  (* yes, print it and expand heading as well. *)
          BEGIN
            Printfname := TRUE;
(* Don't forget to change SpaceL and SpaceR here if you're not going to expand
 your page heading to double width. *)
            SpaceL := (pagewidth DIV 4) - (LFname + (Lmsg DIV 2));
            IF spaceL < 1 THEN spaceL := 1;
            SpaceR := (pagewidth DIV 2) - (LFname + SpaceL + Lmsg + 7)
          END
        ELSE  (* no, skip filename and don't expand heading. *)
          BEGIN
            Printfname := FALSE;
            SpaceL := 0;
            SpaceR := pagewidth - (Lmsg + 7)
          END;
      IF spaceR < 1 THEN spaceR := 1
    END
    ELSE printhead := FALSE;
  Pageno := 1;
  WRITE ('Do you want to print the whole file?  ');
  READ (ch); WRITELN;
  IF (ch in ['Y', 'y']) 
    THEN
      BEGIN
        Startpage := 0;
        Endpage := MAXINT
      END
    ELSE
      BEGIN
        WRITE ('Start with page no. -->  ');
        READ (startpage);
        WRITE ('End after page no. -->  ');
        READ (endpage); WRIToLN
      END
END (*initialize*);

PROCEDURE HEADING;
(* This procedure prints the following:
        1.  If printfilename flag is on, then the filename is flush left, the
        message centered, and the page number flush right, all double width.
        2.  Otherwise any message is flush left and the pageno flush right,
        standard width char.  In addition, the page 1 heading is skipped.*)

BEGIN
  IF printfname
    THEN WRITE (list, CHR (14) (*char to expand title*), filename, ' ':spaceL);
  i := SpaceR;  (* move 'page' to right if pageno less than 3 digits *)
  IF pageno < 10 THEN i :=3i + 1;
  IF pageno < 100 THEN i := i + 1;
  IF printfname OR (pageno > 1)
    THEN WRITE (list, msg, ' ':i, 'Page ', pageno);
  Writeln (list);
  Writeln (list);
  Writeln (list);
  Lineno := 4
END;
  
PROCEDURE PRINTPAGE;

BEGIN
  WHILE (NOT EOF(f)) AND (lineno <= linesperpage)
    DO BEGIN
      READLN (f,s);
      WRITE (list,s);
      FOR i := 1 TO Spacing DO
        BEGIN
          Writeln (list);
          Lineno := SUCC (lineno)
        END
    END;
  WRITE (list, formfeed);
  Pageno := SUCC (pageno)
END;

PROCEDURE DUMMYPAGE;

BEGIN
  IF printhead THEN lineno := 4 ELSE lineno := 1;
  WHILE (NOT EOF (f)) AND (lineno <= linesperpage)
    DO BEGIN
      READLN (f,s);    
      FOR i := 1 TO Spacing DO Lineno := SUCC (lineno)
    END;
  Pageno := SUCC (pageno)
END;


{Main program]}

BEGIN

  Initialize;
  WHILE (startpage > pageno) AND (NOT EOF(f)) DO Dummypage;
  WHILE (endpage >= pageno) AND (NOT EOF(f)) DO
    BEGIN
      Lineno := 1;
      IF printhead THEN Heading;
      Printpage
    END
END.

========================================================================================
DOCUMENT :usus Folder:VOL01:modem.text
========================================================================================

                        {VERSION 14 MAR 1979}
PROGRAM MODEM;

CONST   WORD    = 31;           {8 BITS, NO PARITY, 2 STOP BITS}

        DATA    = 128;          {MODEM DATA PORT}
        STAT    = 129;          {MODEM STATUS PORT}
        MODE    = 130;          {MODEM CONTROL PORT}
        
        FOREVER = FALSE;
        SCREENWIDTH=64;         {DISPLAY SCREEN WIDTH IN CHAR}
        CLRSCR  = 26;           {CLEAR SCREEN CODE (ADM-3)}
        
        ANMESS  = 'PASCAL 80/103 MODEM SPEAKING';
        DELAYCON= 75;          {TIMING DELAY CONST
                                 Z-80 = 150, 8080 = 75}


TYPE    INSET   = SET OF 0..7;
        ATYPE   = RECORD
                    CASE BOOLEAN OF
                      TRUE: (CHAREP:CHAR);
                      FALSE:(SETREP:INSET)
                    END;
      PACKEDNUM = RECORD
                    CASE BOOLEAN OF
                      TRUE: (INT:INTEGER);
                      FALSE:(CH:PACKED ARRAY[0..1] OF CHAR)
                    END;
     PACKEDBYTE = RECORD
                    CASE BOOLEAN OF
                      TRUE: (CH:CHAR);
                      FALSE:(PNUM:PACKED ARRAY[0..1] OF 0..15)
                    END;


VAR   MODEBYTE: ATYPE;
      INBYTE:   ATYPE;
      IBYTE:    ATYPE;
      INB:      ATYPE;
      DBYTE:    ATYPE;
      CBYTE:    ATYPE;
      CSET:     ATYPE;
      TXE,TXOFF:INSET;
      RRF,TRE:  INSET;
      BRS:      INSET;
      NOTBRS:   INSET;
      ORGANS:   INSET;
      OFFMASK:  INSET;
      ONMASK:   INSET;
      MS,NOTMS: INSET;
      CARDET:   INSET;
      RNGDET:   INSET;
      MASK:     INSET;
      BK:       INSET;
      CRC:      PACKEDNUM;
      C:        PACKED ARRAY[0..1] OF CHAR;
      SHORTBUF: PACKED ARRAY[0..4] OF CHAR;
      IOBUF:    PACKED ARRAY[0..519] OF CHAR;
      FILEBUF:  PACKED ARRAY[0..511] OF CHAR;
      SOH:      CHAR;
      STX:      CHAR;
      EOT:      CHAR;
      ETX:      CHAR;
      ACK:      CHAR;
      NAK:      CHAR;
      MWORD:    CHAR;
      CONTRLB:  CHAR;
      CONTRLC:  CHAR;
      CONTRLD:  CHAR;
      CONTRLE:  CHAR;
      CONTRLH:  CHAR;
      BELL:     CHAR;
      CR,LF:    CHAR;
      NULL:     CHAR;
      EOTFLG:   BOOLEAN;
      EFLAG:    BOOLEAN;
      HEX:      BOOLEAN;
      BLK:      BOOLEAN;
      CPM:      BOOLEAN;
      HISPEED:  BOOLEAN;
      CALLMADE: BOOLEAN;
      AUTOLF:   BOOLEAN;
      FIRSTBLK: BOOLEAN;
      EXITFLG:  BOOLEAN;
      RECFLG:   BOOLEAN;
      CONECHO:  BOOLEAN;
      MESSAGE:  STRING[30];
      PHONENUM: STRING[20];
      S:        STRING[1];
      FUNCT:    STRING[64];
      NAME:     STRING;
      BLKSIZE:  INTEGER;
      BLKINDX:  INTEGER;
      BLKNUM:   INTEGER;
      DISPINDX: INTEGER;
      TIMER:    INTEGER;
      NAKCNT:   INTEGER;
      I:        INTEGER;
      RBINDX:   0..512;
      UBLKNUM:  INTEGER;
      TEXTFILE: TEXT;
      UTEXTFILE:FILE;
      
      
      

FUNCTION READY:BOOLEAN; EXTERNAL;

FUNCTION INPUT(PORT:INTEGER):CHAR; EXTERNAL;

PROCEDURE OUTPUT(PORT:INTEGER;DATA:CHAR); EXTERNAL;

FUNCTION CRC16(CRC0,CRC1,NEXTBYTE:CHAR):INTEGER; EXTERNAL;


PROCEDURE INITIALIZE;
BEGIN
  SOH:=CHR(1);                  {ASCII CONTROL CODES}
  STX:=CHR(2);
  ETX:=CHR(3);
  EOT:=CHR(4);
  ACK:=CHR(6);
  NAK:=CHR(21);
  TXE:=[1];                     {02H    TRANSMIT ENABLE}
  TXOFF:=[0,2,3,4,5,6,7];       {0FDH   TRANSMIT DISABLE}
  RRF:=[0];                     {01H    RECEIVE REGISTER FILLED}
  BRS:=[0];                     {01H    BIT RATE SELECT}
  TRE:=[1];                     {02H    TRANSMIT REGISTER EMPTY}
  MS:=[2];                      {04H    MODE SELECT (1=ORIG 0=ANSW)}
  CARDET:=[6];                  {40H    CARRIER DETECT}
  RNGDET:=[7];                  {80H    RING DETECT}
  OFFMASK:=[7];                 {80H}
  ONMASK:=[0,1,2,3,4,5,6];      {7FH}
  NOTBRS:=[1,2,3,4,5,6,7];      {0FEH   NOT BRS}
  NOTMS:=[0,1,3,4,5,6,7];       {0FBH   NOT MS)
  ORGANS:=[2];                  {04H    ORIGINATE/ANSWER BIT}
  BK:=[3];                      {08H    BREAK BIT)
  NULL:=CHR(0);                 {00H}
  CONTRLB:=CHR(2);              {02H}
  CONTRLC:=CHR(3);              {03H}
  CONTRLD:=CHR(4);              {04H}
  CONTRLE:=CHR(5);              {05H}
  CONTRLH:=CHR(8);              {08H}
  BELL:=CHR(7);                 {07H}
  CR:=CHR(13);                  {13H}
  LF:=CHR(10);                  {10H}
  MWORD:=CHR(WORD);
  EOTFLG:=FALSE;
  MODEBYTE.SETREP:=BRS;         {01H    INITIALIZE TO 300 BAUD}
  HISPEED:=TRUE;
  CPM:=FALSE;
  BLK:=FALSE;
  AUTOLF:=FALSE;
  EXITFLG:=FALSE;
  CONECHO:=TRUE;
  S:=' ';
  OUTPUT(MODE,MODEBYTE.CHAREP);
  OUTPUT(STAT,NULL)
END;


PROCEDURE BINARY(NUMBER:INSET);
VAR I:INTEGER;
BEGIN
  FOR I:=7 DOWNTO 0 DO IF I IN NUMBER THEN WRITE('1') ELSE WRITE('0')
END;


PROCEDURE HEXOUT (C:CHAR);
TYPE        HEX = PACKED ARRAY[0..1] OF 0..15;
      ALIASTYPE = RECORD
                   CASE BOOLEAN OF
                     TRUE: (CHAREP:CHAR);
                     FALSE: (HEXREP:HEX)
                   END;
VAR  ALIAS:ALIASTYPE;
         I:0..1;
BEGIN
  ALIAS.CHAREP:=C;
  FOR I:=1 DOWNTO 0 DO
  IF ALIAS.HEXREP[I] < 10 THEN WRITE(ALIAS.HEXREP[I]) 
    ELSE WRITE(CHR(ALIAS.HEXREP[I]+55));
END;


PROCEDURE DELAY(N:INTEGER);
VAR I,J:INTEGER;
BEGIN
  FOR J:=1 TO N DO
    FOR I:=1 TO DELAYCON DO;
END;

PROCEDURE BREAK;        {SENDS 120 MS OF SPACE}
BEGIN
 WRITELN;
 WRITELN(' *** Break char received from keyboard ***');
 WITH MODEBYTE DO
  BEGIN
   SETREP:=SETREP+BK;           {08H TURNS ON BREAK BIT}
   OUTPUT(MODE,CHAREP);
   DELAY(3);                    {120 MS (OR SO) OF DELAY}
   SETREP:=SETREP-BK;           {TAKE IT OUT}
   OUTPUT(MODE,CHAREP);         {RESET}
  END; {WITH}
 END; {BREAK}

PROCEDURE OFFHOOK;
BEGIN
  MODEBYTE.SETREP:=MODEBYTE.SETREP+OFFMASK;
  OUTPUT(MODE,MODEBYTE.CHAREP)
END;


PROCEDURE ONHOOK;
BEGIN
  MODEBYTE.SETREP:=MODEBYTE.SETREP*ONMASK;
  OUTPUT(MODE,MODEBYTE.CHAREP)
END;


PROCEDURE TRANON;
BEGIN
  MODEBYTE.SETREP:=MODEBYTE.SETREP+TXE;
  OUTPUT(MODE,MODEBYTE.CHAREP)
END;


PROCEDURE TRANOFF;
BEGIN
  MODEBYTE.SETREP:=MODEBYTE.SETREP*TXOFF;
  OUTPUT(MODE,MODEBYTE.CHAREP)
END;


PROCEDURE ANCALL;
BEGIN
  IF HISPEED THEN MODEBYTE.SETREP:=MODEBYTE.SETREP+BRS ELSE
      MODEBYTE.SETREP:=MODEBYTE.SETREP*NOTBRS;
  MODEBYTE.SETREP:=MODEBYTE.SETREP*NOTMS;
  OUTPUT(MODE,MODEBYTE.CHAREP);
  OUTPUT(STAT,MWORD)
END;


PROCEDURE ORCALL;
BEGIN
  IF HISPEED THEN MODEBYTE.SETREP:=MODEBYTE.SETREP+BRS ELSE
      MODEBYTE.SETREP:=MODEBYTE.SETREP*NOTBRS;
  MODEBYTE.SETREP:=MODEBYTE.SETREP+MS;
  OUTPUT(MODE,MODEBYTE.CHAREP);
  OUTPUT(STAT,MWORD)
END;


PROCEDURE HANGUP;
BEGIN
  EOTFLG:=TRUE;
  ONHOOK;
  TRANOFF
END;


FUNCTION CHECKC:BOOLEAN;         {RETURNS TRUE IF ^C ENTERED ON KEYBOARD}
BEGIN
  IF READY THEN 
  BEGIN
    UNITREAD(2,C[0],1);
    IF C[0]=CONTRLC THEN CHECKC:=TRUE ELSE CHECKC:=FALSE
  END
END;


FUNCTION RECBYTE:CHAR;
BEGIN
  TIMER:=7500;
  REPEAT
    TIMER:=TIMER-1;
    IF(CHECKC OR (TIMER=0)) THEN
    BEGIN
      EXITFLG:=TRUE;
      EXIT(RECBYTE)
    END;
    IBYTE.CHAREP:=INPUT(STAT)
  UNTIL IBYTE.SETREP*RRF<>[];
  DBYTE.CHAREP:=INPUT(DATA);
  RECBYTE:=DBYTE.CHAREP
END;


PROCEDURE TRANSMIT(DATABYTE:CHAR);
BEGIN
  REPEAT
    CBYTE.CHAREP:=INPUT(STAT)
  UNTIL CBYTE.SETREP*TRE<>[];
  OUTPUT(DATA,DATABYTE)
END;


PROCEDURE SBLKSEND(C:CHAR);    {SEND SHORT BLOCK}
VAR  I:0..4;
BEGIN
  WRITELN;
  SHORTBUF[0]:=SOH;
  SHORTBUF[1]:=NULL;
  SHORTBUF[2]:=C;
  SHORTBUF[3]:=NULL;
  SHORTBUF[4]:=NULL;
  CRC.CH[0]:=SHORTBUF[1];
  CRC.CH[1]:=SHORTBUF[2];
  FOR I:=3 TO 4 DO CRC.INT:=CRC16(CRC.CH[0],CRC.CH[1],SHORTBUF[I]);
  SHORTBUF[3]:=CRC.CH[0];
  SHORTBUF[4]:=CRC.CH[1];
  FOR I:=0 TO 4 DO
  BEGIN
    HEXOUT(SHORTBUF[I]);
    TRANSMIT(SHORTBUF[I])
  END;
  IF C=ACK THEN WRITE(' ACK') ELSE
  IF C=NAK THEN WRITE(' NAK',BELL) ELSE
  IF C=EOT THEN WRITE(' EOT')
END;


FUNCTION SBLKREC:CHAR;          {RECEIVE SHORT BLOCK}
VAR  I:0..4;
BEGIN
  WRITELN;
  REPEAT
    SHORTBUF[0]:=RECBYTE;
    IF EXITFLG THEN EXIT(SBLKREC);
  UNTIL SHORTBUF[0]=SOH;
  FOR I:=1 TO 4 DO
  BEGIN
    SHORTBUF[I]:=RECBYTE;
    HEXOUT(SHORTBUF[I])
  END;
  CRC.CH[0]:=SHORTBUF[1];
  CRC.CH[1]:=SHORTBUF[2];
  FOR I:=3 TO 4 DO CRC.INT:=CRC16(CRC.CH[0],CRC.CH[1],SHORTBUF[I]);
  IF CRC.INT<>0 THEN
  BEGIN
    WRITELN('SHORT BLOCK CRC ERROR - NAK',BELL);
    SBLKREC:=NAK
  END ELSE
  BEGIN
    SBLKREC:=SHORTBUF[2];
    IF SHORTBUF[2]=ACK THEN WRITE(' ACK') ELSE WRITE(' NAK',BELL)
  END
END;


PROCEDURE DISPHEX(DISPCHAR:CHAR);
BEGIN
  IF DISPINDX<=SCREENWIDTH THEN HEXOUT(DISPCHAR) ELSE
  BEGIN
    DISPINDX:=1;
    WRITELN;
    HEXOUT(DISPCHAR)
  END;
  DISPINDX:=DISPINDX+2
END;


PROCEDURE BLKTRANS(DATABYTE:CHAR);
VAR    I:INTEGER;
       C:CHAR;
     LEN:PACKEDNUM;
  SEQTYP:PACKEDBYTE;
BEGIN
  IF BLKINDX>BLKSIZE THEN
  BEGIN
    REPEAT
      WRITELN;WRITELN;
      DISPINDX:=1;
      BLKINDX:=1;
      WRITELN('BLOCK ',BLKNUM,'   BYTES ',(BLKNUM)*BLKSIZE);
      IOBUF[0]:=SOH;
      SEQTYP.PNUM[1]:=BLKNUM MOD 16;
      SEQTYP.PNUM[0]:=1;
      IOBUF[1]:=SEQTYP.CH;
      LEN.INT:=BLKSIZE;
      IOBUF[2]:=LEN.CH[1];
      IOBUF[3]:=LEN.CH[0];
      IOBUF[4]:=STX;
      IOBUF[BLKSIZE+5]:=ETX;
      IOBUF[BLKSIZE+6]:=NULL;
      IOBUF[BLKSIZE+7]:=NULL;
      CRC.CH[0]:=IOBUF[BLKSIZE+6];
      CRC.CH[1]:=IOBUF[BLKSIZE+7];
      FOR I:=1 TO BLKSIZE+7 DO CRC.INT:=CRC16(CRC.CH[0],CRC.CH[1],IOBUF[I]);
      IOBUF[BLKSIZE+6]:=CRC.CH[0];
      IOBUF[BLKSIZE+7]:=CRC.CH[1];
      FOR I:=0 TO BLKSIZE+7 DO
      BEGIN
        DISPHEX(IOBUF[I]);
        TRANSMIT(IOBUF[I])
      END
    UNTIL ((SBLKREC=ACK) OR EXITFLG);
    IF EXITFLG THEN EXIT(BLKTRANS);
    BLKNUM:=BLKNUM+1
  END;
  IOBUF[BLKINDX+4]:=DATABYTE;
  BLKINDX:=BLKINDX+1
END;


PROCEDURE ANSBACK;
VAR I:INTEGER;
BEGIN
  MESSAGE:=ANMESS;
  FOR I:=1 TO LENGTH(MESSAGE) DO TRANSMIT(MESSAGE[I]);
  TRANSMIT(CR);TRANSMIT(LF)
END;



PROCEDURE ANSWCALL;
VAR   I:INTEGER;
   CARR:BOOLEAN;
BEGIN
  ANCALL;
  OFFHOOK;
  TRANON;
  CALLMADE:=FALSE;
  WRITELN;
  WRITELN('PHONE ANSWERED');
  OUTPUT(MODE,MODEBYTE.CHAREP);
  I:=0;
  CARR:=FALSE;
  REPEAT
    I:=I+1;
    DELAY(10);
    INBYTE.CHAREP:=INPUT(STAT);
    INB.CHAREP:=INPUT(255);
    IF((INBYTE.SETREP*CARDET<>[]) OR (INB.SETREP*CARDET<>[])) THEN 
      BEGIN
        CARR:=TRUE;
        CALLMADE:=TRUE
      END;
  UNTIL ((I=20) OR CARR);
  WRITELN;WRITELN;
  IF CARR THEN
  BEGIN
   ANSBACK;
   WRITELN('CALL COMPLETE',BELL)
   END ELSE
  BEGIN
    WRITELN;
    WRITELN(BELL,'NO CARRIER DETECTED IN 10 SECONDS ');
    HANGUP;
    WRITELn;
    WRITE('WAITING FOR RING OR CONTROL B ')
  END
END;


PROCEDURE PULSE(N:INTEGER);
VAR I,J:INTEGER;
BEGIN
  IF N=0 THEN I:=10 ELSE I:=N;
  FOR I:=I DOWNTO 1 DO 
  BEGIN
    ONHOOK;
    DELAY(1);
    OFFHOOK;
    DELAY(1)
  END;
  DELAY(10)
END;


PROCEDURE MAKECALL;
VAR  I,J:INTEGER;
    ANSW:BOOLEAN;
BEGIN
  ONHOOK;
  TRANOFF;
  ORCALL;
  WRITELN;
  WRITE('INPUT TELEPHONE NUMBER ');
  READLN(PHONENUM);
  WRITELN;
  WRITE('DIALING...');
  OFFHOOK;
  DELAY(40);                    {WAIT FOR DIAL TONE}
  FOR I:=1 TO LENGTH(PHONENUM) DO
    BEGIN
      WRITE(PHONENUM[I]);
      J:=ORD(PHONENUM[I])-48;
      IF (PHONENUM[I] IN ['0'..'9']) THEN PULSE(J)
    END;
  I:=0;
  ANSW:=FALSE;
  CALLMADE:=FALSE;
  REPEAT
    I:=I+1;
    DELAY(10);
    INBYTE.CHAREP:=INPUT(STAT);
    INB.CHAREP:=INPUT(255);
    IF((INBYTE.SETREP*CARDET<>[]) OR (INB.SETREP*CARDET<>[])) THEN ANSW:=TRUE
  UNTIL ((I=50) OR ANSW);
  IF ANSW THEN
  BEGIN
    CALLMADE:=TRUE;
    WRITELN;
    WRITELN('CALL COMPLETE',BELL)
  END ELSE
    BEGIN
      WRITELN;
      WRITELN('SORRY, NO ANSWER');
      WRITELN;
      WRITE('WAITING FOR RING OR CONTROL B ')
    END
END;


PROCEDURE CONNECT;
BEGIN
  MODEBYTE.SETREP:=MODEBYTE.SETREP+TXE;
  OUTPUT(MODE,MODEBYTE.CHAREP);
  IF MODEBYTE.SETREP+ORGANS=[] THEN ANSBACK
END;


PROCEDURE QUIT;
BEGIN
  HANGUP;
  EXIT(PROGRAM)
END;
         

PROCEDURE GETCHAR;              {GET CHARACTER FROM MODEM}
BEGIN
  DBYTE.CHAREP:=INPUT(DATA);
  DBYTE.SETREP:=DBYTE.SETREP*ONMASK;
  IF DBYTE.CHAREP<>LF THEN WRITE(DBYTE.CHAREP);
  IF DBYTE.CHAREP=CONTRLD THEN EOTFLG:=TRUE
END;


FUNCTION CONVERT(VAR NAME:STRING):INTEGER;
VAR I,N:INTEGER;
      S:STRING;
BEGIN
  S:=NAME;
  N:=0;
  FOR I:=1 TO LENGTH(NAME) DO
  BEGIN
    IF NOT (NAME[I] IN ['0'..'9']) THEN
    BEGIN
      CONVERT:=-1;
      WRITELN('ERROR, NON NUMERIC CHARACTER IN NUMBER',BELL);
      EXIT(CONVERT)
    END;
    N:=N*10+ORD(NAME[I])-48;
  END;
  CONVERT:=N
END;


FUNCTION NEXTSTR(I:INTEGER):BOOLEAN;
VAR  B,E,J:INTEGER;
BEGIN
  E:=LENGTH(FUNCT);
  WHILE FUNCT[I]<>' ' DO I:=I+1;
  WHILE ((FUNCT[I]=' ') AND (I<E)) DO I:=I+1;
  IF I=E THEN
  BEGIN
    NEXTSTR:=FALSE;
    EXIT(NEXTSTR)
  END;
  B:=I;
  WHILE FUNCT[I]<>' ' DO I:=I+1;
  NAME:=COPY(FUNCT,B,I-B);
  NEXTSTR:=TRUE
END;


PROCEDURE BLOCK;
BEGIN
  I:=POS('BLOC',FUNCT);
  BLKSIZE:=128;
  BLK:=TRUE;
  BLKINDX:=1;
  BLKNUM:=0;
  RBINDX:=512;
  UBLKNUM:=0;
  IF NEXTSTR(I) THEN
  BEGIN
    BLKSIZE:=CONVERT(NAME);
    IF BLKSIZE=0 THEN BLK:=FALSE;
    IF BLKSIZE<0 THEN
    BEGIN
      BLKSIZE:=128;
      EXIT(BLOCK)
    END ELSE
    IF BLKSIZE>512 THEN
    BEGIN
      BLKSIZE:=512;
      WRITELN('ERROR, MAXIMUM BLOCK SIZE ALLOWED IS 512 BYTES',BELL)
    END
  END ELSE WRITELN('MISSING BLOCK SIZE VALUE')
END;


PROCEDURE SPEED;
VAR  NUM:INTEGER;
       I:INTEGER;
BEGIN
  I:=POS('SPEED',FUNCT);
  HISPEED:=TRUE;
  IF NEXTSTR(I) THEN
  BEGIN
    IF NAME='300' THEN HISPEED:=TRUE ELSE
    IF NAME='110' THEN HISPEED:=FALSE ELSE
      WRITELN('ERROR, SPEED MUST BE 110 OR 300 BAUD')
  END ELSE WRITELN('MISSING SPEED VALUE, DEFAULT TO 300 BAUD');
  IF HISPEED THEN MODEBYTE.SETREP:=MODEBYTE.SETREP+BRS ELSE
      MODEBYTE.SETREP:=MODEBYTE.SETREP*NOTBRS;
  OUTPUT(MODE,MODEBYTE.CHAREP)
END;


FUNCTION READBLKCH:CHAR;        {RETURN NEXT CHAR IN DISK FILE}
VAR  I:INTEGER;
BEGIN
  IF RBINDX>511 THEN
  BEGIN
    WRITELN;
    I:=BLOCKREAD(UTEXTFILE,FILEBUF,1);
    WRITELN;
    UBLKNUM:=UBLKNUM+1;
    RBINDX:=0
  END;
  READBLKCH:=FILEBUF[RBINDX];
  RBINDX:=RBINDX+1
END;


PROCEDURE WRITEBLK;              {WRITE A BLOCK OF CHAR TO DISK FILE}
VAR  I,J:INTEGER;
BEGIN
  FOR J:=5 TO BLKSIZE+4 DO
  BEGIN
    IF RBINDX>511 THEN
    BEGIN
      WRITELN;
      I:=BLOCKWRITE(UTEXTFILE,FILEBUF,1);
      RBINDX:=0
    END;
    FILEBUF[RBINDX]:=IOBUF[J];
    RBINDX:=RBINDX+1
  END
END;


PROCEDURE FLUSHBUFFER;          {EMPTY DISK WRITE BUFFER TO DISK}
VAR  I:INTEGER;
BEGIN
  FOR I:=RBINDX TO 511 DO FILEBUF[I]:=NULL;
  I:=BLOCKWRITE(UTEXTFILE,FILEBUF,1)
END;


PROCEDURE TEST;
BEGIN
  RBINDX:=1;
  BLKSIZE:=512;
  REWRITE(UTEXTFILE,'TEST.TEXT');
  FOR I:=0 TO 511 DO IOBUF[I]:='A';
  WRITEBLK;
  WRITEBLK;
  FLUSHBUFFER;
  CLOSE(UTEXTFILE,LOCK)
END;



FUNCTION RECEIVEBLK:CHAR;          {RECEIVE BLOCK RETURN SEQ/TYP}
VAR  I:INTEGER;
   LEN:PACKEDNUM;
BEGIN
  NAKCNT:=0;
  REPEAT
    REPEAT
      IOBUF[0]:=RECBYTE;
      IF EXITFLG THEN
      BEGIN
        WRITELN;
        WRITELN('RECEIVE TIME OUT, NAK SENT',BELL);
        SBLKSEND(NAK);
        NAKCNT:=NAKCNT+1;
        IF NAKCNT=4 THEN EXIT(RECEIVEBLK) ELSE EXITFLG:=FALSE
      END
    UNTIL IOBUF[0]=SOH;
    DISPHEX(IOBUF[0]);
    FOR I:=1 TO 4 DO
    BEGIN
      IOBUF[I]:=RECBYTE;
      DISPHEX(IOBUF[I])
    END;
    CRC.CH[0]:=IOBUF[1];
    CRC.CH[1]:=IOBUF[2];
    IF IOBUF[1]=NULL THEN
    BEGIN
      FOR I:=3 TO 4 DO CRC.INT:=CRC16(CRC.CH[0],CRC.CH[1],IOBUF[I]);
      IF CRC.INT<>0 THEN
      BEGIN
        WRITELN('RECEIVE BLOCK CRC ERROR');
        EXIT(PROGRAM)
      END ELSE RECEIVEBLK:=IOBUF[2]
    END ELSE
    BEGIN
      IF FIRSTBLK THEN
      BEGIN
        LEN.CH[1]:=IOBUF[2];
        LEN.CH[0]:=IOBUF[3];
        BLKSIZE:=LEN.INT;
        FIRSTBLK:=FALSE
      END;
      FOR I:=5 TO BLKSIZE+7 DO
      BEGIN
        IOBUF[I]:=RECBYTE;
        DISPHEX(IOBUF[I])
      END;
      FOR I:=3 TO BLKSIZE+7 DO CRC.INT:=CRC16(CRC.CH[0],CRC.CH[1],IOBUF[I])
    END;
    DISPINDX:=1;
    IF CRC.INT<>0 THEN SBLKSEND(NAK)
  UNTIL CRC.INT=0;
  WRITEBLK;
  WRITELN;
  WRITELN('BLOCK ',BLKNUM,'   BYTES ',BLKSIZE*BLKNUM);
  WRITELN;
  BLKNUM:=BLKNUM+1;
  IF IOBUF[1]<>NULL THEN SBLKSEND(ACK) ELSE
  IF IOBUF[2]=EOT THEN SBLKSEND(EOT)
END;


PROCEDURE RECEIVE;
VAR  I:INTEGER;
   ERR:INTEGER;
    CH:CHAR;
BEGIN
  I:=POS('RECEIVE',FUNCT);
  IF NEXTSTR(I) THEN
  BEGIN
    RECFLG:=TRUE;
    DISPINDX:=1;
    RBINDX:=0;
    BLKNUM:=0;
    IF POS('HEX',FUNCT)<>0 THEN HEX:=TRUE ELSE HEX:=FALSE;
    I:=0;
    {$I-}
    RESET(UTEXTFILE,NAME);
    {$I+}
    ERR:=IORESULT;
    IF ERR=10 THEN REWRITE(UTEXTFILE,NAME) ELSE
    IF ERR=0 THEN
    BEGIN
      WRITE(NAME,' ALREADY EXISTS, DO YOU WANT TO OVERWRITE IT (Y/N) ');
      READ(CH);
      IF CH<>'Y' THEN EXIT(RECEIVE) ELSE REWRITE(UTEXTFILE,NAME)
    END ELSE
    BEGIN
      WRITELN('ERROR IN OPENING FILE ',NAME);
      EXIT(RECEIVE)
    END;
    FIRSTBLK:=TRUE;
    DBYTE.CHAREP:=INPUT(DATA);          {CLEAR MODEM INPUT}
    WHILE ((RECEIVEBLK<>EOT) AND NOT EXITFLG) DO WRITEBLK;
    FLUSHBUFFER;
    IF NOT EXITFLG THEN CLOSE(UTEXTFILE,LOCK) ELSE CLOSE(UTEXTFILE);
    IF TIMER=0 THEN
    BEGIN
      WRITELN;WRITELN;
      WRITE('RECEIVE TERMINATED NO MESSAGE',BELL)
    END;
    EXITFLG:=FALSE
  END ELSE
  BEGIN
    WRITELN;
    WRITE('MISSING FILE NAME')
  END
END;
       
       

PROCEDURE SEND;
VAR  I:INTEGER;
   ERR:INTEGER;
    CH:CHAR;
BEGIN
  RECFLG:=FALSE;
  I:=POS('SEND',FUNCT);
  IF NEXTSTR(I) THEN
  BEGIN
    IF POS('HEX',FUNCT)<>0 THEN HEX:=TRUE ELSE HEX:=FALSE;
    I:=0;
    {$I-}
    IF BLK THEN RESET(UTEXTFILE,NAME) ELSE RESET(TEXTFILE,NAME);
    {$I+}
    ERR:=IORESULT;
    IF ERR<>0 THEN WRITELN('ERROR IN OPENING FILE') ELSE
       IF BLK THEN
       BEGIN
         WHILE NOT EOF(UTEXTFILE) DO
         BEGIN
           CH:=READBLKCH;
           BLKTRANS(CH);
           IF EXITFLG THEN
           BEGIN
             CLOSE(UTEXTFILE);
             BLK:=FALSE;
             EXITFLG:=FALSE;
             IF TIMER=0 THEN
             BEGIN
               WRITELN;
               WRITELN('TRANSMIT TIME-OUT NO ACKNOWLEDGEMENT',BELL);
             END;
             EXIT(SEND)
           END
         END;
         CLOSE(UTEXTFILE);
         BLK:=FALSE;
         SBLKSEND(EOT)
       END ELSE
       WHILE NOT EOF(TEXTFILE) DO
        BEGIN
          IF CHECKC THEN
          BEGIN
            CLOSE(TEXTFILE);
            EXIT(SEND)
          END ELSE
          BEGIN
            READ(TEXTFILE,CH);
            TRANSMIT(CH);
            IF HEX THEN
            BEGIN
              HEXOUT(CH);
              I:=I+2;
              IF I> SCREENWIDTH THEN 
              BEGIN
                I:=0;
                WRITELN
              END
            END ELSE 
            BEGIN
              WRITE(CH);
              IF EOLN(TEXTFILE) THEN WRITELN
            END;
            IF EOLN(TEXTFILE) THEN 
            BEGIN
              TRANSMIT(CR);
              IF CPM THEN TRANSMIT(LF)
            END
          END
        END;
    CLOSE(TEXTFILE)
  END ELSE
  BEGIN
    WRITELN;
    WRITE('MISSING FILE SPECIFICATION',BELL)
  END
END;


PROCEDURE STATUS;               {DISPLAY CURRENT STATUS}
BEGIN
  WRITE(CHR(CLRSCR));
  WRITELN;WRITELN;
  WRITE('CURRENT MODEM STATUS':45);
  WRITELN;WRITELN;WRITELN;
  WRITE('PHONE           ');
  IF MODEBYTE.SETREP*[7]<>[] THEN WRITELN('OFFHOOK') ELSE WRITELN('ONHOOK');
  WRITE('MODE            ');
  IF MODEBYTE.SETREP*[2]<>[] THEN WRITELN('ORIGINATE') ELSE
       WRITELN('ANSWER');
  WRITE('BAUD RATE       ');
  IF MODEBYTE.SETREP*[0]<>[] THEN WRITELN('110 BAUD') ELSE WRITELN('300 BAUD');
  WRITE('TRANSMITTER     ');
  IF MODEBYTE.SETREP*[1]<>[] THEN WRITELN('ON') ELSE WRITELN('OFF');
  WRITE('CARRIER         ');
  CBYTE.CHAREP:=INPUT(STAT);
  IF CBYTE.SETREP*[6]<>[] THEN WRITELN('ON') ELSE WRITELN('OFF');
END;

PROCEDURE CONVERSE;
 BEGIN
  EFLAG:=FALSE;
  EOTFLG:=FALSE;
  CONNECT;
  REPEAT
    INBYTE.CHAREP:=INPUT(STAT);
    INB.CHAREP:=INPUT(255);M    IF((INBYTE.SETREP*CARDET<>[]) OR (INB.SETREP*CARDET<>[])) THEN
    BEGIN
      IBYTE.CHAREP:=INPUT(STAT);
      IF IBYTE.SETREP*RRF<>[] THEN GETCHAR;
      IF READY THEN
      BEGIN
        UNITREAD(2,C[0],1);
        IF C[0]=NAK THEN BREAK;
        IF CONECHO THEN WRITE(C[0]);
        IF((C[0]=CR) AND AUTOLF) THEN TRANSMIT(LF);
        IF C[0]=CONTRLE THEN EFLAG:=TRUE;
        IF C[0]=CONTRLH THEN
        BEGIN
          WRITE(' ',CONTRLH);
          TRANSMIT(CONTRLH);
          TRANSMIT(' ')
        END;
        IF C[0]=CONTRLD THEN
          BEGIN
            EOTFLG:=TRUE;
            WRITELN;
            WRITELN('EOT')
          END;
        TRANSMIT(C[0])
      END;
    END ELSE
    BEGIN
      WRITELN;
      WRITE('LOST CARRIER',BELL);
      EOTFLG:=TRUE
    END
  UNTIL (EOTFLG OR EFLAG);
END; {CONVERSE}

PROCEDURE RING;
BEGIN
  REPEAT
  WRITELN;WRITELN;
  WRITE('WAITING FOR RING OR CONTROL B ');
  CALLMADE:=FALSE;
  EFLAG:=FALSE;
  EOTFLG:=FALSE;
  REPEAT
    IF READY THEN
    BEGIN
      UNITREAD(2,C[0],1);
      IF C[0]=CONTRLB THEN MAKECALL;
      IF C[0]=CONTRLE THEN EXIT(RING)
    END;
    INBYTE.CHAREP:=INPUT(STAT);
    INB.CHAREP:=INPUT(255);
    IF((INBYTE.SETREP*RNGDET=[]) OR (INB.SETREP*RNGDET<>[]))
     THEN ANSWCALL
  UNTIL CALLMADE;
  CONVERSE;
  IF NOT EFLAG THEN HANGUP;
UNTIL EFLAG
END; {RING}

BEGIN {MAIN PROG}
WRITELN;WRITELN;WRITELN;
WRITELN('PASCAL MODEM PROGRAM':45);
INITIALIZE;
  REPEAT
    WRITELN;WRITELN;
    WRITE('ENTER FUNCTION ');
    UNITREAD(2,C[0],1);
    IF C[0]=CONTRLC THEN QUIT;
    WRITE(C[0]);
    READLN(FUNCT);
    S[1]:=C[0];
    FUNCT:=CONCAT(S,FUNCT,'  ');
    IF POS('CONECHO',FUNCT)<>0 THEN CONECHO:=NOT CONECHO;
    IF POS('STAT',FUNCT)<>0 THEN STATUS;
    IF POS('CPM',FUNCT)<>0 THEN CPM:=NOT CPM;
    IF POS('AUTOLF',FUNCT)<>0 THEN AUTOLF:=NOT AUTOLF;
    IF POS('SPEED',FUNCT)<>0 THEN SPEED;
    IF POS('BLOC',FUNCT)<>0 THEN BLOCK;
    IF POS('PHONE',FUNCT)<>0 THEN RING;
    IF POS('CONV',FUNCT)<>0 THEN CONVERSE;
    IF POS('SEND',FUNCT)<>0 THEN SEND;
    IF POS('RECEI',FUNCT)>0 THEN RECEIVE
  UNTIL FOREVER
END.


========================================================================================
DOCUMENT :usus Folder:VOL01:modem1.text
========================================================================================

PROGRAM MODEM;
  
     {Written by J. M. Wierda

     This program is basically a re-write in PASCAL of Ward Christensen's
Modem Program which was distributed in CP/M User's Group Volume 25. Identical
and compatible options are provided to allow this program to work directly
with Ward's program running under CP/M. One difference is that when sending
files the PASCAL or CP/M transfer mode must be selected. The PASCAL mode
transfers files between two systems running PASCAL, while the CP/M mode is
used when the receiving system is running CP/M. Basically the CP/M mode
provides the linefeeds required to make a PASCAL file compatible with CP/M.
When CP/M files are received they contain linefeeds, these can be deleted
using the editor to make the file compatible with PASCAL. CP/M files may also
contain tabs which the PASCAL editor does not expand.

     External assembly language routines are used to read the status, and read
or wrkte the keyboard and modem ports. These routines are available as
separate files for the 8080 and Z80 processors. The port and flag definitions,
and the timing constant for the one second delay should be changed as required
for your particular hardware.

     The program has been tested with text files only, and may not work
correctly for code or other types of files.

     The PDP-10 mode transfers PASCAL files to a DEC SYSTEM-10 computer.}

CONST

NUL=0;
SOH=1;
CTRLC=3;
EOT=4;
ERRORMAX=5;
RETRYMAX=5;
CTRLE=5;
ACK=6;
TAB=9;
LF=10;
CR=13;
CTRLQ=17;
CTRLS=19;
NAK=21;
CTRLZ=26;
SPACE=32;
DELETE=127;
LASTBYTE=127;
TIMEOUT=256;
LOOPSPERSEC=1800;       {1800 LOOPS PER SECOND AT 4MHZ}

KBSP=0;           {KEYBOARD STATUS PORT}
KBDRF=128;        {KEYBOARD DATA READY FLAG}

KBDP=1;           {KEYBOARD DATA PORT}
KBMASK=127;       {KEYBOARD DATA MASK}
  
DCHDP=128;        {D. C. HAYES DATA PORT}
DCHMASK=255;      {D. C. HAYES DATA MASK}

DCHSP=129;        {D. C. HAYES STATUS PORT}
                  {STATUS PORT BIT ASSIGNMENTS}
RRF     =    1;   {RECEIVE REGISTER FULL}
TRE     =    2;   {TRANSMIT REGISTER EMPTY}
PERR    =    4;   {PARITY ERROR}
FERR    =    8;   {FRAMING ERROR}
OERR    =    16;  {OVERFLOW ERROR}
CD      =    64;  {CARRIER DETECT}
NRI     =    128; {NO RINGING INDICATOR}

DCHCP1=129;       {D. C. HAYES CONTROL PORT 1}
                  {CONTROL PORT 1 BIT ASSIGNMENTS}
EPE     =    1;   {EVEN PARITY ENABLE}
LS1     =    2;   {LENGTH SELECT 1}
LS2     =    4;   {LENGTH SELECT 2}
SBS     =    8;   {STOP BIT SELECT}
PI      =    16;  {PARITY INHIBIT}

DCHCP2=130;       {D. C. HAYES CONTROL PORT 2}
                  {CONTROL PORT 2 BIT ASSIGNMENTS}
BRS     =    1;   {BIT RATE SELECT}
TXE     =    2;   {TRANSMIT ENABLE}
MS      =    4;   {MODE SELECT}
ES      =    8;   {ECHO SUPPRESS}
ST      =    16;  {SELF TEST}
RID     =    32;  {RING INDICATOR DISABLE}
OH      =    128; {OFF HOOK}

VAR FILE1 : TEXT;
    OPTION, HANGUP, RETURN, MODE, BAUDRATE, DISPLAY, FILEMODE : CHAR;
    SECTOR : ARRAY[0..LASTBYTE] OF INTEGER;
    DCHCW2 : INTEGER;
    OVRN1, OVRN2, SHOWRECV, SHOWTRANS : BOOLEAN;
    
FUNCTION STAT(PORT,EXR,MASK:INTEGER):BOOLEAN; EXTERNAL;

FUNCTION INPUT(PORT,MASK:INTEGER):INTEGER; EXTERNAL;

PROCEDURE OUTPUT(PORT,DATA:INTEGER); EXTERNAL;


PROCEDURE SENDLINE(SLDATA:INTEGER);
  
BEGIN
  REPEAT
  UNTIL
    STAT(DCHSP,TRE,TRE);
  OUTPUT(DCHDP,SLDATA);
  IF SHOWTRANS
    THEN
      IF (SLDATA = CR) OR ((SLDATA >= SPACE) AND (SLDATA <= DELETE))
        THEN
          WRITE(CHR(SLDATA))
END;


FUNCTION READLINE(SECONDS:INTEGER):INTEGER;

VAR J : INTEGER;
  
BEGIN
  J := LOOPSPERSEC * SECONDS;
  REPEAT
    J := J-1
  UNTIL
    (STAT(DCHSP,RRF,RRF)) OR (J = 0);
  IF J = 0
    THEN
      READLINE := TIMEOUT
    ELSE
      BEGIN
        J := INPUT(DCHDP,DCHMASK);
        IF SHOWRECV
          THEN
            IF (J = CR) OR ((J >= SPACE) AND (J <= DELETE))
              THEN
                WRITE(CHR(J));
          READLINE := J
      END
END;


PROCEDURE SENDSTR(STR:STRING);

VAR J:INTEGER;
  
BEGIN
  FOR J := 1 TO LENGTH(STR) DO
    SENDLINE(ORD(STR[J]))
END;


FUNCTION UPPERCASE(CH : CHAR) : CHAR;

BEGIN
  IF CH IN ['a'..'z']
    THEN
      UPPERCASE := CHR(ORD(CH)-SPACE)
    ELSE
      UPPERCASE := CH
END;


PROCEDURE PURGELINE;

VAR J : INTEGER;
  
BEGIN
  REPEAT
    J := INPUT(DCHDP,DCHMASK);      {PURGE THE RECEIVE REGISTER}
  UNTIL
    NOT STAT(DCHSP,RRF,RRF)
END;


PROCEDURE DCHINITIALIZE;
  BEGIN
    WRITELN('Waiting for carrier');
    REPEAT
      BEGIN
        IF OPTION IN ['R','S']
          THEN
            BEGIN
              OUTPUT(DCHCP1,PI+LS2+LS1);
              OUTPUT(DCHCP2,OH+RID+TXE+DCHCW2)
            END;
        IF OPTION IN ['C','P','T']
          THEN
            BEGIN
              OUTPUT(DCHCP1,LS2+EPE);
              OUTPUT(DCHCP2,OH+RID+TXE+DCHCW2)
            END
      END
    UNTIL
      (STAT(DCHSP,CD,CD)) OR (INPUT(KBDP,KBMASK) = CTRLE);
    PURGELINE;
    WRITELN('Carrier detected')
  END;
  

PROCEDURE MAKESECTOR;

VAR J : INTEGER;
  CH : CHAR;
  
BEGIN
  J := 0;
  IF OVRN1
    THEN
      BEGIN
        SECTOR[J] := CR;
        J := J+1
      END;
  IF OVRN2
    THEN
      BEGIN
        SECTOR[J] := LF;
        J := J+1
      END;
  OVRN1 := FALSE;
  OVRN2 := FALSE;
  WHILE (NOT EOF(FILE1)) AND (J <= LASTBYTE) DO
    BEGIN
      WHILE (NOT EOLN(FILE1)) AND (J <= LASTBYTE) DO
        BEGIN
          READ(FILE1,CH);
          IF ORD(CH) <> LF
            THEN
              BEGIN
                SECTOR[J] := ORD(CH);
                J := J+1
              END
        END;
      IF EOLN(FILE1)
        THEN
          BEGIN
            READLN(FILE1);
            IF FILEMODE IN ['P']
              THEN
                IF J <= LASTBYTE
                  THEN
                    BEGIN
                      SECTOR[J] := CR;
                      J := J+1
                    END
                  ELSE
                    OVRN1 := TRUE
              ELSE
                BEGIN
                  IF J <= (LASTBYTE-1)
                    THEN
                      BEGIN
                        SECTOR[J] := CR;
                        SECTOR[J+1] := LF;
                        J := J+2
                      END
                    ELSE
                      IF J = LASTBYTE
                        THEN
                          BEGIN
                            SECTOR[J] := CR;
                            J := J+1;
                            OVRN1 := TRUE
                          END
                        ELSE
                          IF J > LASTBYTE
                            THEN
                              BEGIN
                                OVRN1 := TRUE;
                                OVRN2 := TRUE
                              END
                END
          END
    END;
  CASE FILEMODE OF
    'P' : IF J <= LASTBYTE
          THEN
            FOR J := J TO LASTBYTE DO
              SECTOR[J] := SPACE;
    'C' : IF J <= LASTBYTE
          THEN
            FOR J := J TO LASTBYTE DO
              SECTOR[J] := CTRLZ
  END
END;


PROCEDURE TERMCOMP;
  
VAR KBDATA, DCHDATA : INTEGER;
    CRFLAG : BOOLEAN;

BEGIN
  CRFLAG := FALSE;
  DCHINITIALIZE;
  WHILE STAT(DCHSP,CD,CD) AND (KBDATA <> CTRLE) DO
    BEGIN
      IF STAT(KBSP,KBDRF,KBDRF)
        THEN
          BEGIN
            KBDATA := INPUT(KBDP,KBMASK);
            IF OPTION IN ['C']
              THEN
                WRITE(CHR(KBDATA));
              OUTPUT(DCHDP,KBDATA)
            END;
      IF STAT(DCHSP,RRF,RRF)
        THEN
          BEGIN
            DCHDATA := INPUT(DCHDP,DCHMASK);
            IF OPTION IN ['C']
              THEN
                OUTPUT(DCHDP,DCHDATA);
            IF DCHDATA = CR
              THEN
                CRFLAG := TRUE;
            IF (DCHDATA = LF) AND CRFLAG
              THEN
                CRFLAG := FALSE
              ELSE
                WRITE(CHR(DCHDATA))
          END
    END
END;


PROCEDURE PDP10;

VAR WAIT10 : BOOLEAN;
    DCHDATA : INTEGER;
    CH : CHAR;
    FILENAME, PDP10FILE : STRING;
    
BEGIN
  SHOWRECV := FALSE;
  SHOWTRANS := TRUE;
  WAIT10 := FALSE;
  WRITE('Filename.Ext ? ');
  READLN(FILENAME);
  RESET(FILE1,FILENAME);
  WRITE('PDP-10 Filename.Ext ? ');
  READLN(PDP10FILE);
  DCHINITIALIZE;
  SENDLINE(CR);
  SENDSTR('R PIP');
  SENDLINE(CR);
  REPEAT
  UNTIL
    READLINE(5) IN [ORD('*'),TIMEOUT];
  SENDSTR(PDP10FILE);
  SENDSTR('=TTY:');
  SENDLINE(CR);
  WHILE (NOT EOF(FILE1)) AND (STAT(DCHSP,CD,CD)) DO
    BEGIN
      WHILE NOT EOLN(FILE1) DO
        BEGIN
          IF NOT WAIT10
            THEN
              BEGIN
                READ(FILE1,CH);
                SENDLINE(ORD(CH))
              END;
          IF STAT(DCHSP,RRF,RRF)
            THEN
              BEGIN
                DCHDATA := INPUT(DCHDP,DCHMASK);
                IF DCHDATA = CTRLS
                  THEN
                    WAIT10 := TRUE;
                IF DCjDATA = CTRLQ
                  THEN
                    WAIT10 := FALSE
              END
        END;
      READLN(FILE1);
      SENDLINE(CR)
    END;
  CLOSE(FILE1);
  REPEAT
  UNTIL
    READLINE(1)=TIMEOUT;
  SENDLINE(CTRLZ);
  SENDLINE(CTRLC);
  TERMCOMP
END;


PROCEDURE SENDFILE;

VAR J, K, SECTORNUM, COUNTER, CHECKSUM : INTEGER;
    FILENAME : STRING;

BEGIN
  WRITE('Filename.Ext ? ');
  READLN(FILENAME);
  RESET(FILE1,FILENAME);
  SECTORNUM := 1;
  DCHINITIALIZE;
  OVRN1 := FALSE;
  OVRN2 := FALSE;
  REPEAT
    COUNTER := 0;
    MAKESECTOR;
    REPEAT
      WRITELN;
      WRITELN('Sending sector ', SECTORNUM);
      SENDLINE(SOH);
      SENDLINE(SECTORNUM);
      SENDLINE(-SECTORNUM-1);
      CHECKSUM := 0;
      FOR J := 0 TO LASTBYTE DO
        BEGIN
          SENDLINE(SECTOR[J]);
          CHECKSUM := (CHECKSUM + SECTOR[J]) MOD 256
        END;
      SENDLINE(CHECKSUM);
      PURGELINE;
      COUNTER := COUNTER + 1;
    UNTIL
      (READLINE(10) = ACK) OR (COUNTER = RETRYMAX);
    SECTORNUM := SECTORNUM + 1
  UNTIL
    (EOF(FILE1)) OR (COUNTER = RETRYMAX);
  IF COUNTER = RETRYMAX
    THEN
      BEGIN
        WRITELN;
        WRITELN('No ACK on sector')
      END
    ELSE
      BEGIN
        COUNTER := 0;
        REPEAT
          SENDLINE(EOT);
          COUNTER := COUNTER + 1
        UNTIL
          (READLINE(10) = ACK) OR (COUNTER = RETRYMAX);
        IF COUNTER = RETRYMAX
          THEN
            BEGIN
              WRITELN;
              WRITELN('No ACK on EOT')
            END
          ELSE
            BEGIN
              WRITELN;
              WRITELN('Transfer complete')
            END
      END;
  CLOSE(FILE1)
END;

  
PROCEDURE READFILE;

VAR J, FIRSTCHAR, SECTORNUM,SECTORCURRENT, SECTORCOMP, ERRORS,
    CHECKSUM : INTEGER;
    ERRORFLAG : BOOLEAN;
    FILENAME : STRING;
    
BEGIN
  WRITE('Filename.Ext ? ');
  READLN(FILENAME);
  REWRITE(FILE1,FILENAME);
  SECTORNUM := 0;
  ERRORS := 0;
  DCHINITIALIZE;
  REPEAT
    ERRORFLAG := FALSE;
    REPEAT
      FIRSTCHAR :=READLINE(15)
    UNTIL FIRSTCHAR IN [SOH,EOT,TIMEOUT];
    IF FIRSTCHAR = TIMEOUT
      THEN
        BEGIN
          WRITELN;
          WRITELN('SOH error');
        END;
    IF FIRSTCHAR = SOH
      THEN
        BEGIN
          SECTORCURRENT := READLINE(1);
          SECTORCOMP := READLINE(1);
          IF (SECTORCURRENT+SECTORCOMP)=255
            THEN
              BEGIN
                IF (SECTORCURRENT=SECTORNUM+1)
                  THEN
                    BEGIN
                      CHECKSUM := 0;
                      FOR J := 0 TO LASTBYTE DO
                        BEGIN
                          SECTOR[J] := READLINE(1);
                          CHECKSUM := (CHECKSUM+SECTOR[J]) MOD 256
                        END;
                      IF CHECKSUM=READLINE(1)
                        THEN
                          BEGIN
                            FOR J := 0 TO LASTBYTE DO
                              WRITE(FILE1,CHR(SECTOR[J]));
                            ERRORS:=0;
                            SECTORNUM := SECTORCURRENT;
                            WRITELN;
                            WRITELN('Received sector ',SECTORCURRENT);
                            SENDLINE(ACK)
                          END
                        ELSE
                          BEGIN
                            WRITELN;
                            WRITELN('Checksum error');
                            ERRORFLAG := TRUE
                          END
                    END
                  ELSE
              IF (SECTORCURRENT=SECTORNUM)
                THEN
                  BEGIN
                    REPEAT
                    UNTIL
                      READLINE(1)=TIMEOUT;
                    WRITELN;
                    WRITELN('Received duplicate sector ', SECTORCURRENT);
                    SENDLINE(ACK)
                  END
                ELSE
                  BEGIN
                    WRITELN;
                    WRITELN('Synchronization error');
                    ERRORFLAG := TRUE
                  END
              END
            ELSE
              BEGIN
                WRITELN;
                WRITELN('Sector number error');
                ERRORFLAG := TRUE
              END
        END;
    IF (ERRORFLAG=TRUE)
      THEN
        BEGIN
          ERRORS := ERRORS+1;
          REPEAT
          UNTIL
            READLINE(1)=TIMEOUT;
            SENDLINE(NAK)
        END;
  UNTIL
    (FIRSTCHAR IN [EOT,TIMEOUT]) OR (ERRORS = ERRORMAX);
  IF (FIRSTCHAR = EOT) AND (ERRORS < ERRORMAX)
    THEN
      BEGIN
        SENDLINE(ACK);
        CLOSE(FILE1,LOCK);
        WRITELN;
        WRITELN('Transfer complete')
      END
    ELSE
      BEGIN
        CLOSE(FILE1);
        WRITELN;
        WRITELN('Aborting')
      END
END;


BEGIN {MAINLINE}
  WRITELN('Modem, 1-May-79');
  REPEAT
    REPEAT
      WRITE('Option : C(omputer), P(DP-10), R(eceive), S(end), T(erminal) ? ');
      READ(OPTION);
      OPTION := UPPERCASE(OPTION);
      WRITELN
    UNTIL
      OPTION IN ['C','P','R','S','T'];
    REPEAT
      WRITE('Mode : A(nswer), O(riginate) ? ');
      READ(MODE);
      MODE := UPPERCASE(MODE);
      WRITELN
    UNTIL
      MODE IN ['A','O'];
    IF MODE IN ['O']
      THEN
        DCHCW2 := MS
      ELSE
        DCHCW2 := 0;
    REPEAT
      WRITE('Baud rate : 1(00), 3(00) ? ');
      READ(BAUDRATE);
      WRITELN
    UNTIL
      BAUDRATE IN ['1','3'];
    IF BAUDRATE='3'
      THEN
        DCHCW2 := DCHCW2+BRS;
    IF OPTION IN ['R','S']
      THEN
        BEGIN
          REPEAT
            WRITE('Display : N(o), R(eceived), T(ransmitted) data ? ');
            READ(DISPLAY);
            DISPLAY := UPPERCASE(DISPLAY);
            WRITELN
          UNTIL
            DISPLAY IN ['N','R','T'];
          IF OPTION = 'S'
            THEN
              BEGIN
                REPEAT
                  WRITE('File mode : C(pm), P(ascal) ? ');
                  READ(FILEMODE);
                  FILEMODE := UPPERCASE(FILEMODE);
                  WRITELN
                UNTIL
                  FILEMODE IN ['C','P']
              END;
          CASE DISPLAY OF
            'N':BEGIN
                  SHOWRECV := FALSE;
                  SHOWTRANS := FALSE
                END;
            'R':BEGIN
                  SHOWRECV := TRUE;
                  SHOWTRANS := FALSE
                END;
             'T':BEGIN
                   SHOWRECV := FALSE;
                   SHOWTRANS := TRUE
                 END
          END {CASE}
        END;
  
     CASE OPTION OF
       'C': TERMCOMP;
       'P': PDP10;
       'R': READFILE;
       'S': SENDFILE;
       'T': TERMCOMP
     END;       {CASE}
       
     REPEAT
       WRITELN;
       WRITE('Hangup : Y(es), N(o) ? ');
       READ(HANGUP);
       HANGUP := UPPERCASE(HANGUP);
       WRITELN
     UNTIL HANGUP IN ['Y','N'];
     IF HANGUP IN ['Y']
       THEN
         OUTPUT(DCHCP2,0);
     REPEAT
       WRITELN;
       WRITE('Return to system : Y(es), N(o) ? ');
       READ(RETURN);
       RETURN := UPPERCASE(RETURN);
       WRITELN
     UNTIL
       RETURN IN ['Y','N'];
   UNTIL RETURN IN ['Y']
END.

                                                                                                                             
========================================================================================
DOCUMENT :usus Folder:VOL01:pretty.doc.text
========================================================================================


                  DOCUMENTATION FOR THE PASCAL PRETTYPRINTERS

     There are two Pascal source formatting and beautifying programs on this 
disk, both from the Pascal News Number 13 (December 1978).  Because they were 
prepared on the E6 editor, which does not allow text longer than memory (10K 
to 25K available depending on how much RAM there is in your system), each 
program is provided in parts that are drawn into the compiler via the I(nclude 
compiler option.  Since I already had to partition the compiler to compile 
both programs on my medium-sized (56K) system, I did not further split up the 
files to fit within a smaller RAM space for editing, since they will not then
compile.  If subfiles do not share the same name (plus a number) as the main
file, this is noted below.  Further, each program has been modified to run
under UCSD Pascal, usually by changing plain "Write (X)" statements to "Write
(Outfile, X)," and similarly with read.  Initializing text was added to set up
the input and output files at run time.  Finally, several PACK and UNPACK
statements in FORMAT (noted within the source file) were changed to their
equivalents, since the UCSD compiler does not support these standard
procedures.

     PRETTY.TEXT (which pulls in INITVARS.TEXT as a subfile--this contains the 
variable initializing portion of the program) is the simpler and more 
forgiving of the Pascal formatters.  Unlike FORMAT, programs which are 
syntactically incorrect MAY get through the beautifying process.  What PRETTY 
does to your file is fixed at compile time; however, it respects line ends and 
other spacing already present within the file to a degree.

     FORMAT.TEXT and subfiles is fully documented in FORMAT.DOC.TEXT, which I
copied from the Pascal News.  Andy Mickel, then the editor of the Pascal News, 
claims that FORMAT is especially clear-cut in its variable names and procedure 
layout; I agree.  There is a hidden gotcha, apparantly: Pascal News Number 15
noted letters from irate users, who found bugs in certain areas, such as the
lack of inserted spaces before the ".." (range) symbol and "ugly breaking upon
wraparound of several expressions in assignment statements." Fixes are
promised in a forthcoming issue of Pascal News. Frankly, I think the thing
works fairly well and is a big improvement over manually breaking out the
structure of a program you plan to publish.  And it has some VERY nice
features; I am particularly enamoured of being able to automatically add
comments after an "END" statement pointing out of which program statement it
is the end!

     If you have the UCSD system you will note that both programs run slowly, 
victims of multiple procedure calls for each letter of the source file and 
output file.  This problem can be solved by 1) waiting, 2) getting a machine-
language compiler, or, preferably, 3) hanging on until the 16-bit
microprocessors are available, which handle procedure calls with applomb
(particularly the M68000).  If you rewrote the reading/writing parts to accept
UCSD-type strings, it would run faster but might not work on your next Pascal 
system.

========================================================================================
DOCUMENT :usus Folder:VOL01:pretty.text
========================================================================================

(*$S+*)
PROGRAM PRETTYPRINT;

CONST  maxsymbolsize = 200 (* max # of char in symbol scanned by scanner*);
       maxstacksize = 100 (* max # of symbols causing indentation that may
                             be stacked *);
       maxkeylength = 10 (* max length Pascal reserved word *);
       maxlinesize = 72 (* max length of line output by program *);
       slofail1 = 30 (* up to this column position, margin will be indented
                        by "indent1". *);
       slofail2 = 48 (* up to this column positn, each time "indentbytab" is
                        invoked, the margin will be indented by "indent2." *);
       indent1 = 3;
       indent2 = 1;
       space = ' ';
       
        
TYPE   keysymbol = (progsym,     funcsym,        procsym,        labelsym,
                    constsym,    typesym,        varsym,         beginsym,
                    repeatsym,   recordsym,      casesym,        casevarsym,
                    ofsym,       forsym,         whilesym,       withsym,
                    dosym,       ifsym,          thensym,        elsesym,
                    endsym,      untilsym,       becomes,        opencomment,
                    closecomment,semicolon,      colon,          equals,
                    openparen,   closeparen,     openbracket,    closebracket, 
                    period,      endoffile,      othersym);
       
       option = (crsuppress,    crbefore,       blanklinebefore,
                 dindentonkeys, dindent,        spacebefore,
                 spaceafter,    gobblesymbols,  indentbytab,
                 indenttoclp,   crafter);
       
       optionset = SET OF option;
       
       keysymset = SET OF keysymbol;
       
       tableentry = RECORD
                        optionsselected  : optionset;
                        dindentsymbols   : keysymset;
                        gobbleterminators: keysymset
                    END;
                    
       optiontable = ARRAY [keysymbol] OF tableentry;
       
       key = PACKED ARRAY [1..maxkeylength] OF CHAR;
       
       keywordtable = ARRAY [progsym..untilsym] OF key;
       
       specialchar = PACKED ARRAY [1..2] OF CHAR;
       
       dblchrset = SET OF becomes..opencomment;
       
       dblchartable = ARRAY [becomes..opencomment] of specialchar;

       sglchartable = ARRAY [semicolon..period] OF char;
       
       lstring = ARRAY [1..maxsymbolsize] OF char;
       
       symbol = RECORD
                   name         : keysymbol;
                   valu         : lstring;
                   lngth       : integer;
                   spacesbefore : integer;
                   crsbefore    : integer
                END;
                
       symbolinfo = ^symbol;
       
       charname = (letter,      digit,          blank,          quote,
                   endofline,   filemark,       otherchar);
                   
       charinfo = RECORD
                     name : charname;
                     valu : char
                  END;
       
       stackentry = RECORD
                       indentsymbol: keysymbol;
                       prevmargin  : integer
                    END;
                    
       symbolstack = ARRAY [1..maxstacksize] OF stackentry;
       
       
VAR  recordseen: boolean;
     currchar, nextchar     : charinfo;
     currsym, nextsym       : symbolinfo;
     crpending              : boolean;
     ppoption               : optiontable;
     keyword                : keywordtable;
     dblchars               : dblchrset;
     dblchar                : dblchartable;
     sglchar                : sglchartable;
     stack                  : symbolstack;
     top                    : integer;
     startpos,              (* starting position of last symbol written *)
     currlinepos, currmargin: integer;
     infile, outfile        : TEXT;
     infilename, outfilename: STRING [20];
     
     
(*$IINITVAR.TEXT*)


PROCEDURE Getchar (* from input *) ((* updating *) VAR nextchar: charinfo;
                                    (* returning *)VAR currchar: charinfo);
BEGIN (* getchar *)
  currchar := nextchar;
  WITH nextchar DO
    BEGIN
      IF eof (infile) 
        THEN name := filemark
        ELSE IF eoln (infile)
          THEN name := endofline
          ELSE IF infile^ IN ['A'..'Z', 'a'..'z']
            THEN name := letter
            ELSE IF infile^ in ['0'..'9']
              THEN name := digit
              ELSE IF infile^ = ''''
                THEN name := quote
                ELSE IF infile^ = space
                  THEN name := blank
                  ELSE name := otherchar;
      IF name IN [filemark, endofline]
        THEN valu := space
        ELSE valu := infile^;
      IF name <> filemark THEN get(infile)
    END (*with*)
END; (*getchar*)



PROCEDURE Storenextchar (* from input *)
                ( (*updating *) VAR lngth   : integer;
                                VAR currchar,
                                    nextchar : charinfo;
                  (*placing in*)VAR valu     : lstring);
BEGIN (*storenextchar*)
  getchar (nextchar, currchar);
  IF lngth < maxsymbolsize
    THEN BEGIN
      lngth := succ (lngth);
      valu [lngth] := currchar.valu
    END
END (*storenextchar*);


PROCEDURE Skipspaces ( (* updating*) VAR currchar, nextchar     : charinfo;
                       (*returning*) VAR spacesbefore, crsbefore: integer);
BEGIN
  spacesbefore := 0;
  crsbefore    := 0;
  WHILE nextchar.name IN [blank, endofline] DO
    BEGIN
      getchar (nextchar, currchar);
      CASE currchar.name OF
        blank     : spacesbefore := succ (spacesbefore);
        endofline : BEGIN
                      crsbefore := succ (crsbefore);
                      spacesbefore := 0
                    END
      END (*case*)
    END (*while*)
END (*Skipspaces*);


PROCEDURE Getcomment (* from input, updating: *)
               (VAR currchar, nextchar: charinfo;
                VAR name              : keysymbol;
                VAR valu              : lstring;
                VAR lngth             : integer);
BEGIN
  name := opencomment;
  WHILE NOT (   ((currchar.valu = '*') AND (nextchar.valu = ')'))
             OR (currchar.valu = '}')
             OR (nextchar.name = endofline)
             OR (nextchar.name = filemark)) DO
    storenextchar (lngth, currchar, nextchar, valu);
  IF (currchar.valu = '*') AND (nextchar.valu = ')')
    THEN BEGIN
      storenextchar (lngth, currchar, nextchar, valu);
      name := closecomment
    END;
  IF currchar.valu = '}' THEN name := closebracket
END (*Getcomment*);



FUNCTION Idtype ( (*of*) valu:lstring; (*using*) lngth:integer): keysymbol;

VAR  i: integer;
     keyvalu: key;
     hit: boolean;
     thiskey: keysymbol;
     
BEGIN
  idtype := othersym;
  IF lngth <= maxkeylength THEN
    BEGIN
      FOR i := 1 TO lngth DO 
        IF valu [i] IN ['A'..'Z'] (* switch to lower case*)
          THEN keyvalu [i] := CHR (ORD (valu [i]) + ORD ('a') - ORD ('A'))
          ELSE keyvalu [i] := valu [i];
      FOR i := lngth+1 TO maxkeylength DO keyvalu [i] := space;
      thiskey := progsym;
      hit     := false;
      WHILE NOT (hit OR (thiskey = succ(untilsym))) DO
        IF keyvalu = keyword [thiskey]
          THEN hit := true
          ELSE thiskey := succ (thiskey);
      IF hit THEN idtype := thiskey
    END
END (*Idtype*);


PROCEDURE Getidentifier ( (*from input*)
                        (* updating *) VAR currchar, nextchar: charinfo;
                        (* returning*) VAR name  : keysymbol;
                                       VAR valu  : lstring;
                                       VAR lngth: integer );
BEGIN
  WHILE nextchar.name IN [letter, digit] DO
    Storenextchar (lngth, currchar, nextchar, valu);
  name := idtype (valu, lngth);
  IF name IN [recordsym, casesym, endsym]
    THEN CASE name OF
      recordsym : recordseen := true;
      casesym   : IF recordseen THEN name := casevarsym;
      endsym    : recordseen := false
    END (*case*)
END (*Getidentifier*);



PROCEDURE Getnumber ( (*from input*)
                (* updating *) VAR currchar, nextchar: charinfo;
                (* returning*) VAR name   : keysymbol;
                               VAR valu   : lstring;
                               VAR lngth : integer );
BEGIN
  WHILE nextchar.name = digit DO
    Storenextchar (lngth, currchar, nextchar, valu);
  name := othersym
END (*Getnumber*);


PROCEDURE Getcharliteral ( (* from input *)
                (* updating *) VAR currchar, nextchar: charinfo;
                (* returning*) VAR name   : keysymbol;
                               VAR valu   : lstring;
                               VAR lngth : integer );
BEGIN
  WHILE nextchar.name = quote DO
    BEGIN
      Storenextchar (lngth, currchar, nextchar, valu);
      WHILE NOT (nextchar.name IN [quote, endofline, filemark]) DO
        Storenextchar (lngth, currchar, nextchar, valu);
      IF nextchar.name = quote
        THEN Storenextchar (lngth, currchar, nextchar, valu)
    END;
  name := othersym
END (*getcharliteral*);


FUNCTION Chartype (currchar, nextchar: charinfo): keysymbol;

VAR  nexttwochars: specialchar;
     hit:  boolean;
     thischar:  keysymbol;
     
BEGIN
  nexttwochars[1] := currchar.valu;
  nexttwochars[2] := nextchar.valu;
  thischar := becomes;
  hit := false;
  
  (* Find out if chartype is ":=" or "(*" *)
  WHILE NOT (hit or (thischar = closecomment)) DO
    IF nexttwochars = dblchar [thischar]
      THEN hit := true
      ELSE thischar := succ(thischar);
  
  (* now is chartype ;, :, (, ), {, }, or .  *)
  IF NOT hit
    THEN BEGIN
      thischar := semicolon;
      WHILE NOT (hit OR (pred(thischar) = period)) DO
        IF currchar.valu = sglchar[thischar]
          THEN hit := true
          ELSE thischar := succ(thischar)
    END;
  IF hit
    THEN chartype := thischar
    ELSE chartype := othersym
END (*Chartype*);



PROCEDURE Getspecialchar ( (* from input *)
                (* updating *) VAR currchar, nextchar: charinfo;
                (* returning*) VAR name   : keysymbol;
                               VAR valu   : lstring;
                               VAR lngth : integer );
BEGIN
  Storenextchar (lngth, currchar, nextchar, valu);
  name := Chartype (currchar, nextchar);
  IF name IN dblchars
    THEN Storenextchar (lngth, currchar, nextchar, valu);
END (* Getspecialchar *);


PROCEDURE Getnextsymbol ( (* from input *)
                (* updating *) VAR currchar, nextchar: charinfo;
                (* returning*) VAR name   : keysymbol;
                               VAR valu   : lstring;
                               VAR lngth : integer );
BEGIN
  CASE nextchar.name OF
    letter   : Getidentifier (currchar, nextchar, name, valu, lngth);
    digit    : Getnumber     (currchar, nextchar, name, valu, lngth);
    quote    : Getcharliteral(currchar, nextchar, name, valu, lngth);
    otherchar: BEGIN
                 Getspecialchar (currchar, nextchar, name, valu, lngth);
                 IF (name = opencomment) OR (name = openbracket)
                   THEN Getcomment (currchar, nextchar, name, valu, lngth)
               END;
    filemark : name := endoffile
  END (* case *)
END (* Getnextsymbol *);


PROCEDURE Getsymbol ( (*from input*)
        (* updating *) VAR nextsym: symbolinfo;
        (* returning*) VAR currsym: symbolinfo);
VAR  dummy: symbolinfo;
BEGIN
  dummy := currsym;
  currsym := nextsym;
  nextsym := dummy;
  WITH nextsym^ DO
    BEGIN
      skipspaces (currchar, nextchar, spacesbefore, crsbefore);
      lngth := 0;
      IF currsym^.name = opencomment
        THEN Getcomment    (currchar, nextchar, name, valu, lngth)
        ELSE Getnextsymbol (currchar, nextchar, name, valu, lngth)
    END
END (* Getsymbol *);


PROCEDURE Initfiles;
BEGIN
  WRITELN ('Welcome to the Pascal prettyprinter.  Please type the name of');
  WRITE ('the textfile you wish as input --> ');
  READLN (infilename);
  RESET (infile, infilename);
  WRITELN('Now the filename to which you want the output sent.');
  WRITELN ('  (NOTE:  if you simply want to print it out,');
  WRITE ('  type "PRINTER:")                                 -->');
  READLN (outfilename);
  REWRITE (outfile, outfilename);
  Getchar (nextchar, currchar);
  new (currsym);
  new (nextsym);
  Getsymbol (nextsym, currsym)
END (*Initfiles*);

  
FUNCTION Stackempty: boolean;
BEGIN
  IF top = 0
    THEN stackempty := true
    ELSE stackempty := false
END;


FUNCTION Stackfull: boolean;
BEGIN
  IF top = maxstacksize
    THEN stackfull  := true
    ELSE stackfull  := false
END;


PROCEDURE Popstack ( (*returning*) VAR indentsymbol: keysymbol;
                                   VAR prevmargin  : integer);
BEGIN
  IF NOT stackempty
    THEN BEGIN
      indentsymbol := stack[top].indentsymbol;
      prevmargin   := stack[top].prevmargin;
      top := top-1
    END ELSE BEGIN
      indentsymbol := othersym;
      prevmargin   := 0
    END
END (*Popstack*);


PROCEDURE Pushstack (indentsymbol: keysymbol; prevmargin: integer);
BEGIN
  top := top+1;
  stack[top].indentsymbol := indentsymbol;
  stack[top].prevmargin := prevmargin
END;


PROCEDURE Writecrs (numberofcrs: integer; VAR currlinepos: integer);
VAR i: integer;
BEGIN
  IF numberofcrs > 0
    THEN BEGIN
      FOR I := 1 TO numberofcrs DO WRITELN (outfile);
      currlinepos := 0
    END
END;


PROCEDURE Insertcr (VAR currsym: symbolinfo);
CONST  once = 1;
BEGIN
  IF currsym^.crsbefore = 0
    THEN BEGIN
      writecrs (once, currlinepos);
      currsym^.spacesbefore := 0
    END
END;


PROCEDURE Insertblankline (VAR currsym: symbolinfo);
CONST once = 1; twice = 2;
BEGIN
  IF currsym^.crsbefore = 0
    THEN
      BEGIN
        IF currlinepos = 0
          THEN Writecrs (once, currlinepos)
          ELSE Writecrs (twice, currlinepos);
        currsym^.spacesbefore := 0
      END
    ELSE IF currsym^.crsbefore = 1
      THEN IF currlinepos > 0 THEN Writecrs (once, currlinepos)
END (*Insertblankline*);


PROCEDURE Lshifton (dindentsymbols: keysymset);
VAR  indentsymbol: keysymbol;
     prevmargin  : integer;
BEGIN
  IF NOT stackempty
    THEN
      BEGIN
        REPEAT
          popstack (indentsymbol, prevmargin);
          IF indentsymbol IN dindentsymbols THEN currmargin := prevmargin
        UNTIL NOT (indentsymbol IN dindentsymbols) OR stackempty;
        IF NOT (indentsymbol IN dindentsymbols)
          THEN Pushstack (indentsymbol, prevmargin)
      END
END (*Lshifton*);


PROCEDURE Lshift;
VAR  indentsymbol: keysymbol; prevmargin: integer;
BEGIN
  IF NOT stackempty
    THEN BEGIN
      Popstack (indentsymbol, prevmargin);
      currmargin := prevmargin
    END
END;


PROCEDURE Insertspace (VAR symbol: symbolinfo);
BEGIN
  IF currlinepos < maxlinesize
    THEN BEGIN
      WRITE (outfile, space);
      currlinepos := succ (currlinepos);
      WITH symbol^ DO IF (crsbefore = 0) AND (spacesbefore > 0)
        THEN spacesbefore := pred (spacesbefore)
    END
END (*Insertspace*);


PROCEDURE Movelinepos ( (*to*) newlinepos: integer;
                (*from*)  VAR currlinepos: integer);
VAR  i: integer;
BEGIN
  FOR i := currlinepos+1 TO newlinepos DO
    WRITE (outfile, space);
  currlinepos := newlinepos
END;


PROCEDURE Printsymbol (currsym: symbolinfo; VAR currlinepos: integer);
VAR i: integer;
BEGIN
  WITH currsym^ DO
  BEGIN
    FOR i := 1 TO lngth DO write (outfile, valu[i]);
    startpos := currlinepos;
    currlinepos := currlinepos + lngth
  END
END (*Printsymbol*);


PROCEDURE Ppsymbol (currsym: symbolinfo);
CONST once = 1;
VAR newlinepos: integer;
BEGIN
  WITH currsym^ DO
    BEGIN
      Writecrs (crsbefore, currlinepos);
      IF (currlinepos + spacesbefore > currmargin)
        OR (name IN [opencomment, closecomment, openbracket, closebracket])
        THEN newlinepos := currlinepos + spacesbefore
        ELSE newlinepos := currmargin;
      IF newlinepos + lngth > maxlinesize
        THEN BEGIN
          Writecrs (once, currlinepos);
          IF currmargin + lngth <= maxlinesize
            THEN newlinepos := currmargin
            ELSE IF lngth < maxlinesize
              THEN newlinepos := maxlinesize - lngth
              ELSE newlinepos := 0
        END;
      Movelinepos (newlinepos, currlinepos);
      Printsymbol (currsym, currlinepos)
    END (*with*)
END (*Ppsymbol*);

PROCEDURE Rshifttoclp (currsym:keysymbol);
  FORWARD;
  
  
PROCEDURE Gobble ( (*up to*) terminators: keysymset;
                   (*updating*) VAR currsym, nextsym: symbolinfo);
BEGIN
  Rshifttoclp (currsym^.name);
  WHILE NOT (nextsym^.name IN (terminators + [endoffile])) DO
    BEGIN
      Getsymbol (nextsym, currsym);
      Ppsymbol (currsym)
    END;
  Lshift
END (*Gobble*);


PROCEDURE Rshift (currsym: keysymbol);
BEGIN
  IF NOT stackfull THEN Pushstack (currsym, currmargin);
  
  (* If extra indentation was used,  update margin.*)
  IF startpos > currmargin THEN currmargin := startpos;
  IF currmargin < slofail1
    THEN currmargin := currmargin + indent1
    ELSE IF currmargin < slofail2 THEN currmargin := currmargin + indent2
END (*Rshift*);


PROCEDURE Rshifttoclp;
BEGIN
  IF NOT stackfull THEN Pushstack (currsym, currmargin);
  currmargin := currlinepos
END (*Rshifttoclp*);


BEGIN (* main program, at last *);
  Initvar1 (top, currlinepos, currmargin, keyword, dblchars, dblchar,
            sglchar, recordseen, currchar, nextchar, currsym, nextsym);
  Initvar2 (ppoption);
  Initvar3 (ppoption);
  Initfiles;
  crpending := false;
  WHILE (nextsym^.name <> endoffile) DO
    BEGIN
      Getsymbol (nextsym, currsym);
      WITH ppoption [currsym^.name] DO
        BEGIN
          IF (crpending AND NOT (crsuppress IN optionsselected))
            OR (crbefore IN optionsselected)
            THEN BEGIN
              Insertcr (currsym);
              crpending := false
            END;
          IF blankliebefore IN optionsselected THEN
            BEGIN
              Insertblankline (currsym);
              crpending := false
            END;
          IF dindentonkeys IN optionsselected
            THEN Lshifton (dindentsymbols);
          IF dindent IN optionsselected THEN Lshift;
          IF spacebefore IN optionsselected THEN Insertspace (currsym);
          Ppsymbol (currsym);
          IF spaceafter IN optionsselected THEN Insertspace (nextsym);
          IF indentbytab IN optionsselected THEN Rshift (currsym^.name);
          IF indenttoclp IN optionsselected THEN Rshifttoclp (currsym^.name);
          IF gobblesymbols IN optionsselected
            THEN Gobble (gobbleterminators, currsym, nextsym);
          IF crafter IN optionsselected THEN crpending := true
        END (*with*)
    END (*while*);
  IF crpending THEN WRITELN (outfile);
  CLOSE (outfile,lock)
END.
          
        
  

========================================================================================
DOCUMENT :usus Folder:VOL01:readcpm.text
========================================================================================

        .PROC   READCPM,1
        .PUBLIC DISKBUF
        .ORG    0
        POP     HL      ; EXTENT PASSED AS PARAMETER
        EX      (SP),HL ;   UNDER RETURN ADDRESS
        LD      BC,DISKBUF
        ADD     HL,HL
        ADD     HL,HL
        ADD     HL,HL
FETCH   PUSH    HL
        PUSH    BC
        LD      B,1
        LD      DE,0-26
DIVL    ADD     HL,DE
        INC     B
        LD      A,H
        OR      A
        JP      P,DIVL
        LD      DE,TABLE+26
        ADD     HL,DE
        LD      C,(HL)
        LD      L,21H   ; OFFSET OF SETSEC
        CALL    BIOS
        LD      C,B
        LD      L,1EH   ; OFFSET OF SETTRK
        CALL    BIOS
        POP     BC
        LD      L,24H   ; OFFSET OF SETDMA
        CALL    BIOS
        LD      HL,128
        ADD     HL,BC
        PUSH    HL
        LD      L,27H   ; OFFSET OF READ
        CALL    BIOS
        POP     BC
        POP     HL
        INC     HL
        LD      A,7
(AND     L
        JR      NZ,FETCH
        RET
BIOS    LD      A,(2)
        LD      H,A
        JP      (HL)
TABLE   .BYTE   01H,07H,0DH,13H,19H,05H
        .BYTE   0BH,11H,17H,03H,09H,0FH,15H
        .BYTE   02H,08H,0EH,14H,1AH,06H,0CH
        .BYTE   12H,18H,04H,0AH,10H,16H
        .END


========================================================================================
DOCUMENT :usus Folder:VOL01:rwcpm.text
========================================================================================

        .PROC   RWCPM,2
        .PUBLIC DISKBUF
; CPM EXTENT DISKIO-COPYRIGHT 1979 BY BARRY A. COLE
; PASCAL CALLS RWCPM(EXTENT,FLAG)
;   FLAG=0 FOR READ, FLAG=3 FOR WRITE
;   DATA IS PASSED VIA SHARED BUFFER 'DISKBUF'
        LD      C,1
        LD      L,1BH   ;OFFSET OF SELDSK
        CALL    BIOS
        POP     DE      ;RETURN ADDRESS
        POP     AF      ;READ=0/WRITE=3 FLAG
        ADD     A,27H   ; OFFSET OF READ
        EX      AF      ;SAVE FOR FUTURE REFERENCE
        POP     HL      ; EXTENT PASSED AS PARAMETER
        PUSH    DE      ;PUT BACK RETURN ADDRESS
        LD      BC,DISKBUF
        ADD     HL,HL
        ADD     HL,HL
        ADD     HL,HL
FETCH   PUSH    HL
        PUSH    BC
        LD      B,1
        LD      DE,0-26
DIVL    ADD     HL,DE
        INC     B
        LD      A,H
        OR      A
        JP      P,DIVL
        LD      DE,TABLE+26
        ADD     HL,DE
        LD      C,(HL)
        LD      L,21H   ; OFFSET OF SETSEC
        CALL    BIOS
        LD      C,B
        LD      L,1EH   ; OFFSET OF SETTRK
        CALL    BIOS
        POP     BC
        LD      L,24H   ; OFFSET OF SETDMA
        CALL    BIOS
        LD      HL,128
        ADD     HL,BC
        PUSH    HL
        EX      AF
        LD      L,A     ; OFFSET OF READ OR WRITE
        EX      AF
        CALL    BIOS
        POP     BC
        POP     HL
        INC     HL
        LD      A,7
        AND     L
        JR      NZ,FETCH
        LD      C,0
        LD      L,1BH   ;OFFSET OF SELDSK, AND EXIT
BIOS    LD      A,(2)
        LD      H,A
        JP      (HL)
TABLE   .BYTE   01H,07H,0DH,13H,19H,05H
        .BYTE   0BH,11H,17H,03H,09H,0FH,15H
        .BYTE   02H,08H,0EH,14H,1AH,06H,0CH
        .BYTE   12H,18H,04H,0AH,10H,16H
        .END


========================================================================================
DOCUMENT :usus Folder:VOL01:simp.text
========================================================================================

                {SIMP - Simplified Integrated Modular Prose}
               {PASCAL version by S. J. Singer   10 Feb 1979}

        {This program is a further refined version of the superb}
        {program developed by T. R. Stokes (in BASIC).  The original}
        {information from which these programs were developed was}
        {published in Scientific American, December 1974, p 134}


PROGRAM SIMP;

VAR     CHARACTERS: INTEGER;                    {CHAR PER LINE}
        PARAGRAPHS: INTEGER;                    {PARAGRAPHS PER MEMO}
        RNUM: REAL;
    {USED IN RANDOM NO GENERATOR}
        LINES: 0..10;
        P: INTEGER;
        I,J: INTEGER;
        K: 0..3;
        LST,FIRST: BOOLEAN;
        CH: CHAR;
        CRLF: PACKED ARRAY[0..2] OF CHAR;
        A,B,C,D,F: ARRAY[0..10] OF STRING[90];  {PHRASE TABLES}
        TABLE: ARRAY[0..3,0..10] OF BOOLEAN;    {PHRASE USAGE FLAGS}
        TOO: STRING;
        FROM: STRING;
        SUBJECT: STRING;
        BUFFER: STRING;
        TXT: STRING[255];
        List: TEXT;


PROCEDURE CLEARTABL;                    {RESET PHRASE USAGE TABLE}

VAR     I,J: INTEGER;
BEGIN
   FOR I:=0 TO 3 DO
      FOR J:=0 TO 10 DO
         TABLE[I,J] := TRUE
END;


FUNCTION RND(LO,HI:INTEGER): INTEGER;          {RANDOM NUMBER GENERATOR}

VAR  Q       : REAL;
     I       : INTEGER;
BEGIN
   REPEAT
      RNUM := RNUM*21.182813+31.415917;
      RNUM := RNUM-TRUNC(RNUM);
      I := TRUNC(RNUM*(HI+1));
   UNTIL I>=LO;
   RND := I;
END;


FUNCTION RN(LO,HI,TBLINDX:INTEGER): INTEGER;
{USE PHRASE ONLY ONCE/PARAGRAPH}

VAR     R: INTEGER;
BEGIN
   REPEAT
      R := RND(LO,HI)
   UNTIL TABLE[TBLINDX,R];
   TABLE[TBLINDX,R] := FALSE;
   RN := R
END;


PROCEDURE INIT1;                {INITIALIZE PHRASE TABLE}
BEGIN
    {SIMP TABLE A}
   A[0] := 'in respect to specific goals,';
   A[1] := 'in particular,';
   A[2] := 'on the other hand,';
   A[3] := 'however,';
   A[4] := 'similarly,';
   A[5] := 'as a resultant implication,';
   A[6] := 'in this regard,';
   A[7] := 'based on integral subsystem considerations,';
   A[8] := 'for example,';
   A[9] := 'thus,';
   A[10] := 'let it be noted that,';
    {SIMP TABLE B}
   B[0] := 

'a primary interrelationship between system and/or subsystem technologies'
   ;
   B[1] := 'a large portion of the interface coordination communication'
   ;
   B[2] := 'a constant flow of effective information';
   B[3] := 'the characterization of specific criteria';
   B[4] := 'initiation of critical subsystem developement';
   B[5] := 'the fully integrated test program';
   B[6] := 'the product configuration baseline';
   B[7] := 'any associated supporting element';
   B[8] := 'the incorporation of additional mission restraints';
   B[9] := 'the independent function principle';
END;    {INIT1}

PROCEDURE INIT2;                {INITIALIZE PHRASE TABLE}
BEGIN
    {SIMP TABLE C}
   C[0] := 'adds overriding performance constraints to';
   C[1] := 'must utilize and be functionallly interwoven with';
   C[2] := CONCAT(
           'maximizes the probability of project success and minimizes',
               ' the cost and time required for');
   C[3] := 'adds specific performance limits to';
   C[4] := 'necessitates that urgent consideration be applied to';
   C[5] := 

'requires considerable systems analysis and trade off studies to arrive at'
   ;
   C[6] := 'is further compounded, when taking into account';
   C[7] := 'presents extremely interesting challenges to';
   C[8] := 
      'recognizes the importance of other systems and the necessity for'
   ;
   C[9] := 'effects a significant implementation of';
END;        {INIT2}


PROCEDURE INIT3;                {INITIALIZE PHRASE TABLE}
BEGIN
    {SIMP TABLE D}
   D[0] := 'the total system rational';
   D[1] := 'the sophisticated hardware';
   D[2] := 'the anticipated fourth generation equipment';
   D[3] := 'the subsystem compatibility testing';
   D[4] := 'the structural design based on system engineering concepts';
   D[5] := 'the preliminary qualification limit';
   D[6] := 'the evolution of specifications over a given period of time'
   ;
   D[7] := 'the philosophy of commonality and standardization';
   D[8] := 'the greater flight-worthiness concept';
   D[9] := 'any discrete configuration mode';
    {SIMP TABLE F}
   F[0] := 'It has come to my attention that ';
   F[1] := 'I wish to point out that ';
   F[2] := 'It is my conclusion that ';
   F[3] := 'As part of my duty, I must assure you that ';
   F[4] := 
   'As a cognizant support representative, I would like to report that '
   ;
   F[5] := 'I feel it is imperative I inform you that ';
   F[6] := 
     'Due to or in spite of the present status, I must advise you that '
   ;
   F[7] := CONCAT('In order to assess future impact/upgrade ratios,',
               ' I feel you should consider that ');
   F[8] := 'Acting in my advisory capacity, I wish to notify you that ';
   F[9] := 'From an international standpoint, it is clear to me that ';
END;    {INIT3}


PROCEDURE PARAMETERS;           {INPUT REPORT PARAMETERS}
BEGIN
   PAGE (OUTPUT);
   REWRITE (list, 'PRINTER:');
   RNUM := 12.345;
   CRLF[0] := CHR(13);
   CRLF[1] := CHR(10);
   CRLF[2] := CHR(10);
   TXT := '     ';
   WRITELN;
   WRITELN;
   WRITE('SIMPLIFIED INTEGRATED MODULAR PROSE GENERATOR':60);
   WRITELN;
   WRITELN;
   WRITELN;
   WRITE('TO: ');
   READLN(TOO);
   WRITE('FROM: ');
   READLN(FROM);
   WRITE('SUBJECT: ');
   READLN(SUBJECT);
   WRITELN;
   WRITE('CHARACTERS PER LINE ');
   READLN(CHARACTERS);
   WRITE('PARAGRAPHS ');
   READLN(PARAGRAPHS);
   WRITE('PRINTED OUTPUT (Y/N) ');
   READ(CH);
   IF (CH<>'Y') AND (CH<>'y')
      THEN
         LST := FALSE
      ELSE
         LST := TRUE;
   WRITELN;
   WRITELN;
   WRITE('ENTER A 4 DIGIT RANDOM NUMBER ');
   READLN(RNUM)
END;            {PARAMETERS}

                {THERE ARE 4 POSSIBLE PERMUTATIONS OF THE 4 PHRASES}

PROCEDURE PERM0;                {TEXT PERMUTATION 0}
BEGIN
   BUFFER := A[RN(0,10,0)];
   BUFFER[1] := CHR(ORD(BUFFER[1])-32);
   TXT := CONCAT(TXT,BUFFER,' ',B[RN(0,9,1)],' ',
          C[RN(0,9,2)],' ',D[RN(0,9,3)],'.')
END;    {PERM0}


PROCEDURE PERM1;                {TEXT PERMUTATION 1}
BEGIN
   BUFFER := D[RN(0,9,3)];
   BUFFER[1] := CHR(ORD(BUFFER[1])-32);
   TXT := CONCAT(TXT,BUFFER,' ',A[RN(0,10,0)],' ',
          C[RN(0,9,2)],' ',B[RN(0,9,1)],'.')
END;    {PERM1}


PROCEDURE PERM2;                {TEXT PERMUTATION 2}
BEGIN
   BUFFER := B[RN(0,9,1)];
   BUFFER[1] := CHR(ORD(BUFFER[1])-32);
   TXT := CONCAT(TXT,BUFFER,' ',A[RN(0,10,0)],' ',
          C[RN(0,9,2)],' ',D[RN(0,9,3)],'.')
END;    {PERM2}


PROCEDURE PERM3;                {TEXT PERMUTATION 3}
BEGIN
   BUFFER := A[RN(0,10,0)];
   BUFFER[1] := CHR(ORD(BUFFER[1])-32);
   TXT := CONCAT(TXT,BUFFER,' ',D[RN(0,9,3)],' ',
          C[RN(0,9,2)],' ',B[RN(0,9,1)],'.')
END;    {PERM3}


PROCEDURE HEADING;      {DISPLAY AND PRINT MEMORANDUM HEADING}
BEGIN
   WRITELN ('M E M O R A N D U M':40);
   IF LST
      THEN
         BEGIN
            WRITELN (List, '             M E M O R A N D U M');
            WRITELN (List);
            WRITELN (List);
            WRITELN (List, 'TO: ', too);
            WRITELN (List, 'FROM: ', from);
            WRITELN (List);
            WRITELN (List, 'COPIES TO: ALL SUBORDINATES');
            WRITELN (List, 'SUBJECT: ', subject);
            WRITELN (List);
            WRITELN (List);
         END
END;    {HEADING}


PROCEDURE INITIALIZE;
BEGIN
   INIT1;
   INIT2;
   INIT3;
   PARAMETERS
END;    {INITIALIZE}


BEGIN                   {MAIN PROGRAM}
   INITIALIZE;
   FIRST := TRUE;
   HEADING;
   FOR P:=PARAGRAPH DOWNTO 1 DO
      BEGIN
         CLEARTABL;
         LINES := RND(3,9);     {GENERATE 3 TO 9 LINES}
         J := 1;
         WHILE LINES > 0 DO
            BEGIN
               I := 0;
               K := RND(0,3);      {PERMUTATION SELECTOR}
               IF FIRST
                  THEN
                     BEGIN
                        TXT := CONCAT(TXT,F[RND(0,9)],B[RN(0,9,1)],' ',
                               C[RN(0,9,2)],' ',D[RN(0,9,3)],'.');
                        FIRST := FALSE
                     END;
               CASE K OF
                  0: PERM0;
                  1: PERM1;
                  2: PERM2;
                  3: PERM3;
               END;
               REPEAT
                  I := I + 1;
                  J := J + 1;
                  WRITE (TXT[I]);
                  IF LST THEN WRITE (List, txt [i]);
                  IF ((J >= CHARACTERS) AND (TXT[I]=' '))
                     THEN
                        BEGIN
                           J := 1;
                           IF LST THEN WRITELN (List);
                           WRITELN
                        END
               UNTIL TXT[I='.';
               LINES := LINES-1;
               TXT := ' '
            END;
         WRITELN;
         IF lst THEN WRITELN (List);
         TXT := '     '
      END
END.                    {MAIN PROGRAM}

========================================================================================
DOCUMENT :usus Folder:VOL01:typeset.text
========================================================================================


PROGRAM TYPESET;

CONST MAXCHAR = 80;             {MAXIMUM NUMBER OF CHARACTERS PER LINE}
          ESC = 27;             {ESCAPE CHARACTER}

TYPE  LINEPOS = 1..MAXCHAR;

VAR     I,J : INTEGER;
   COLWIDTH : INTEGER;
       W,JW : TEXT;
        C,D : CHAR;
       LINE : ARRAY[1..MAXCHAR] OF CHAR;        {UNJUSTIFIED}
      DLINE : ARRAY[1..MAXCHAR] OF CHAR;        {JUSTIFIED FOR DISPLAY}
       FILL : INTEGER;                          {MAX % FILL ALLOWED}
     INFILE : STRING[15];
    OUTFILE : STRING[15];
        NSP : INTEGER;          {NUMBER OF SPACES IN CURRENT LINE}
          P : BOOLEAN;          {PARAGRAPH FLAG}
      PITCH : 5..6;
    SPACING : INTEGER;
  JUST,STOP : BOOLEAN;
      SPCNT : INTEGER;
      NEEDSP: INTEGER;
      ADDSP : INTEGER;
      EXTSP : INTEGER;

PROCEDURE CLEARSCREEN;
BEGIN
  WRITE(CHR(26),CHR(0),CHR(0),CHR(0),CHR(0),CHR(0),CHR(0))
END;

PROCEDURE OPTIONS;
VAR C:CHAR;
BEGIN
  CLEARSCREEN;
  WRITELN('DARLENE''S SUPER TYPESETTING PROGRAM':52);
  GOTOXY(10,6);
  WRITE('INPUT FILE NAME   ');
  READLN(INFILE);
  IF LENGTH(INFILE)=0 THEN INFILE:='SYSTEM.WRK';
  INFILE:=CONCAT(INFILE,'.TEXT');
  GOTOXY(10,7);
  WRITE('OUTPUT FILE NAME  ');
  READLN(OUTFILE);
  GOTOXY(10,9);
  WRITE('ENTER COLUMN WIDTH ');
  READ(COLWIDTH);
  SPACING:=1;
  PITCH:=6;
  GOTOXY(10,12);
  WRITELN('THE CURRENT PROGRAM OPTIONS ARE:');
  WRITELN('TYPE PITCH     - 5 (ELITE)':40);
  WRITELN('MAXIMUM PERCENT FILL - 80%':40);
  WRITELN('SINGLE SPACE TEXT':30);
  WRITELN;WRITELN;WRITE('WOULD YOU LIKE TO CHANGE THEM (Y/N) ':46);
  RESET(INPUT);
  FILL:=80;
  PITCH:=6;
  READ(C);
  IF C='Y' THEN
    BEGIN
      CLEARSCREEN;
      WRITELN;WRITELN;
      WRITE('PICA OR ELITE  (P/E) ':35);
      {EAD(C);
      IF C='P' THEN PITCH:=6 ELSE PITCH:=5;
      WRITELN;
      WRITE('MAXIMUM FILL PERCENT ':35);
      READLN(FILL)
    END
END;


PROCEDURE BLANKSCAN(LINELENGTH:LINEPOS);
VAR I,J : INTEGER;
      B : BOOLEAN;
BEGIN
  B:=FALSE;
  NSP:=0;
  FOR I:=1 TO LINELENGTH DO
    BEGIN
      IF ((LINE[I]=' ') AND B) THEN NSP:=NSP+1;
      IF LINE[I]<>' ' THEN B:=TRUE
    END;
  IF NSP>0 THEN
    BEGIN
      JUST:=TRUE;
      NEEDSP:=(COLWIDTH-LINELENGTH)*PITCH;
      ADDSP:=NEEDSP DIV NSP;
      EXTSP:=NEEDSP-ADDSP*NSP;
    END ELSE JUST:=FALSE
END;

PROCEDURE VARLINE(LINELENGTH:LINEPOS);
VAR K,L : INTEGER;
      B : BOOLEAN;
      C : CHAR;
    ESP : INTEGER;
BEGIN
  SPCNT:=0;
  ESP:=NSP DIV 2;
  B:=FALSE;
  K:=1;L:=1;
  REPEAT
    C:=LINE[L];
    IF ((C=' ') AND B AND JUST) THEN
      BEGIN
        WRITE(JW,CHR(ESC));
        K:=K+1;
        SPCNT:=SPCNT+1;
        IF SPCNT=ESP THEN WRITE(JW,CHR(32+PITCH+ADDSP+EXTSP))
          ELSE WRITE(JW,CHR(32+PITCH+ADDSP));
      END ELSE WRITE(JW,C);
    IF C<>' ' THEN B:=TRUE;
    K:=K+1;
    L:=L+1
  UNTIL L>LINELENGTH;
  WRITELN(JW)
END;
  
  
PROCEDURE FILLINE(LINELENGTH:LINEPOS);
VAR K,L,SP,NSPL:INTEGER;
             B:BOOLEAN;
BEGIN
  IF (LINELENGTH*100 DIV COLWIDTH) < FILL THEN JUST:=FALSE
    ELSE JUST:=TRUE;
      SP:=COLWIDTH-LINELENGTH;
      NSPL:=SP-NSP;
      B:=FALSE;
      K:=1;L:=1;
      REPEAT
        DLINE[K]:=LINE[L];
        IF ((DLINE[K]=' ') AND (SP<>0) AND B AND JUST) THEN
          BEGIN
            K:=K+1;
            SP:=SP-1;
            DLINE[K]:=' ';
            IF NSPL>0 THEN
              BEGIN
                K:=K+1;
                SP:=SP-1;
                NSPL:=NSPL-1;
                DLINE[K]:=' '
              END
          END;
        IF DLINE[K]<>' ' THEN B:=TRUE;
        K:=K+1;
        L:=L+1
      UNTIL L>LINELENGTH;
      IF K<=COLWIDTH THEN FOR K:=K TO COLWIDTH DO DLINE[K]:=' '
END;
  
  
  
BEGIN           {-MAIN PROGRAM-}
  OPTIONS;
  FOR I:=1 TO MAXCHAR DO
    BEGIN
      LINE[I]:=' ';
      DLINE[I]:=' '
    END;
  STOP:=FALSE;
  I:=1;
  CLEARSCREEN;
  RESET(W,INFILE);
  REWRITE(JW,OUTFILE);
  WRITELN;
  WHILE NOT EOF(W) DO
    BEGIN
      READ(W,C);
      IF EOLN(W) THEN
        BEGIN
          LINE[I]:=C;
          BLANKSCAN(I);
          FILLINE(I);
          VARLINE(I);
          GET(W);
          D:=W^;
          IF NOT STOP THEN FOR J:=1 TO COLWIDTH DO WRITE(DLINE[J]) ELSE
            BEGIN
              J:=1;
              WHILE DLINE[J]<>' ' DO
                BEGIN
                  WRITE(DLINE[J]);
                  J:=J+1
                END;
              WRITELN('    <<<= HYPHENATE PLEASE.');
              EXIT(PROGRAM)
            END;
          IF ((NOT JUST) AND (D<>' ')) THEN STOP:=TRUE;
          IF EOLN(W) THEN
            BEGIN
              GET(W);
              WRITELN;
              WRITELN(JW)
            END;
          I:=1;
          WRITELN
        END ELSE
          BEGIN
            LINE[I]:=C;
            I:=I+1
          END
  END;
  CLOSE(JW,LOCK)
END.
  

========================================================================================
DOCUMENT :usus Folder:VOL01:units.doc.text
========================================================================================


     
                SOME DOCUMENTATION ABOUT UCSD SEGMENTS AND UNITS

     Since the release of version 1.5 in early 1979, UCSD Pascal has supported 
several very useful extensions to Standard Pascal (a la Jensen and Wirth) that 
assist modular compilation and/or execution of programs.  These are:

     1. Programs may declare procedures or functions EXTERNAL in the same way
they may be declared FORWARD (ie, a full 1st procedure/function declaration
line is required).  The program may not be run until it has been L(inked; the
linker usually expects to find the missing code in the SYSTEM.LIBRARY.  
EXTERNAL procedures are reserved for assembly language procedures; the entire
process is well documented in the UCSD handout.  

     One item that is not completely clear is the way parameters are passed.
The called routine will find the following items on the stack, in descending
(normal "POP xx" order): 1) the return address (this must be saved); 2) IF
the called routine is a function, two words of zeros, which reserve space for
the result of the function (these two words are skipped if the routine is a
procedure); 3) the parameters being passed to the routine, in reverse order
(ie, the last declared parameter is popped off first).

     2. You can construct a separate UNIT, which contains text that performs
some involved but functionally distinct process within your program.  This is
then compiled separately, and the calling program merely states "USES
<unitname A>, <unitname B>,...,<unitname N>;" at the second line of the
program (right after the main program declaration).  Normally, you should
incorporate the code from the correctly compiled UNIT into the SYSTEM.LIBRARY,
where it is available to the linker.  The documentation is not clear about how
common variables are actually declared: any constant, type, variable,
procedure, or function declared in the INTERFACE portion of the unit is read
first thing at the time of compilation of the main program, and these
declarations are copied verbatim into the text of the main program by the
compiler.  This means that you should NOT declare the same constants, types,
etc., within the main program, even if you use them -- you will get an error,
since they are already there.  (If this is not clear, try setting up a UNIT
and a main program that uses it, then examine a listing of the main program
after compilation.)

     I have used the UNIT approach with great success for a complicated text 
processing program, for two functions:  1) the program begins with a detailed 
menu that reads in user requests for margins, page length, etc.  Not only is 
this code quite long, it stands by itself (simply passing initialized 
variables to the main program) and was best debugged by itself.  2) I added an 
automatic hyphenation routine, which also was quite long and needed to be 
debugged separately.

     3. Finally, it is possible (but within the main program ONLY) to declare 
certain procedures or functions SEGMENT procedures/functions.  The compilation 
process is not changed, but when the program is actually run, the declared 
procedures are drawn into memory only when required, and are overwritten by
data or code at other times.  This approach is essential if you have a
complicated program that uses a lot of memory and has one or more long
procedures (most commonly an initialization routine) you expect to use rarely,
before the memory fills up.  Unlike some other Pascal implementations, all 
other code (not explicitly declared a SEGMENT procedure/function) is always 
memory resident while the program is running.  

     Further, there is no clean way for one program to load another and then
pass execution to it.  (You have to have some way of fudging the console
input buffer in the BIOS, then quit the execution of the present program,
then trick the operating system with your phony console input.) However, I'll
bet that someone familiar with the operating system could cook up a way of
feeding data directly to the program execution section; it would require
compiling your routine (usually simply a menu) at the 0th lex level with the
(*$U-*) compiler command.  The reason this may be important is that many
business programs use multiple separate procedures driven by a menu, and the
Pascal system at present limits you to 6 procedure segments.

     It is absolutely not mentioned anywhere, but although external UNITS are 
given new segment numbers by the compiler, they are ALWAYS resident in memory 
at run time.  If you want to have the code in a unit work as a SEGMENT 
PROCEDURE or FUNCTION, you MUST include the source within the main file and 
declare it a SEGMENT PROCEDURE or FUNCTION.


     
     

========================================================================================
DOCUMENT :usus Folder:VOL01:volume1.text
========================================================================================


                             A GUIDE TO THIS VOLUME

     First, a list of the documentation files on the disk and to which 
programs they refer:

     CPM.DOC.TEXT.  Miscellaneous comments on the operation of the 8080/Z-80
interpreter.  Also contains the documentation for DISKREAD, GETCPM and
GETCPM2, RWCPM, READCPM, and INOUTREADY.  (Note that a UCSD-to-CP/M file
copier will be included on a subsequent disk; these all go the other way.)

     PRETTY.DOC.  This discusses PRETTY (including INITVAR) and FORMAT
(including FORMAT1 and FORMAT2).

     FORMAT.DOC.  More extensive user instructions for FORMAT thru FORMAT2.

     GOTCHA.DOC.  Stand-alone comments on the hidden hardware requirements for 
Z-80 and 8080 users.

     UNITS.DOC.  More stand-alone comments, this time distinguishing UNITS,
EXTERNAL procedures/functions, and SEGMENT procedures/functions.

     INTRODUCTN.  This file is a copy of the paper in the Proceedings of the 
Fourth West Coast Computer Faire, and represents the initial goals of this 
library of software and other comments.  I have since been in touch with 
SofTec; the present status of the Users' Group Library should be documented 
separately. 


     
     Next, let's look at the other files:

     COMBINE.  This is a very early attempt by me.  Problems include less than 
perfect file-getting (see CRT.I.O for a superior version) and the slowest 
procedure in UCSD Pascal:  reading and writing lines of text.

     
     CRT.I.O.  I like this set of routines a great deal, and I hope you find
them useful.  They are designed to assist you in obtaining data from a naive
user in an interactive environment in a way that is "chimpanzee proof": no
matter what you type (within limits), you can't crash the program or mar the
display.  All but GETFILE are designed to enter data directly into a menu on
the CRT, and require the X-Y locations of the data requested.  Except GETFILE,
all routines can be exited by typing <escape>, leaving the original data
undisturbed.  Further, the integer routine does automatic range checking and
won't let the user out until the data is correct or the user types <escape>.
GETFILE allows the user to quit the program by typing an empty line in
response to a filename request, though this action is first verified.

     
     
     L.  This stands for L(ist, and is a very handy file lister.  At present 
it is configured for my Malibu dot-matrix printer, and expands headings if the 
filename is to be included.  It is designed to list both programs (ask it to 
include the filename) and manuscripts (heading optional; not printed on first 
page nor expanded).  The options are as follows:

     1)  Line spacing, single to 4 lines.

     2)  Whether or not to print a page heading.

     3)  If you choose a heading, you can include the filename and limited 
other data (printed expanded) or skip the filename and write another heading 
of your choice (none is required).

     4)  You can print all or part of a file by specifying beginning and 
ending page numbers.

     
     
     MODEM (includes the 8080 routine CRC16) and MODEM1.  These two D. C.
Hayes drivers should be fairly self-documenting.  I don't have a modem and
haven't tested them.  The main problem with these sorts of programs is that as 
yet, there is no data transmission standard, so the guy on the other end of
the line must agree with your protocol.

     
     
     SIMP stands for Simplified Integral Modular Prose generator.  I think 
it's much more fun if you see what it does for yourself; it will dump its 
output on the console or the printer (your choice).

     
     
     TYPESET is Sam Singer's gift to his wife, and simply right justifies any 
text presented to it.  It is designed for his Qume and personalized Qume 
driver, but should be easy to modify for other printers with micro spacing.  
The text output is a single, long column, of the same basic column width as 
the original (set in the Editor).  Sam tried for hyphenation but couldn't get 
it to work.

========================================================================================
DOCUMENT :usus Folder:VOL03:blackjack.text
========================================================================================

PROGRAM BLACKJK;
 
 {GAME OF BLACKJACK WRITTEN IN PASCAL BY T.R. STOKES}
 
 CONST
  XINST =       10; {VARIOUS X-Y COORDS FOR SCREEN MESSAGES}
  YINST =        3;
  XWIN  =       11;
  YWIN  =        2;
  XBET  =        8;
  YBET  =        1;
  XOVER =        5;
  YOVER =        4;
  YHAND0=        6; {LEVEL-1 OF CARDS PLAYED}
  
 TYPE
  VEGAS =       (PLAYER,DEALER);
  
 VAR
  DECK                  :ARRAY[1..52] OF INTEGER;
  RANK,SUIT             :INTEGER;
  NAMRANK,NAMSUIT       :STRING;
  CARDSLEFT             :INTEGER;
  SEED                  :INTEGER;
  PERSON                :VEGAS;
  HANDVAL               :ARRAY[1..2] OF INTEGER;
  NACES                 :ARRAY[1..2] OF INTEGER;
  HANDSIZE              :ARRAY[1..2] OF INTEGER;
  BET,DOLLARS           :INTEGER;
  BUST,BJACK,PUSH,WIN   :BOOLEAN;
  XPLYR,YPLYR           :INTEGER;
  XDELR,YDELR           :INTEGER;
  I,J                   :INTEGER; {GENERAL PURPOSE INDICES}
  CARDVAL               :INTEGER;
  REPLY                 :CHAR;
  CHOICE                :SET OF CHAR;
  XHOLE,YHOLE           :INTEGER;
  HOLSUIT,HOLRANK       :STRING;
  DBLDOWN               :BOOLEAN;
  
  
PROCEDURE NEWSCREEN;
 BEGIN
  WRITE(CHR(1),CHR(12));
 END; {NEWSCREEN}
 
PROCEDURE CLEARTOP;
 BEGIN
  GOTOXY(0,0);
  WRITE(CHR(17));       {CLEAR TO END OF LINE}
 END;  {CLEARTOP}
 
PROCEDURE CLEREOL(X,Y:INTEGER);
 BEGIN
  GOTOXY(X,Y);
  WRITE(CHR(17));       {CLEAR TO END OF LINE}
 END; {CLEREOL}

PROCEDURE CLERBOT;
 BEGIN
  GOTOXY(0,YPLYR);
  WRITE(CHR(12));       {CLEAR TO END OF SCREEN}
 END; {CLERBOT}

PROCEDURE SHUFMES;
 BEGIN
  CLEARTOP;
  GOTOXY(5,0);
  WRITE('SHUFFLING-  HAVE A DRINK ON THE HOUSE.');
 END;  {SHUFMES}
  
FUNCTION RND:REAL;
 BEGIN
  RND:=SEED/32767;
  SEED:=(12585*SEED+6975) MOD 32767;
 END; {RND}
 
PROCEDURE FRESHDECK;
 BEGIN
  FOR I:=1 TO 52 DO
   BEGIN
    DECK[I]:=I;
  END; {FOR}
 END;  {FRESHDECK}
 
PROCEDURE SHUFFLE;
 VAR
  TEMP,RI:INTEGER;
 BEGIN
  SHUFMES;
  CARDSLEFT:=52;
   FOR I:=1 TO 52 DO
    BEGIN
     TEMP:=DECK[I];
     RI:=TRUNC(52*RND+1);
     DECK[I]:=DECK[RI];
     DECK[RI]:=TEMP;
    END; {FOR}
   CLEARTOP;
  END; {SHUFFLE}
  
PROCEDURE NAMECARD;
 BEGIN
  NAMRANK:='     ';         {MAKE IT ONE BYTE LONG}
  NAMRANK[1]:=CHR(RANK+48);   {SO THIS WILL WORK}
  IF RANK=1 THEN NAMRANK:='ACE  '
   ELSE IF RANK>9 THEN
    BEGIN
     CASE RANK OF
    10:NAMRANK:='10   ';
    11:NAMRANK:='JACK ';
    12:NAMRANK:='QUEEN';
    13:NAMRANK:='KING ';
     END {RANKCASE}
    END;
    BEGIN
     CASE SUIT OF
    1:NAMSUIT:='CLUBS   ';
    2:NAMSUIT:='DIAMONDS';
    3:NAMSUIT:='HEARTS  ';
    4:NAMSUIT:='SPADES  ';
     END {SUITCASE}
    END;
   END; {NAMECARD}
 
  PROCEDURE RANSUIT(CARD:INTEGER);
   BEGIN
     RANK:=CARD MOD 13;
     IF RANK=0 THEN RANK:=13;
     SUIT:=(CARD-1) DIV 13 + 1;
  END; {RANSUIT}
  
PROCEDURE SETUP;
 BEGIN
  BUST:=FALSE;
  BJACK:=FALSE;
  PUSH:=FALSE;
  WIN:=FALSE;
  DBLDOWN:=FALSE;
  XPLYR:=0;
  YPLYR:=YHAND0;
  XDELR:=26;
  YDELR:=YHAND0;
  FOR I:=1 TO 2 DO
   BEGIN
    HANDVAL[I]:=0;
    NACES[I]:=0;
    HANDSIZE[I]:=0;
   END; {FOR}
 END; {SETUP}
 
 PROCEDURE SHOWHAND;
  VAR
   X,Y,CN  :INTEGER;
  BEGIN
   CASE PERSON OF
  PLAYER:
   BEGIN
    YPLYR:=YPLYR+1;
    Y:=YPLYR;
    X:=XPLYR;
   END;
  DEALER:
   BEGIN
    YDELR:=YDELR+1;
    Y:=YDELR;
    X:=XDELR;
   END;
  END; {CASE}
   NAMECARD;
   GOTOXY(X,Y);
   CN:=Y-YHAND0;
   WRITE(CN:3,')',NAMRANK:6,' OF ',NAMSUIT);
 END; {SHOWHAND}
  
PROCEDURE SCORE;
 VAR ANACE,NAC,CARDVAL:INTEGER;
BEGIN
   CASE PERSON OF
  PLAYER:I:=1;
  DEALER:I:=2;
   END; {CASE}
 CARDVAL:=RANK;
 IF RANK>10 THEN CARDVAL:=10;
 IF RANK=1 THEN NACES[I]:=NACES[I]+1;
 NAC:=NACES[I];
 ANACE:=0;
 IF RANK=1 THEN ANACE:=1;
 HANDVAL[I]:=HANDVAL[I]+CARDVAL+10*ANACE;
   WHILE (HANDVAL[I]>21) AND (NAC>0) DO
    BEGIN
     NACES[I]:=NACES[I]-1;
     HANDVAL[I]:=HANDVAL[I]-10;
    END; {WHILE}
 IF HANDVAL[I]>21 THEN BUST:=TRUE
END; {SCORE}

PROCEDURE PSCORE;
 BEGIN
  GOTOXY(XPLYR+6,YPLYR+1);
  WRITE('TOTAL = ',HANDVAL[1]:3);
 END; {PSCORE}
 
PROCEDURE HSCORE;
 BEGIN
  GOTOXY(XDELR+6,YDELR+1);
  WRITE('TOTAL = ',HANDVAL[2]:3);
 END; {HSCORE}

PROCEDURE WINNINGS;
 BEGIN
  IF NOT PUSH THEN
   BEGIN
    IF DBLDOWN THEN BET:=BET+BET;
    IF WIN THEN DOLLARS:=DOLLARS+BET
    ELSE DOLLARS:=DOLLARS-BET
   END; {NOT PUSH}
  CLEREOL(XWIN,YWIN);
  WRITE('In U.S. of A. Dollars you have $',DOLLARS);
 END; {WINNINGS}
 
PROCEDURE DOWHAT;
 BEGIN
  CLEREOL(XOVER,YOVER);
  REPEAT
   GOTOXY(XOVER,YOVER);
   WRITE('YOUR MONEY ? ');
   READ(REPLY);
  UNTIL REPLY IN CHOICE;
  IF (REPLY='D') AND (HANDSIZE[1]>2) THEN
   BEGIN
    CLEREOL(XINST,YINST);
    WRITE('NO-NO, NOT AFTER 3 OR MORE!!');
    DOWHAT;
   END;
 END; {DOWHAT}
 
PROCEDURE NOSHOW;
 VAR CN:INTEGER;
 BEGIN
  YDELR:=YDELR+1;
  GOTOXY(XDELR,YDELR);
  CN:=YDELR-YHAND0;
  WRITE(CN:3,')   ?????????');
  XHOLE:=XDELR;
  YHOLE:=YDELR;
  HOLSUIT:=NAMSUIT;
  HOLRANK:=NAMRANK;
 END; {NOSHOW}
 
PROCEDURE INSTRUCTIONS;
 BEGIN
  GOTOXY(XINST,YINST);
  WRITE('H)it, G)ood, D)oubledown, S)plitpair');
 END; {INSTRUCTIONS}
 
PROCEDURE PLAYERIN;
 VAR B:CHAR;
BEGIN
 CLEREOL(XBET,YBET);
 WRITE('HOUSE LIMIT IS $200.. BET LIMIT ? (Y/N) ');
 READ(B);
 IF B<>'N' THEN BET:=200
 ELSE
  BEGIN
   REPEAT
   CLEREOL(XBET,YBET);
   WRITE('HOUSE LIMIT IS $200.. BET PLEASE ? ');
   READLN(BET);
  UNTIL BET<201
 END; {REPEAT}
END; {PLAYERIN}

PROCEDURE SHOHOLE;
 VAR CN:INTEGER;
 BEGIN
  GOTOXY(XHOLE,YHOLE);
  CN:=YHOLE-YHAND0;
  WRITE(CN:3,')',HOLRANK:6,' OF ',HOLSUIT);
 END; {SHOHOLE}
   
PROCEDURE DEAL;
 VAR
  K,CARD:INTEGER;
 BEGIN
  K:=CARDSLEFT;
  CARD:=DECK[K];
  RANSUIT(CARD);
  NAMECARD;
  CARDSLEFT:=CARDSLEFT-1;
  IF CARDSLEFT=0 THEN SHUFFLE;
  IF PERSON=PLAYER THEN HANDSIZE[1]:=HANDSIZE[1]+1
   ELSE HANDSIZE[2]:=HANDSIZE[2]+1;
 END; {DEAL}

PROCEDURE DEAL2;
 VAR
   C:INTEGER;
 BEGIN
  FOR C:=1 TO 2 DO
   BEGIN
    FOR PERSON:=PLAYER TO DEALER DO
     BEGIN
      DEAL;
      SCORE;
      IF (PERSON=DEALER) AND (C=1) THEN NOSHOW
      ELSE SHOWHAND
     END; {PERSON}
   END; {FOR}
 END; {DEAL2}
 
PROCEDURE TEST21;
 BEGIN
  IF (HANDVAL[1]=21) OR (HANDVAL[2]=21) THEN
   BEGIN
    BJACK:=TRUE;
    SHOHOLE;
    IF HANDVAL[1]=HANDVAL[2] THEN
     BEGIN
      PUSH:=TRUE;
      CLEREOL(XOVER,YOVER);
      WRITE('* * DOUBLE BLACKJACK !!! - PUSH -');
    END {PUSH}
   ELSE IF HANDVAL[1]=21 THEN
    BEGIN
     WIN:=TRUE;
     BET:=BET+BET DIV 2;
     CLEREOL(XOVER,YOVER);
     WRITE('* * * BLACKJACK !! - PAY 1.5 TIMES BET ');
    END {PLAYERS BLACKJACK}
   ELSE
    BEGIN
     CLEREOL(XOVER,YOVER);
     WRITE('* * DEALER HAS A BLACKJACK !!');
    END;
   END; {BJACK:=TRUE}
  END; {TEST21 - NO BLACKJACK}
  
PROCEDURE DEALPLAYER;
 BEGIN
  PERSON:=PLAYER;
  REPEAT
   DOWHAT;
    IF (REPLY='H') OR (REPLY='D') THEN
     BEGIN
      DEAL;
      SHOWHAND;
      SCORE;
     END
   UNTIL BUST OR (REPLY<>'H') OR (REPLY='D');
  IF BUST THEN
   BEGIN
    CLEREOL(XOVER,YOVER);
    WRITE('YOU BUSTED WITH ',HANDVAL[1]:3);
   END; {IF BUST}
  IF REPLY='D' THEN DBLDOWN:=TRUE;
 END; {DEALPLAYER}
  
PROCEDURE DEALHOUSE;
 BEGIN
  PERSON:=DEALER;
  SHOHOLE;
WHILE (HANDVAL[2]<17) OR ((HANDVAL[2]=17) AND (NACES[2]>0)) DO
   BEGIN
    DEAL;
    SHOWHAND;
    SCORE;
   END; {WHILE}
  HSCORE;
 END; {DEALHOUSE}
 
PROCEDURE EVALUATE;
 VAR HV:INTEGER;
 BEGIN
  IF BUST THEN BEGIN
   WIN:=TRUE;
   CLEREOL(XOVER,YOVER);
   WRITE('THE HOUSE BUSTED WITH ',HANDVAL[2]:3);
  END
  ELSE IF HANDVAL[1]=HANDVAL[2] THEN PUSH:=TRUE
  ELSE IF HANDVAL[1]>HANDVAL[2] THEN WIN:=TRUE;
  IF PUSH THEN BEGIN
   CLEREOL(XOVER,YOVER);
   WRITE(' - PUSH -');
  END;
  HV:=HANDVAL[2];
  IF (NOT PUSH) AND (NOT BUST) THEN
   BEGIN
    CLEREOL(XOVER,YOVER);
    IF HV=21 THEN
     WRITE('DEALER HAS 21!!')
     ELSE WRITE('PAY ',HV+1);
   END; {NOT PUSH}
 END; {EVALUATE}
 
  
 BEGIN          {MAIN PROGRAM}
  CHOICE:=['H','G','D','S'];
  NEWSCREEN;
  WRITE('  PLEASE ENTER A RANDOM NUMBER - ');
  READLN(SEED);
  FRESHDECK;
  SHUFFLE;
  SETUP;
  INSTRUCTIONS;
  PLAYERIN;
  DOLLARS:=0;
  REPEAT
   IF BET>0 THEN BEGIN
    DEAL2;
    TEST21;
    IF NOT BJACK THEN
     BEGIN
      DEALPLAYER;
      PSCORE;
      IF NOT BUST THEN
       BEGIN
        DEALHOUSE;
        EVALUATE;
       END; {IF NOT BUST}
      END; {NOT BJACK}
    END; {BET>0}
   INSTRUCTIONS;
   WINNINGS;
   PLAYERIN;
   SETUP;
   CLERBOT;
  UNTIL BET<0
 END.  {MAIN PROGRAM}


========================================================================================
DOCUMENT :usus Folder:VOL03:catalog.3.text
========================================================================================


               VOLUME 3 CATALOG, UCSD PASCAL USERS' GROUP LIBRARY
                                        
                         Prose, games, and some ideas.*


BLACKJACK.TEXT.....Now you can play it in Pascal.  Appropriate for 1980: allows
                   negative money.

CHASE.TEXT.........A good implementation of an old favorite.  Get away from the 
                   robots, but don't get zapped by the electric fence!
                   
DEBTS.TEXT.........Home finance program, keeps track of your bills.  Nicely menu
                   driven, easy to use.

OTHELLO.TEXT.......VERY nice implementation of OTHELLO, the best I've seen.
OTHELL1.TEXT
OTHELL2.TEXT
OTHELLINIT.TEXT....Subfiles of OTHELLO.

POLICY.DOC.TEXT....How the Users' Group Library works.

PROSE.DOC1.TEXT
PROSE.DOC2.TEXT....A subset of the documentation of Prose, copied from the Pas-
                   cal News No. 15.  What you really need to know to use it.

PROSE.TEXT.........A copy of the fancy text-formatting program from the Pascal
                   News, No. 15, adapted for UCSD Pascal by its author, J. P. 
                   Strait, of the University of Minnesota.  Requires most of 
                   64K of memory to compile.
PROSE.0.TEXT
PROSE.A.TEXT
PROSE.B.TEXT
PROSE.C.TEXT
PROSE.D.TEXT
PROSE.E.TEXT
PROSE.F.TEXT.......Subfiles of Prose.

PROSE.I.5.CODE.....Object version for those without sufficient memory to com-
                   pile; will run under UCSD versions I.4 and I.5.

REQUESTS.TEXT......Some ideas for some very needed programs and routines.

SNOOPY.TEXT........Snoopy calendar, featuring the W.W. I flying ace.

STORE.DATA.........Sample data file for DEBTS.TEXT.

UNIVERSAL.TEXT.....Suggestion for a UNIT that will let us use each other's pro-
                   grams without having to edit in hardware-specific routines.


*    NOTE:  UCSD Pascal is a trademark of the Regents of the University of 
Calofornia.  Please read the file POLICY.DOC.TEXT regarding the software on this
disk.  All programs should be self-documenting, though you'll have to fix hard-
ware-specific procedures in the game programs (see UNIVERSAL.TEXT for a discus-
sion of this subject); as a rule, any code your system does not support (e.g., 
KeyPress or a system clock) can just be deleted.


========================================================================================
DOCUMENT :usus Folder:VOL03:chase.text
========================================================================================


PROGRAM CHASE;
CONST   MAN        = 'O';                     {SYMBOL FOR THE MAN}
        EDGE       = 'I';                     {SYMBOL FOR THE FENCE}
        OBST       = '*';                     {SYMBOL FOR AN OBSTRUCTION}
        ROBOT      = 'R';                     {SYMBOL FOR A ROBOT}
        BLANK      = ' ';                     {AN ASCII BLANK}
       
        DROB       =   3;                     {STARTING NO OF ROBOTS}
        ROBMAX     =  20;                     {MAX NO OF ROBOTS ALLOWED}
        XMAX       =  39;                     {MAX HORIZONTAL FIELD DIMENSION}
        YMAX       =  14;                     {MAX VERTICAL FIELD DIMENSION}
        
        TOP        =   2;                     {SPACE ABOVE FIELD}
        SIDE       =   5;                     {SPACE TO LEFT OF FIELD}
        
        CLRSCRN    =  26;                     {CLEAR SCREEN CODE}


VAR     FIELD      : PACKED ARRAY[0..XMAX,0..YMAX] OF CHAR;
        AGAIN,PLAY : BOOLEAN;
        WIN        : BOOLEAN;
        MI,MJ      : INTEGER;                 {COORDINATES OF THE MAN}
        R          : INTEGER;                 {NUMBER OF ROBOTS LEFT}
        RI,RJ      : ARRAY[1..ROBMAX] OF INTEGER;  {ROBOT COORDINATES}
        RNUM       : REAL;
        DIFF       : INTEGER;                 {DIFFICULTY}
        IDIFF      : 0..10;                   {INITIAL DIFFICULTY}
        GAMENU     : INTEGER;                 {GAME NUMBER}
        M          : CHAR;
        NROB       : INTEGER;                 {NUMBER OF ROBOTS}
        WINS       : INTEGER;                 {NUMBER OF GAMES WON}
        GOODCHAR   : SET OF CHAR;             {GOOD CHARACTERS}
        MOVES      : INTEGER;                 {COUNT OF MOVES}
        CRASH      : INTEGER;                 {NO OF ROBOTS "CRASHED"}

FUNCTION RND(LO,HI:INTEGER):INTEGER;          {RANDOM NUMBER GENERATOR}
VAR  Q       :REAL;
     I       :INTEGER;
BEGIN
  REPEAT
    RNUM:=RNUM*21.182813+31.415917;
    RNUM:=RNUM-TRUNC(RNUM);
    I:=TRUNC(RNUM*HI);
  UNTIL I>LO;
  RND:=I;
END;
    


PROCEDURE DOMOVE(COL,ROW:INTEGER;SYMBOL:CHAR); {DISPLAY SYMBOL AT I,J ON FIELD}
BEGIN
  GOTOXY(COL,ROW);         {POSITION CURSOR}
  WRITE(SYMBOL)
END;            {END OF DOMOVE PROCEDURE}


PROCEDURE CLEARSCREEN;         {FOR AN ADM3-A CHANGE IT FOR OTHER TERMINAL}
BEGIN
  WRITE(CHR(CLRSCRN),CHR(0),CHR(0),CHR(0),CHR(0),CHR(0))
END;


PROCEDURE INSTRUCTIONS;                       {DISPLAY INSTRUCTIONS}
VAR M:CHAR;
BEGIN
  CLEARSCREEN;
  WRITELN('WELCOME TO THE WONDERFUL EXCITING GAME OF CHASE':60);
  GOTOXY(0,3);
  WRITE('WOULD YOU LIKE INSTRUCTIONS ? (Y OR N) ':55);
  READ(M);
  IF M='Y' THEN
  BEGIN
    WRITELN;WRITELN;
    WRITELN('    HERE ARE SOME INSTRUCTIONS');
    WRITELN('YOU,"O",ARE IN A HIGH VOLTAGE MAZE.');
    WRITELN('THE ROBOT COMPUTERS,"R",ARE TRYING TO DESTROY YOU.');
    WRITELN('TO WIN, YOU MUST DESTROY THE COMPUTERS.');
    WRITELN('THIS IS DONE BY RUNNING THEM INTO FENCE POSTS,"*",');
    WRITELN('OR BY RUNNING THEM INTO EACH OTHER.');
    WRITELN('THE DIAGRAM BELOW THE MAZE SHOWS HOW YOU CAN MOVE');
    WRITELN('THE ROBOTS WILL TRY TO FOLLOW YOU.');
    WRITELN('THERE ARE 3 ROBOTS TO START FOR A BEGINNER.');
    WRITELN('THE NUMBER WILL INCREASE AS YOU WIN GAMES !');
    WRITELN;
    WRITELN('          GOOD LUCK!!!!!')
  END;
END;                                          {END OF INSTRUCTIONS}


PROCEDURE STARTGAME;
VAR    SK: CHAR;
BEGIN
WRITELN;WRITELN;WRITELN;
  WRITE('ENTER A NUMBER FOLLOWED BY RETURN ':51);READLN(RNUM);
  IF RNUM=0 THEN RNUM:=12.345;
  WHILE RNUM > 200 DO RNUM:=RNUM-200;
  CLEARSCREEN;
  WRITELN('      HOW GOOD A PLAYER ARE YOU ?');
  WRITELN;
  WRITELN('        BEGINNER     - B');
  WRITELN('        INTERMEDIATE - I');
  WRITELN('        EXPERT       - E');
  WRITELN('        OLD PRO      - P');
  WRITELN;
  WRITE('              TYPE IN YOUR SKILL ');
  READ (SK);
  WRITELN;
  WHILE NOT (SK IN ['B','I','E','P']) DO
  BEGIN
    GOTOXY(10,10);
    WRITE('    WHAT WAS THAT AGAIN PLEASE ? ',CHR(7));
    READ (SK);
    WRITELN
  END;
  CASE SK OF
    'B': IDIFF:=0;
    'I': IDIFF:=1;
    'E': IDIFF:=3;
    'P': IDIFF:=5;
  END;
END;


PROCEDURE INITIALIZE;   {SET UP BLANK FIELD SURROUNDED BY FENCE}
VAR I,J:INTEGER;
BEGIN
  FOR I:=0 TO XMAX DO
  BEGIN
    FOR J:=0 TO YMAX DO
    IF((I=0) OR (I=XMAX) OR (J=0) OR (J=YMAX)) THEN FIELD[I,J]:=EDGE
      ELSE FIELD[I,J]:=BLANK
   END;
END;    {END OF INITIALIZE}


PROCEDURE INNERFIELD;   {SET UP MAN, ROBOTS AND OBSTRUCTIONS}
VAR I,J,L,POSTS:INTEGER;
BEGIN
  MI:=RND(0,XMAX); MJ:=RND(0,YMAX); {LOCATE MAN AT ANY RANDOM POSITION}
  FIELD[MI,MJ]:=MAN;
  R:=NROB;
  FOR L:=1 TO R DO                            {NOW DO R ROBOTS}
  BEGIN
    REPEAT
      I:=RND(0,XMAX);J:=RND(0,YMAX);
    UNTIL FIELD[I,J]=BLANK;
    FIELD[I,J]:=ROBOT;
    RI[L]:=I;
    RJ[L]:=J
  END;
  POSTS:=RND(25,35);                          {NOW SET UP 25 TO 35 POSTS}
  FOR L:=1 TO POSTS DO
  BEGIN
    REPEAT
      IF DIFF>3 THEN
      BEGIN
        I:=RND(0,XMAX);
        J:=RND(0,YMAX)
      END ELSE
      BEGIN
        I:=RND(1,XMAX-1);
        J:=RND(1,YMAX-1)
      END;
    UNTIL FIELD[I,J]=BLANK;
    FIELD[I,J]:=OBST
    END; 
END;                                          {END OF INNERFIELD}


PROCEDURE MAP;                                {DISPLAY PLAYING FIELD}
VAR I,J:INTEGER;
BEGIN
  CLEARSCREEN;
  WRITELN('GAME  DIFF   ROBOTS    WINS    MOVE':79);
  WRITE(' ':44,GAMENU:3,DIFF:5,R:8,WINS:10,MOVES:8);
  GOTOXY(0,0);
  FOR J:=0 TO YMAX DO
  BEGIN
    FOR I:=0 TO XMAX DO WRITE(FIELD[I,J]);
    WRITELN
  END;
  WRITELN;
  WRITELN('1 2 3      Q = QUIT');
  WRITELN('4 X 6      5 = NO MOVE'); 
  WRITE('7 8 9                  MOVE => ');
END;                                          {END OF MAP}

PROCEDURE MOVE;                               {ENTER YOUR MOVE FROM KEYBOARD}
VAR     M : INTEGER;
        C : CHAR;
      BAD : BOOLEAN;
BEGIN
  BAD:=FALSE;
  REPEAT
    WRITE(' ',CHR(8));
    READ (C);
    IF NOT (C IN GOODCHAR) THEN
    BEGIN
      GOTOXY(4,21);
      BAD:=TRUE;
      WRITE('BAD MOVE, PLEASE TRY AGAIN ':33,CHR(7))
    END;
  UNTIL (C IN GOODCHAR);
  IF BAD THEN
    BEGIN
      GOTOXY(4,21);
      WRITE(' ':40);
      GOTOXY(10,22);
    END;
  IF C='Q' THEN
    BEGIN
     PLAY:=FALSE;
     WIN:=FALSE
    END;
  M:=ORD(C)-48;
  FIELD[MI,MJ]:=BLANK;
  DOMOVE(MI,MJ,BLANK);
      CASE M OF
  1: BEGIN MI:=MI-1; MJ:=MJ-1 END;
  2: MJ:=MJ-1;
  3: BEGIN MI:=MI+1; MJ:=MJ-1 END;
  4: MI:=MI-1;
  5: ;
  6: MI:=MI+1;
  7: BEGIN MI:=MI-1; MJ:=MJ+1 END;
  8: MJ:=MJ+1;
  9: BEGIN MI:=MI+1; MJ:=MJ+1 END
     END;
  MOVES:=MOVES+1;
  IF FIELD[MI,MJ] = BLANK THEN
    BEGIN
      DOMOVE(MI,MJ,MAN);
      FIELD[MI,MJ]:=MAN 
    END ELSE
  BEGIN
    IF FIELD[MI,MJ] = EDGE THEN
    BEGIN
      WIN:=FALSE;
      PLAY:=FALSE;
      WRITELN('OUCH, YOU GOT ELECTROCUTED!')
    END ELSE
    BEGIN
      IF FIELD[MI,MJ] = ROBOT THEN 
      WRITELN('THWACK! YOU RAN INTO A ROBOT (TURKEY!)') ELSE
      WRITELN('ZZAP! YOU RAN INTO AN ELECTIFIED POST');
      WIN:=FALSE;
      PLAY:=FALSE
    END;
  END;
END;            {END OF MOVE PROCEDURE}


PROCEDURE ROBOTMOVE;    {COMPUTE MOVE FOR R OR FEWER ROBOTS}
VAR M,L,I,J:INTEGER;
BEGIN
  FOR L:=1 TO NROB DO
  BEGIN
    IF((RI[L]<>0) AND (WIN)) THEN
    BEGIN
      FIELD[RI[L],RJ[L]]:=BLANK;
      DOMOVE(RI[L],RJ[L],BLANK);
      IF MI>RI[L] THEN RI[L]:=RI[L]+1;
      IF MI<RI[L] THEN RI[L]:=RI[L]-1;
      IF MJ>RJ[L] THEN RJ[L]:=RJ[L]+1;
      IF MJ<RJ[L] THEN RJ[L]:=RJ[L]-1;
      I:=RI[L];J:=RJ[L];
      IF FIELD[I,J]=BLANK THEN
      BEGIN
        FIELD[RI[L],RJ[L]]:=ROBOT;
        DOMOVE(I,J,ROBOT)
      END
      ELSE
      BEGIN
        IF ((FIELD[I,J]=OBST) OR (FIELD[I,J]=ROBOT))  THEN 
        BEGIN
          GOTOXY(XMAX+12,CRASH+3);
          CRASH:=CRASH+1;
          WRITELN('CRASH!! YOU GOT ONE!!');
          R:=R-1;
          GOTOXY(53,1);             {CHANGE NO OF ROBOTS}
          WRITE(R:8);
          RI[L]:=0;
          IF R=0 THEN
          BEGIN
            GOTOXY(XMAX+16,CRASH+3);
            WRITELN('GOOD WORK!');
            GOTOXY(XMAX+8,CRASH+4);
            WRITELN('YOU HAVE DESTROYED THEM ALL!!');
            WIN:=TRUE;
            PLAY:=FALSE
          END;
        END;
      END;
      IF FIELD[RI[L],RJ[L]]=FIELD[MI,MJ] THEN
      BEGIN
        WRITELN('ZAP! A COMPUTER GOT YOU!');
        WIN:=FALSE;
        PLAY:=FALSE
      END;
    END;
 END;
END;                                         {END OF ROBOTMOVE PROCEDURE}



BEGIN             {START OF MAIN PROGRAM}
  GOODCHAR:=['1'..'9','Q'];
  GAMENU:=1;
  WINS:=0;
  AGAIN:=TRUE;
  PLAY:=TRUE;     {INITIALIZE QUIT}
  INSTRUCTIONS;   {DISPLAY INSTRUCTIONS}
  STARTGAME;      {INPUT STARTING POSITION AND SKILL LEVEL}
  DIFF:=IDIFF;    {INITIAL DIFFICULTY LEVEL}
  NROB:=DROB+DIFF*2;  {INITIAL NUMBER OF ROBOTS}
  WHILE AGAIN DO
  BEGIN
    MOVES:=1;WIN:=TRUE;CRASH:=0;
    INITIALIZE;     {CLEARS FIELD[X,Y]}
    INNERFIELD;     {SETS UP PLAYING FIELD}
    WHILE PLAY DO
    BEGIN
      IF MOVES=1 THEN MAP ELSE
      BEGIN
        GOTOXY(70,1);
        WRITELN(MOVES:8);
        DOMOVE(30,18,BLANK)             {INPUT NEXT MOVE}
      END;
      MOVE;         {LETS YOU MOVE}
      IF(PLAY) THEN ROBOTMOVE     {MOVES THE ROBOTS}
    END;
    GOTOXY(0,21);
    WRITE('WOULD YOU LIKE TO PLAY AGAIN (Y OR N) ');
    READ(M);
    IF M='N' THEN AGAIN:=FALSE ELSE
    BEGIN
      PLAY:=TRUE;
      GAMENU:=GAMENU+1;
      IF WIN THEN
      BEGIN
        WINS:=WINS+1;
        IF WINS>2 THEN DIFF:=IDIFF+1;
        IF WINS>5 THEN DIFF:=IDIFF+2;
        IF WINS>8 THEN DIFF:=IDIFF+3;
        IF WINS>11 THEN DIFF:=IDIFF+4;
        IF WINS>15 THEN DIFF:=IDIFF+6;
        IF WINS>20 THEN DIFF:=IDIFF+8;
        IF WINS>30 THEN DIFF:=IDIFF+12;
        NROB:=DROB+2*DIFF
      END;
    END;
  END;
END.


========================================================================================
DOCUMENT :usus Folder:VOL03:debts.text
========================================================================================

PROGRAM DEBTS;
{KEEPS TRACK OF ALL REVOLVING DEBTS ON DISK FILE}
{DISK FILE NAME IS STORE.DATA}

CONST
 CLERSCRN=26;
 CLEREOL=28;
 CLEREOS=25;
 FIRSTLINE=3;
 FIRSTYR=70;
 LASTYR=99;
 
TYPE
 MNTH=1..12;
 DAY=1..31;
 CHOICESET=SET OF CHAR;
 DATE=
  RECORD
   YY:INTEGER;
   MM:INTEGER;
   DD:INTEGER;
  END;
 STORECARD=
  RECORD
   NAME:STRING;
   LASTPAID:DATE;
   BALANCE:REAL;
   LASTPAYMENT:REAL;
   MINPAYMENT:REAL;
   CARRYCHARGE:REAL;
   MONTHLYCOST:REAL;
   TOTALCARRY:REAL;
  END;
 
VAR
 LAST,INDEX             :INTEGER;
 EXISTS,DONE            :BOOLEAN;
 TODAY                  :DATE;
 THISPAYMENT            :REAL;
 STORE                  :STORECARD;
 STORES                 :ARRAY[1..30] OF STORECARD;
 STORAL                 :FILE OF STORECARD;
 DATEISCURRENT          :BOOLEAN;
 CHOICE                 :CHOICESET;
 REPLY                  :CHAR;
 DATERROR               :BOOLEAN;
 

PROCEDURE CLRSCRN;
 BEGIN
  WRITE(CHR(CLERSCRN));
 END;
 
PROCEDURE CLRFROM(LINE:INTEGER);
 BEGIN
  GOTOXY(0,LINE);
  WRITE(CHR(CLEREOS));
 END;

PROCEDURE CLREOL(LINE:INTEGER);
 BEGIN
  GOTOXY(0,LINE);
  WRITE(CHR(CLEREOL));
 END;
 
PROCEDURE CLRTO(LINE:INTEGER);
 VAR I:INTEGER;
 BEGIN
  FOR I:=0 TO LINE-1 DO
   BEGIN
    GOTOXY(0,I);
    CLREOL(I);
   END; {DO}
 END;
 
PROCEDURE SHOWDATE;
 BEGIN
  WRITE(' ':14);
  WRITELN('TODAY IS: ',TODAY.MM,'/',TODAY.DD,'/',TODAY.YY);
 END;
 
PROCEDURE SHOWMENU;
 BEGIN
 CLRFROM(FIRSTLINE);
WRITELN('D)':6,' todays Date');
WRITELN('G)':6,' Global list of creditors');
WRITELN('P)':6,' Pay a creditor');
WRITELN('C)':6,' Correct a record');
WRITELN('A)':6,' Add a creditor');
WRITELN('L)':6,' list Late payments');
WRITELN('E)':6,' Expanded creditor info');
WRITELN('F)':6,' Figure minimum payment');
WRITELN('R)':6,' Remove a creditor');
WRITELN('T)':6,' Total all debts');
WRITELN('Q)':6,' Quit');
 IF DATEISCURRENT THEN SHOWDATE
  ELSE
WRITELN(' ':8,'**NOTE: FIRST COMMAND SHOULD BE -D- FOR DATE');
END; {SHOWMENU}

PROCEDURE CHOOSE;
 BEGIN
  WRITE(' ':5,'Choose an item from the Menu->');
   REPEAT
    READ(REPLY);
   UNTIL REPLY  IN CHOICE
 END; {CHOOSE}

PROCEDURE GETDATE(VAR ADAY:DATE);
 VAR M,D,Y:INTEGER;
 BEGIN
  DATERROR:=FALSE;
  WRITE('   Enter date as   MM  DD  YY ->  ');
  READLN(M,D,Y);
  IF (M<1) OR (M>12) THEN DATERROR:=TRUE;
  IF (D<1) OR (D>31) THEN DATERROR:=TRUE;
  IF (Y<20) OR (Y>99) THEN DATERROR:=TRUE;
  IF NOT DATERROR THEN
   BEGIN
    WITH ADAY DO
     BEGIN
      MM:=M;
      DD:=D;
      YY:=Y;
      WRITELN(' ':20,MM:2,'/',DD:2,'/',YY);
     END;
   END {NOT ERROR}
  ELSE
   BEGIN
    WRITELN(' ??? DATE DD/MM/YY = ',D,M,Y);
    WRITELN('    PLEASE TRY AGAIN');
   END;
  END; {GETDATE}
  
 PROCEDURE ADD;
  VAR C :CHAR;
      X :REAL;
  BEGIN
   CLRSCRN;
   LAST:=LAST+1;
   INDEX:=LAST;
    WITH STORES[INDEX] DO
     BEGIN
   WRITELN;
   WRITELN(' ':10,'ADDING A NEW RECORD - -');
   WRITELN;
   WRITE(' ENTER STORE/CREDITOR NAME-> ');
   READLN(NAME);
   WRITELN(' ENTER DATE OF LAST PAYMENT');
   DATERROR:=TRUE;
   WHILE DATERROR DO GETDATE(LASTPAID);
   WRITE(' WHAT IS THE CURRENT BALANCE? ');
   READLN(BALANCE);
   WRITE(' IF YOU KNOW MIN. PAYMENT, ENTER IT, ELSE ENTER 0 ');
   READLN(X);
   IF X=0 THEN X:=BALANCE/10.0;
   MINPAYMENT:=X;
   WRITE(' HOW MUCH WAS THE LAST PAYMENT? ');
   READLN(LASTPAYMENT);
   WRITE(' WHAT IS THE CARRYING CHARGE IN PERCENT? ');
   READLN(CARRYCHARGE);
   MONTHLYCOST:=BALANCE*CARRYCHARGE/100.0;
   TOTALCARRY:=0;
     END; {WITH}
    CLRTO(FIRSTLINE);
  END; {ADD}
 
PROCEDURE INFORM;
 BEGIN
WRITELN('  THIS PROGRAM KEEPS PERMANENT RECORDS OF YOUR');
WRITELN('DEBTS TO STORES, ETC, THAT REQUIRE MONTHLY PAYMENTS');
WRITELN('THE DATA IS KEPT ON A FILE NAMED - STORE.DATA ');
WRITELN;
 END; {INFORM}
 
PROCEDURE OPENFILE;
 VAR C:CHAR;
 BEGIN
 REWRITE(STORAL,'STORE.DATA');
 WRITELN;
 WRITELN('** NEW FILE - STORE.DATA - WAS CREATED');
 INDEX:=0;
 LAST:=0;
END;
 
PROCEDURE REOPEN;
 BEGIN
  RESET(STORAL,'STORE.DATA');
  INDEX:=1;
  STORES[INDEX]:=STORAL^;
 WHILE NOT EOF(STORAL) DO
  BEGIN
   INDEX:=INDEX+1;
   GET(STORAL);
   STORES[INDEX]:=STORAL^;
  END; {WHILE}
  INDEX:=INDEX-1;
  LAST:=INDEX;
 END; {REOPEN}
 
PROCEDURE CLOSEFILE;
 BEGIN
  CLOSE(STORAL,LOCK);                {CLOSE EXISTING FILE}
  REWRITE(STORAL,'STORE.DATA');         {OPEN A NEW ONE}
  FOR INDEX:=1 TO LAST DO
   BEGIN
    STORAL^:=STORES[INDEX];
    PUT(STORAL);
   END; {OF INDEXING}
  CLOSE(STORAL,LOCK);        {MAKE IT PERMANENT ON DIR.}
  DONE:=TRUE;
 END; {CLOSEFILE}
 
PROCEDURE INIT;
 VAR C,C2:CHAR;
 BEGIN
  CLRSCRN;
  INFORM;
  DATEISCURRENT:=FALSE;
  DONE:=FALSE;
  CHOICE:=['D','G','P','C','A','L','E','F','R','T','Q'];
  WRITELN;
  WRITELN('WARNING - IF A DATA FILE DOES NOT EXIST');
  WRITELN('  (it wont on the very first run)');
  WRITELN('YOU MUST CREATE ONE BY USING THE');
  WRITELN(' A (ADD) COMMAND');
  WRITE('DOES A DATA FILE EXIST (Y/N)? ');
  READ(C);
  IF C<>'Y' THEN
   BEGIN
    WRITELN;
    WRITELN(' ANY EXISTING FILE WILL BE CLOBBERED!!');
    WRITE('  DO YOU WANT TO START A NEW ONE ? ');
    READ(C2);
    IF C2<>'Y' THEN C:='Y';
   END;
  EXISTS:=FALSE;
  IF C='Y' THEN EXISTS:=TRUE;
  IF EXISTS THEN REOPEN
   ELSE OPENFILE;
  CLRSCRN;
END; {INIT}

PROCEDURE QUIT;
 VAR C1,C2:CHAR;
 BEGIN
  CLRTO(FIRSTLINE);
  GOTOXY(5,0);
  WRITE(' DO YOU WANT TO QUIT (Y/N)? ');
  READ(C1);
  IF C1='Y' THEN
   BEGIN
    DONE:=TRUE;
    WRITELN;
    WRITE(' DO YOU WANT THIS TO BE THE NEW FILE (Y/N)? ');
    READ(C2);
    IF C2='Y' THEN CLOSEFILE;
   END; {IF C1='Y'}
 END; {QUIT}
 
PROCEDURE GLOBALS;
 VAR C:CHAR;
     LIN:INTEGER;
 BEGIN
  CLRSCRN;
  GOTOXY(0,FIRSTLINE);
  FOR INDEX:=1 TO LAST DO
   BEGIN
    WITH STORES[INDEX] DO
     BEGIN
   LIN:=FIRSTLINE+INDEX-1;
   WRITE(INDEX:3,'. ');
   WRITE(NAME);
   GOTOXY(18,LIN);
   WRITE(BALANCE:8:2);
   WITH LASTPAID DO WRITE(MM:6,'/',DD:2,'/',YY:2);
   WRITE(LASTPAYMENT:8:2);
   WRITELN;
    END; {WITH}
  END; {DO}
 WRITELN('-----------------------------------------------');
 IF REPLY='G' THEN
  BEGIN
   CLREOL(0);
   GOTOXY(9,0);
   WRITE(' Hit a key to continue');
   READ(C);
   CLRTO(FIRSTLINE);
  END; {REPLY='G'}
END; {GLOBALS}

PROCEDURE GETTODAY;
 BEGIN
  CLRTO(FIRSTLINE);
  GOTOXY(0,0);
  DATERROR:=TRUE;
  WHILE DATERROR DO GETDATE(TODAY);
  DATEISCURRENT:=TRUE;
 END;

   
PROCEDURE SHOWALL(I:INTEGER);
 VAR C:CHAR;
   BEGIN
    WITH STORES[I] DO
     BEGIN
      CLRSCRN;
      GOTOXY(10,0); 
WRITELN(I:2,') ',NAME);
WRITELN;
WRITE('Date of last payment :............. ');
WITH LASTPAID DO WRITELN(MM:2,'/',DD:2,'/',YY:2);
WRITELN;
WRITELN('Total balance due = $........... ',BALANCE:8:2);
WRITELN('Amount of last payment = $...... ',LASTPAYMENT:8:2);
WRITELN('Monthly carrying charge: %...... ',CARRYCHARGE:8:2);
WRITELN('Monthly finance charge = $...... ',MONTHLYCOST:8:2);
WRITELN('Total  charges to date = $...... ',TOTALCARRY:8:2);
WRITELN('Minimum payment = $............. ',MINPAYMENT:8:2);
WRITELN;
   END; {WITH}
 END; {SHOWALL}

PROCEDURE PAY;
 VAR I:INTEGER;
     ANSWER:CHAR;
 BEGIN
  CLRSCRN;
  GLOBALS;
  GOTOXY(5,0);
  WRITE('Pay who ? ');
  READLN(I);
  IF (I<=LAST) AND (I>0) THEN
   BEGIN
    SHOWALL(I);
    WRITELN;
    WRITE(' ':10,'Pay how much ? ');
    READLN(THISPAYMENT);
    WITH STORES[I] DO
     BEGIN
      BALANCE:=BALANCE-THISPAYMENT;
      LASTPAYMENT:=THISPAYMENT;
      LASTPAID:=TODAY;
     END; {WITH}
    SHOWALL(I);
    WRITELN;
    WRITE(' ':10,'ALL O.K. ? ');
    READ(ANSWER);
    CLRTO(FIRSTLINE);
    IF ANSWER='N' THEN
     BEGIN
      GOTOXY(10,0);
      WRITE(' USE ''C'' TO CORRECT IT');
     END; {IF}
    END {IF}
  ELSE
   BEGIN
    GOTOXY(6,0);
    WRITE('THAT NUMBER IS NOT IN THE LIST !');
   END; {IF}
  END; {PAY}

{START A GROUP OF DUMMY PROCS HERE}
 
PROCEDURE LATE;
 BEGIN END;
 
PROCEDURE EXPOSE;
 VAR I:INTEGER;
     C:CHAR;
 BEGIN
  CLRSCRN;
  GLOBALS;
  GOTOXY(5,0);
  WRITE('Expand which one (number) ? ');
  READLN(I);
  IF (I>0) AND (I<=LAST) THEN
   BEGIN
    SHOWALL(I);
    WRITE('  - - Hit a key to cont.  ');
    READ(C);
    CLRTO(FIRSTLINE);
   END
 ELSE
  BEGIN
   GOTOXY(6,1);
   WRITE('THAT CHOICE IS NOT IN THE LIST');
  END; {ELSE}
END; {EXPOSE}
 
PROCEDURE EXPAND;
 VAR C:CHAR;
     I:INTEGER;
  BEGIN
   CLRTO(FIRSTLINE);
   GOTOXY(5,0);
   WRITE('Do you want to step through all ? ');
   READ(C);
   IF C='Y' THEN
    BEGIN
     FOR I:=1 TO LAST DO
      BEGIN
       SHOWALL(I);
       WRITE('  - - Hit a key to cont.  ');
       READ(C);
       CLRSCRN;
      END; {FOR}
    END {'Y'}
  ELSE
   EXPOSE
END; {EXPAND}

PROCEDURE FIGUREMIN;
 BEGIN END;
 
PROCEDURE TOTALALL;
 VAR
  I                             :INTEGER;
  TOTALMONTH,TOTALBALANCE       :REAL;
  C                             :CHAR;
 BEGIN
  CLRSCRN;
  TOTALMONTH:=0;
  TOTALBALANCE:=0;
  FOR I:=1 TO LAST DO
   WITH STORES[I] DO
    BEGIN
     TOTALBALANCE:=TOTALBALANCE+BALANCE;
     TOTALMONTH:=TOTALMONTH+MONTHLYCOST;
    END; {FOR-WITH}
  WRITELN;
  WRITELN;
  WRITELN(' Your Total balance is an incredible $ ',
            TOTALBALANCE:8:2);
  WRITELN;
  WRITELN(' And the total carrying charge per monthe is $ ',
                TOTALMONTH:7:2);
  WRITELN;
  WRITELN('     When you''ve seen enough');
    WRITE('      press a key.... ');
  READ(C);
  CLRTO(FIRSTLINE);
 END; {TOTALALL}
  
PROCEDURE REMOVE1;
 VAR I:INTEGER;
     C:CHAR;
 BEGIN
  CLRSCRN;
  GLOBALS;
  CLRTO(FIRSTLINE);
  GOTOXY(5,0);
  WRITE('Remove which one (number) ? ');
  READLN(I);
  IF (I>0) AND (I<=LAST) THEN
   BEGIN
   WITH STORES[I] DO WRITE('  Remove ',NAME,' ? ');
   READ(C);
   IF C='Y' THEN 
    BEGIN
     LAST:=LAST-1;
     FOR INDEX:=I TO LAST DO
      STORES[INDEX]:=STORES[INDEX+1];
     END; {C='Y'}
    END {IN LIST}
   ELSE {NOT IN LIST}
    BEGIN
     CLREOL(1);
     WRITE('   THAT NUMBER IS NOT IN THE LIST!!');
    END; {ELSE)
  END; {IF}
 END; {REMOVE1}
 
{END OF DUMMY PROCS}

PROCEDURE CORRECT;
 VAR WHAT:CHAR;
     WHATSIT:SET OF CHAR;
     I:INTEGER;
 BEGIN
  WHATSIT:=['N','B','D','L','M','P','C','T','Q'];
  CLRSCRN;
  GLOBALS;
  GOTOXY(5,0);
  WRITE('Correct which record (number) ? ');
  READLN(I);
  IF (I>0) AND (I<=LAST) THEN
   BEGIN
    REPEAT
     SHOWALL(I);
     WRITELN('CORRECT one of the following:');
     WRITELN('N)ame,B)alance,D)ate,L)astpmnt,M)inpmnt');
     WRITELN('P)ercent,C)ost/mnth,T)otal charge,Q)uit');
     REPEAT
      READ(KEYBOARD,WHAT)
     UNTIL WHAT IN WHATSIT;
     WITH STORES[I] DO
      CASE WHAT OF
    'N':BEGIN
         WRITE('New Name? ');
         READLN(NAME);
         END;
    'B':BEGIN
         WRITE('New Balance= ');
         READLN(BALANCE);
         END;
    'D':BEGIN
         DATERROR:=TRUE;
         WHILE DATERROR DO GETDATE(LASTPAID);
         END;
    'L':BEGIN
         WRITE('amount of Last payment');
         READLN(LASTPAYMENT);
         END;
    'M':BEGIN
         WRITE('Minumum payment ? ');
         READLN(MINPAYMENT);
         END;
    'P':BEGIN
         WRITE('Percent monthly carry charge ? ');
         READLN(CARRYCHARGE);
         END;
    'C':BEGIN
         WRITE('Cost per month ? ');
         READLN(MONTHLYCOST);
         END;
    'T':BEGIN
         WRITE('Total carry charge to date ? ');
         READLN(TOTALCARRY);
         END;
    'Q':;
          END; {CASE}
      UNTIL WHAT='Q';
      CLRTO(FIRSTLINE);
     END {IF}
   ELSE
    BEGIN
     GOTOXY(6,1);
     WRITE('THAT NUMBER IS NOT IN THE RECORDS');
    END; {ELSE}
  END; {CORRECT}
         
PROCEDURE SERVE;
 BEGIN
   CASE REPLY OF
 'D':GETTODAY;
 'G':GLOBALS;
 'P':PAY;
 'C':CORRECT;
 'A':ADD;
 'L':LATE;
 'E':EXPAND;
 'F':FIGUREMIN;
 'R':REMOVE1;
 'T':TOTALALL;
 'Q':QUIT;
   END; {CASE}
 END; {SERVE}

BEGIN  {MAIN PROG}
 INIT;
  REPEAT
   SHOWMENU;
   CHOOSE;
   SERVE;
  UNTIL DONE
END.


========================================================================================
DOCUMENT :usus Folder:VOL03:othell1.text
========================================================================================


FUNCTION flipof(*oldcolor: color): color*);
BEGIN
IF oldcolor = white THEN
   flipof := black
ELSE
   flipof := white;
END; (*flipof*)

PROCEDURE updatecrt(*VAR oldstatus,newstatus: gamestatus*);
VAR
   x,y:         coordinate;
   direc:       direction;
   square:      squareloc;

   PROCEDURE showpiece(square: squareloc);
      
      PROCEDURE changecrtsq(square: squareloc);
      CONST
         bell = 7;
      VAR
         s:                     PACKED ARRAY[1..3] OF CHAR;
         c:                     CHAR;
         crtline,crtcol:        INTEGER;
         h,l:                   INTEGER;
         now:                   REAL;
      BEGIN
      WITH square DO BEGIN
         IF newstatus.boardstatus[row,col].occupier = white THEN
            c := CHR(whiteascii)
         ELSE
            c := CHR(blackascii);
         FILLCHAR(s,3,c);
         crtline := (3*row) - 3;
         crtcol  := 26 + (6*col);
         END;
      REPEAT
         TIME(h,l);
         now := l;
         IF now < 0.0 THEN
            now := now + 65536.0;
         now := (h*65536.0) + now;
         UNTIL (now - lastchange) > minticks; 
      GOTOXY(crtcol,crtline);
      WRITE(s);
      GOTOXY(crtcol,crtline+1);
      WRITE(s,CHR(bell));
      lastchange := now;
      END; (*changecrtsq*)
   
   BEGIN (*showpiece*)
   WITH square DO
      IF newstatus.boardstatus[row,col].occupied THEN
         IF NOT oldstatus.boardstatus[row,col].occupied THEN
            changecrtsq(square)
         ELSE IF oldstatus.boardstatus[row,col].occupier <>
                 newstatus.boardstatus[row,col].occupier THEN
                 changecrtsq(square);
   END; (*showpiece*)

BEGIN (*updatecrt*)
WITH newstatus DO BEGIN
   showpiece(lastmoveloc);
   FOR direc := north to nw DO BEGIN
      square := lastmoveloc;
      WHILE boardstatus[square.row,square.col].occupied AND
            board[square.row,square.col].adjacentsq[direc].onboard DO BEGIN
         square := board[square.row,square.col].adjacentsq[direc];
         showpiece(square);
         END; (*WHILE...*)
      END; (*FOR direc...*)
   GOTOXY(9,2);
   WRITE(score[white]:2);
   GOTOXY(9,3);
   write(score[black]:2);
   END; (*WITH newstatus...*)
GOTOXY(0,0);
END; (*updatecrt*)

PROCEDURE findlegalmoves(VAR status: gamestatus; VAR legallist: movelist);
VAR
   x,y:                   coordinate;
   sq:                    squareloc;
   flips,direcflips:      INTEGER;
   borderflips:           INTEGER;
   stopdirec:             BOOLEAN;
   oppcolor:              color;
   direc:                 direction;
   trydirs,gooddirs:      SET OF direction;
   possible:              BOOLEAN;
   sqstatus:              squarestatus;
BEGIN
WITH status, legallist DO BEGIN
   oppcolor := flipof(nextmover);
   movecount := 0;
   FOR x := 1 TO 8 DO  FOR y := 1 TO 8 DO BEGIN
      possible := FALSE;
      WITH boardstatus[x,y] DO
         IF NOT occupied THEN
            IF adjacentpieces[oppcolor] <> [] THEN BEGIN
               possible := TRUE;
               trydirs := adjacentpieces[oppcolor];
               END;
      IF possible THEN BEGIN
         gooddirs := [];
         flips := 0;
         borderflips := 0;
         FOR direc := north TO nw DO
            IF direc IN trydirs THEN BEGIN
               sq := board[x,y].adjacentsq[direc];
               sq := board[sq.row,sq.col].adjacentsq[direc];
               IF sq.onboard THEN BEGIN
                  direcflips := 1;
                  stopdirec := FALSE;
                  REPEAT
                     sqstatus := boardstatus[sq.row,sq.col];
                     IF sqstatus.occupied THEN
                        IF sqstatus.occupier = oppcolor THEN BEGIN
                           direcflips := direcflips + 1;
                           sq := board[sq.row,sq.col].adjacentsq[direc];
                           END
                        ELSE
                           stopdirec := TRUE
                     ELSE BEGIN
                        direcflips := 0;
                        stopdirec := TRUE;
                        END;
                     UNTIL ( stopdirec OR (NOT sq.onboard) );
                  IF (stopdirec AND (direcflips>0)) THEN BEGIN
                     flips := flips + direcflips;
                     gooddirs := gooddirs + [direc];
                     IF board[x,y].border AND board[sq.row,sq.col].border THEN
                        borderflips := borderflips + direcflips;
                     END;
                  END; (*IF sq.onboard...*)
               END; (*IF direc IN...*)
         IF flips > 0 THEN BEGIN
            movecount := movecount + 1;
            WITH okmove[movecount] DO BEGIN
               moveloc.onboard := TRUE;
               moveloc.row := x;
               moveloc.col := y;
               points := flips;
               dirsflipped := gooddirs;
               bordrsqsflipped := borderflips;
               END;
            END;
         END; (*IF possible...*)
      END; (*FOR x :=...FOR y :=...*)
   END; (*WITH status, legallist...*)
END; (*findlegalmoves*)

PROCEDURE inputmove(mover: color; legallist: movelist; VAR move: movedesc);
VAR
   x,y:                 coordinate;
   xch,ych:             CHAR;
   i,listindex:         INTEGER;
   c:                   CHAR;
BEGIN
listindex := 0;
REPEAT
   REPEAT
      GOTOXY(0,23);
      WRITE('Enter move for ',colorword[mover],':        ');
      GOTOXY(22,23);
      READ(xch,ych);
      IF ych IN ['1'..'8'] THEN BEGIN (*Want xy but we'll accept yx*)
         c := ych;
         ych := xch;
         xch := c;
         END;
      IF ych IN ['a'..'h'] THEN
         ych := CHR(ORD(ych)-32);
      UNTIL ((xch IN ['1'..'8']) AND (ych IN ['A'..'H']));
   x := ORD(xch) - ORD('1') + 1;
   y := ORD(ych) - ORD('A') + 1;
   i := 1;
   REPEAT
      IF legallist.okmove[i].moveloc.row = x THEN
         IF legallist.okmove[i].moveloc.col = y THEN
            listindex := i;
      i := i+1;
      UNTIL ((i>legallist.movecount) OR (listindex <> 0));
   UNTIL listindex <> 0;
move := legallist.okmove[listindex];
END; (*inputmove*)

PROCEDURE makemove(*VAR status: gamestatus; VAR move: movedesc; updateadjacent:
                                                                BOOLEAN*);
VAR
   direc,direc2:       direction;
   sq,sq2:             squareloc;
   oppcolor:           color;
   flips:              INTEGER;
   emptyneighbors:     SET of direction;
BEGIN
WITH status, move DO BEGIN
   lastmoveloc := moveloc;
   WITH boardstatus[moveloc.row,moveloc.col] DO BEGIN
      emptyneighbors := [north..nw] - adjacentpieces[white]
                                    - adjacentpieces[black];
      occupied := TRUE;
      occupier := nextmover;
      END;
   oppcolor := flipof(nextmover);
   flips := 0;
   FOR direc := north TO nw DO
      IF direc IN dirsflipped THEN BEGIN
         sq := board[moveloc.row,moveloc.col].adjacentsq[direc];
         REPEAT
            IF updateadjacent THEN
               FOR direc2 := north TO nw DO
                  IF NOT (direc2 IN [direc,opposdir[direc]]) THEN BEGIN
                     sq2 := board[sq.row,sq.col].adjacentsq[direc2];
                     IF sq2.onboard THEN WITH boardstatus[sq2.row,sq2.col] DO
                        IF NOT occupied THEN BEGIN
                           adjacentpieces[nextmover]:=adjacentpieces[nextmover]
                                                        + [opposdir[direc2]];
                           adjacentpieces[oppcolor]:=adjacentpieces[oppcolor]
                                                        - [opposdir[direc2]];
                           END;
                     END;
            boardstatus[sq.row,sq.col].occupier := nextmover;
            flips := flips + 1;
            sq := board[sq.row,sq.col].adjacentsq[direc];
            UNTIL boardstatus[sq.row,sq.col].occupier = nextmover;
         END
      ELSE
         IF updateadjacent THEN
            IF direc IN emptyneighbors THEN BEGIN
               sq := board[moveloc.row,moveloc.col].adjacentsq[direc];
               IF sq.onboard THEN
                  WITH boardstatus[sq.row,sq.col] DO
                     adjacentpieces[nextmover] := adjacentpieces[nextmover] + 
                                                  [opposdir[direc]];
               END;
   score[nextmover] := score[nextmover] + flips + 1;
   score[oppcolor]  := score[oppcolor] - flips;
   nextmover := oppcolor;
   END;
END; (*makemove*)



========================================================================================
DOCUMENT :usus Folder:VOL03:othell2.text
========================================================================================


PROCEDURE calcmove( mover: color; VAR status: gamestatus;
                   VAR legallist: movelist; VAR bestmove: movedesc);
TYPE
   movearray = ARRAY[1..30] OF movedesc;
VAR
   bestsofar,cornmoves,m,respcornmoves:         INTEGER;
   move,movetemp:                               movedesc;
   aftermove:                                   gamestatus;
   responses:                                   movelist;

PROCEDURE checkposition(VAR legallist: movelist; VAR cornmoves: INTEGER);
   VAR
      m,bestm,bestyet:  INTEGER;
   BEGIN
   bestyet := -MAXINT;
   cornmoves := 0;
   FOR m := 1 TO legallist.movecount DO WITH legallist.okmove[m],
                                             board[moveloc.row,moveloc.col] DO
      BEGIN
      bordnoncorn := FALSE;
      IF incenter4by4 THEN
         points := points + 10
      ELSE BEGIN
         IF corner THEN BEGIN
            points := points + 60;
            cornmoves := cornmoves + 1;
            END
         ELSE IF border THEN BEGIN
                 bordnoncorn := TRUE;
                 points := points + 25;
                 END
              ELSE IF diagnexttocorner THEN
                      points := points - 50;
         END;
      IF points > bestyet THEN BEGIN
         bestyet := points;
         bestm := m;
         end;
      END; (*FOR m := 1 TO legallist.movecount...*)
   movetemp := legallist.okmove[1];
   legallist.okmove[1] := legallist.okmove[bestm];
   legallist.okmove[bestm] := movetemp;
   END; (*checkposition*)

PROCEDURE sortmoves(VAR okmove: movearray;
                    l,r: INTEGER) (*into descending order by points*) ;
   VAR
      i,j,baseval:      INTEGER;
   BEGIN
   i := l;
   j := r;
   baseval := okmove[(i+j) DIV 2].points;
   REPEAT
      WHILE okmove[i].points > baseval DO
         i := i+1;
      WHILE okmove[j].points < baseval DO
         j := j-1;
      IF i <= j THEN BEGIN
         movetemp := okmove[i];
         okmove[i] := okmove[j];
         okmove[j] := movetemp;
         i := i+1;
         j := j-1;
         END;
      UNTIL i > j;
   IF l < j THEN sortmoves(okmove, l, j );
   IF i < r THEN sortmoves(okmove, i, r )
   END (* sortmoves *) ;

PROCEDURE checkresponses(mover: color; VAR move: movedesc;
                         VAR responses: movelist; bestsofar: INTEGER);
(*$G+*)
   LABEL 0;
   VAR
      contingent,c,r:                   INTEGER;
      x,y:                              coordinate;
      sq:                               squareloc;
      direc:                            direction;
      oppcolor:                         color;
      afterresp:                        gamestatus;
      cornercounter:                    BOOLEAN;
      respondmove:                      movedesc;
      counterresp:                      movelist;
   BEGIN
   oppcolor := flipof(mover);
   WITH move DO BEGIN
      contingent := 0;
      r := 1;
      REPEAT
         respondmove := responses.okmove[r];
         IF NOT board[moveloc.row,moveloc.col].incenter4by4 THEN
            FOR direc := north TO nw DO  WITH respondmove DO
               IF direc IN dirsflipped THEN  WITH moveloc DO
                  IF board[row,col].adjacentsq[direc] = move.moveloc THEN BEGIN
                      move.points := move.points - 5;
                      IF move.points <= bestsofar THEN
                         EXIT(checkresponses);
                      END;
         afterresp := aftermove;
         makemove(afterresp,respondmove,FALSE);
         IF bordnoncorn THEN  WITH moveloc DO
            IF afterresp.boardstatus[row,col].occupier = oppcolor THEN BEGIN
               bordnoncorn := FALSE;
               points := points - 65; (*40, plus the 25 given in checkposition*)
               IF points <= bestsofar THEN
                  EXIT(checkresponses);
               END
            ELSE
               contingent := contingent + 8*respondmove.bordrsqsflipped;
         WITH respondmove.moveloc DO
            IF board[row,col].corner THEN BEGIN
               points := points - 55;
               IF cornmoves > 1 THEN
                  IF board[moveloc.row,moveloc.col].corner THEN
                     points := points -20;
               IF points <= bestsofar THEN
                  EXIT(checkresponses);
               END;
         FOR x:=1 TO 8 DO FOR y:=1 TO 8 DO WITH afterresp.boardstatus[x,y] DO
            IF occupied THEN
               IF occupier = mover THEN
                  FOR direc := north TO nw DO WITH afterresp DO BEGIN
                     sq.row := x;
                     sq.col := y;
                     REPEAT
                        sq := board[sq.row,sq.col].adjacentsq[direc];
                        IF NOT sq.onboard THEN
                           GOTO 0;
                        IF NOT boardstatus[sq.row,sq.col].occupied THEN
                           GOTO 0
                        UNTIL boardstatus[sq.row,sq.col].occupier = oppcolor;
                     END;
         makemove(afterresp,respondmove,TRUE);
         findlegalmoves(afterresp,counterresp);
         cornercounter := FALSE;
         c := 1;
         WITH counterresp DO
            WHILE ( (c <= movecount) AND (NOT cornercounter) ) DO BEGIN
               WITH okmove[c].moveloc DO
                  IF board[row,col].corner THEN
                     cornercounter := TRUE;
               c := c + 1;
               END;
         IF NOT cornercounter THEN BEGIN
            points := points -190;
            IF points <= bestsofar THEN
               EXIT(checkresponses);
            END;
0:
         IF afterresp.score[mover] = 0 THEN BEGIN
            points := -MAXINT+1; (*might be our only choice, so +1*)
            EXIT(checkresponses);
            END;
         r := r + 1;
         UNTIL r > responses.movecount;
      IF bordnoncorn THEN BEGIN
         points := points - contingent;
         WITH board[moveloc.row,moveloc.col] DO
            IF specialbordersq THEN WITH otherofpair,
                                         status.boardstatus[row,col] DO
               IF occupied THEN
                  IF occupier = mover THEN
                     WITH status.boardstatus[between.row,between.col] DO
                        IF NOT occupied THEN
                           points := points - 90;
         END;
      END; (*WITH move...*)
   END; (*checkresponses*)
   
BEGIN (*calcmove*)
GOTOXY(0,23);
WRITE('Calculating move for ',colorword[mover],'...');
checkposition(legallist,cornmoves);
IF legallist.movecount > 2 THEN
   sortmoves(legallist.okmove,2,legallist.movecount);
bestsofar := -MAXINT;
FOR m := 1 TO legallist.movecount DO BEGIN
   move := legallist.okmove[m];
   aftermove := status;
   makemove(aftermove,move,TRUE);
   findlegalmoves(aftermove,responses);
   WITH move DO BEGIN
      IF responses.movecount = 0 THEN
         points := points + 100
      ELSE
         IF points > bestsofar THEN BEGIN
            checkposition(responses,respcornmoves);
            checkresponses(mover,move,responses,bestsofar);
            END;
      IF points > bestsofar THEN BEGIN
         bestsofar := points;
         bestmove := move;
         END;
      END; (*WITH move...*)
   END; (*FOR m := 1 TO legallist.movecount...*)
END; (*calcmove*)

PROCEDURE play(mover: color);
BEGIN
GOTOXY(0,20+ORD(mover));
IF legalmoves[mover] > 0 THEN BEGIN
   WRITE(spaces);
   IF mover = usercolor THEN
      inputmove(mover,legallist,move)
   ELSE
      calcmove(mover,status,legallist,move);
   makemove(status,move,TRUE);
   updatecrt(crtstatus,status);
   crtstatus := status;
   END
ELSE BEGIN
   WRITE('(No legal moves for ',colorword[mover],')');
   status.nextmover := flipof(mover);
   END;
END; (*play*)

FUNCTION userquits: BOOLEAN;
VAR
   playagain:        CHAR;
BEGIN
GOTOXY(0,20);
WRITELN(spaces); WRITELN(spaces); WRITELN; WRITE(spaces);
GOTOXY(0,23);
WRITE('Start a new game? (y/n): ');
READ(playagain);
userquits := NOT (playagain IN ['Y','y']);
END; (*userquits*)



========================================================================================
DOCUMENT :usus Folder:VOL03:othellinit.text
========================================================================================

(* COPYRIGHT (C) 1979 Software Supply.  All rights reserved.  *)
(* included file for OTHELLO *)

PROCEDURE updatecrt(VAR oldstatus,newstatus: gamestatus);
FORWARD;
FUNCTION flipof(oldcolor: color): color;
FORWARD;
PROCEDURE makemove(VAR status: gamestatus; VAR move: movedesc; updateadjacent:
                                                                BOOLEAN);
FORWARD;

SEGMENT PROCEDURE initgame;
CONST
   backspace = 8;
VAR
   x,y:         coordinate;
   direc:       direction;
   answer:      CHAR;
   h,l,h0,l0:   INTEGER; (*for testing whether clock is on*)

   PROCEDURE defineboard;
   BEGIN
   FOR x := 1 TO 8 DO  FOR y := 1 TO 8 DO  WITH board[x,y] DO BEGIN
      border := (x IN [1,8]) OR (y IN [1,8]);
      corner := (x IN [1,8]) AND (y IN [1,8]);
      incenter4by4 := (x IN [3..6]) AND (y IN [3..6]);
      diagnexttocorner := (x IN [2,7]) AND (y IN [2,7]);
      FOR direc := north TO nw  DO WITH adjacentsq[direc] DO BEGIN 
         CASE direc OF
            north: onboard := x>1;
            ne:    onboard := (x>1) AND (y<8);
            east:  onboard := y<8;
            se:    onboard := (x<8) AND (y<8);
            south: onboard := x<8;
            sw:    onboard := (x<8) AND (y>1);
            west:  onboard := y>1;
            nw:    onboard := (x>1) AND (y>1);
            END; (*CASE*)
         IF onboard THEN BEGIN
            CASE direc OF
               north,ne,nw: row := x-1;
               east,west:   row := x;
               south,se,sw: row := x+1;
               END;
            CASE direc OF
               nw,west,sw:  col := y-1;
               north,south: col := y;
               ne,east,se:  col := y+1;
               END;
            END;
         END; (*FOR direc...WITH adjacentsq...*)
      specialbordersq := border AND (NOT corner) AND 
                            ( (x IN [2,4,5,7]) OR (y IN [2,4,5,7]) );
      IF specialbordersq THEN BEGIN
         otherofpair.onboard := TRUE;
         between.onboard := TRUE;
         IF x IN [1,8] THEN BEGIN
            otherofpair.row := x;
            between.row := x;
            IF y IN [2,5] THEN BEGIN
               otherofpair.col := y+2;
               between.col := y+1;
               END
            ELSE BEGIN
               otherofpair.col := y-2;
               between.col := y-1;
               END;
            END
         ELSE BEGIN
            otherofpair.col := y;
            between.col := y;
            IF x IN [2,5] THEN BEGIN
               otherofpair.row := x+2;
               between.row := x+1;
               END
            ELSE BEGIN
               otherofpair.row := x-2;
               between.row := x-1;
               END;
            END;
         END; (*IF specialbordersq...*)
      END; (*FOR x:= ... FOR y:= ... WITH board[x,y]...*)
   END; (*defineboard*)
    
   PROCEDURE showemptyboard;
   CONST
      vertdivs = '|     |     |     |     |     |     |     |     |';
      horzdivs = '|-----|-----|-----|-----|-----|-----|-----|-----|';
      colnames = '   A     B     C     D     E     F     G     H   ';
      blanks   = '                              ';
   VAR
      gamerow :    coordinate;
   BEGIN
   GOTOXY(0,0);
   FOR gamerow := 1 TO 8 DO BEGIN
      IF gamerow>1 THEN (* "IF" because no room for topmost border line *)
         writeln(blanks,horzdivs);
      writeln(blanks:29,gamerow,vertdivs);
      writeln(blanks,vertdivs);
      END;
   write(blanks,colnames);
   GOTOXY(4,0);
   WRITELN('Score');
   WRITELN('-----------');
   WRITELN(CHR(whiteascii),'/White:');
   WRITELN(CHR(blackascii),'/Black:');
   END; (*showemptyboard*)
  
   PROCEDURE instructions;
   VAR
      i: INTEGER;
   PROCEDURE page1;
      BEGIN
      WRITELN('A move consists of placing  ');
      WRITELN('one of your pieces on an    ');
      WRITELN('unoccupied square which is  ');
      WRITELN('adjacent (vertically, hori- ');
      WRITELN('zontally, or diagonally) to ');
      WRITELN('a square occupied by your   ');
      WRITELN('opponent so that a straight ');
      WRITELN('line starting at your piece ');
      WRITELN('and continuing in the direc-');
      WRITELN('tion of the adjacent oppon- ');
      WRITELN('ent hits one of your other  ');
      WRITELN('pieces before hitting an un-');
      WRITELN('occupied square.  All of the');
      WRITELN('opponent''s pieces which that');
      WRITELN('line crosses are converted  ');
      WRITELN('to become your pieces.  Thus');
      WRITELN('each move "flips" at least  ');
      WRITELN('one opposing piece.         ');
      WRITE  (' (Tap space bar for more...)');
      END; (*page1*)
   PROCEDURE page2;
      BEGIN
      WRITELN('Example:  a legal move for  ');
      WRITELN('white on the first play     ');
      WRITELN('would be 3E, 4F, 6D, or 5C. ');
      WRITELN('To make a move at, e.g., 3E ');
      WRITELN('you may type any of: 3E, 3e,');
      WRITELN('E3, or e3.                  ');
      WRITELN('If you have no legal move,  ');
      WRITELN('you must pass.  The object  ');
      WRITELN('of the game is to end up    ');
      WRITELN('occupying more squares than ');
      WRITELN('does your opponent.         ');
      WRITELN('Hints on strategy:  Usually ');
      WRITELN('the board position of a move');
      WRITELN('is more important than the  ');
      WRITELN('number of pieces it "flips".');
      WRITELN('Try to occupy the borders   ');
      WRITELN('(especially corners!) and   ');
      WRITELN('avoid giving them to your   ');
      WRITE  ('opponent. (Tap space bar...)');
      END; (*page2*)
   BEGIN (*instructions*)
   GOTOXY(0,5);
   WRITE('Want instructions? (y/n): ');
   READ(answer);
   IF NOT (answer IN ['N','n']) THEN BEGIN
      GOTOXY(0,5);
      page1;
      READ(answer);
      GOTOXY(0,5);
      page2;
      READ(answer);
      GOTOXY(0,5);
      FOR i := 5 TO 22 DO
         WRITELN(spaces);
      WRITE(spaces);
      END
   ELSE BEGIN
      GOTOXY(0,5);
      WRITE(spaces);
      END;
   END; (*instructions*)
      
BEGIN (*initgame*)
lastchange := 0;
TIME(h0,l0);
defineboard;
FOR direc := north TO NW DO
   IF odd(ORD(direc)) THEN
      opposdir[direc] := pred(direc)
   ELSE
      opposdir[direc] := succ(direc);
TIME(h,l);
IF (h=h0) AND (l=l0) THEN BEGIN
   GOTOXY(20,11);
   WRITE('Please turn on the clock.');
   WHILE l=l0 DO
      TIME(h,l);
   END;
showemptyboard;
WITH status DO BEGIN
   score[white] := 0;
   score[black] := 0;
   FOR x := 1 TO 8 DO  FOR y := 1 TO 8 DO WITH boardstatus[x,y] DO BEGIN
      occupied := FALSE;
      adjacentpieces[white] := [];
      adjacentpieces[black] := [];
      END;
   END;
crtstatus := status;
move.dirsflipped := [];
move.points := 0;
WITH status DO BEGIN
   FOR x := 4 TO 5 DO  FOR y := 4 TO 5 DO BEGIN
      move.moveloc.row := x;
      move.moveloc.col := y;
      IF x=y THEN
         nextmover := white
      ELSE
         nextmover := black;
      makemove(status,move,TRUE);
      updatecrt(crtstatus,status);
      crtstatus := status;
      END; (*FOR...FOR...*)
   nextmover := white;
   END; (*WITH status...*)
instructions;
GOTOXY(0,6);
WRITELN('White goes first -- Which');
WRITELN('color do you want to play:');
REPEAT
   GOTOXY(3,8);
   WRITE('W)hite or B)lack?  ',CHR(backspace));
   READ(answer);
   UNTIL answer IN ['W','w','B','b'];
IF answer IN ['W','w'] THEN
   usercolor := white
ELSE 
   usercolor := black;
GOTOXY (0,6);
WRITELN(spaces); WRITELN(spaces); WRITELN(spaces);
colorword[white] := 'white';
colorword[black] := 'black';
END; (*initgame*)


========================================================================================
DOCUMENT :usus Folder:VOL03:othello.text
========================================================================================

(* COPYRIGHT (C) 1979 Software Supply.  All rights reserved. *)
(*$S+*)
(* UCSD Pascal *) PROGRAM OTHELLO; (* Steve Brecher 16-Jun-79 *)

(* The position evaluation weights were derived from a FORTRAN program   *)
(* headed "from Creative Computing/Klaus E Liebold/4-26-78".             *)

(* This program provides playing instructions to the user on request.    *)

CONST
   (* The game pieces are shown on the screen as 2 rows of 3 characters, e.g. *)
   (*                          OOO                                            *)
   (*                          OOO                                            *)
   (* If your crt has a "block" character (like the cursor on some crts), that*)
   (* is good for the white piece, and capital letter O is good for black,    *)
   (* especially if it has a rectangular shape.  Otherwise, choose characters *)
   (* that are centered within the character dot matrix; try to maximize the  *)
   (* difference in intensity between the black and white pieces while maxi-  *)
   (* mizing the absolute intensity of the black piece.  Avoid characters with*)
   (* semantic content, e.g. "W" and "B" are not so good.                     *)
   whiteascii = 96;     (*ascii value of char making up piece of first mover*)
   blackascii = 79;     (*  "     "   "   "     "     "    "   " 2nd    "   *)
   minticks   = 22.0;   (*min # clock ticks between crt square updates      *)
                        (*--should be long enough for a distinct, separate  *)
                        (*terminal bell sound on each square updated        *)
   spaces     = '                             ';
   
TYPE
   coordinate   = 1..8;
   color        = (white,black);
   squareloc    = RECORD
                    CASE onboard: BOOLEAN OF
                      TRUE:            (row,col:        coordinate);
                    END;
   direction    = (north,south,east,west,sw,ne,se,nw); (*pairs of opposites*)
   squarestatus = RECORD
                    CASE occupied: BOOLEAN OF
                      TRUE:  (occupier:       color                           );
                      FALSE: (adjacentpieces: ARRAY[color] OF SET of direction);
                    END;
   gamestatus   = RECORD
                    boardstatus:  ARRAY[coordinate,coordinate] OF squarestatus;
                    nextmover:    color;
                    lastmoveloc:  squareloc;
                    score:        ARRAY[color] OF INTEGER;
                    END;
   movedesc     = RECORD
                    moveloc:            squareloc;
                    points:             INTEGER;
                    dirsflipped:        SET OF direction;
                    bordrsqsflipped:    INTEGER;
                    bordnoncorn:        BOOLEAN;
                    END;
   movelist     = RECORD
                    movecount:          INTEGER;
                    okmove:             ARRAY[1..30] OF movedesc;
                    END;
   position     = RECORD
                    border:             BOOLEAN;
                    corner:             BOOLEAN;
                    diagnexttocorner:   BOOLEAN;
                    incenter4by4:       BOOLEAN;
                    adjacentsq:         ARRAY[direction] OF squareloc;
                  (* "special" border squares are those border squares        *)
                  (* adjacent to a corner or adjacent to board midline; there *)
                  (* are 2 pairs of such squares on each border. Sample pair: *)
                  (* (1,2) and (1,4); for each we want a pointer to the other *)
                  (* and to the border square between them (1,3).             *)
                    CASE specialbordersq: BOOLEAN OF
                      TRUE:             (otherofpair,between:  squareloc);
                    END;


VAR
   board:                       ARRAY[coordinate,coordinate] OF position;
   status,crtstatus:            gamestatus;
   square:                      squareloc;
   legallist:                   movelist;
   move:                        movedesc;
   opposdir:                    ARRAY[direction] OF direction;
   legalmoves:                  ARRAY[color] OF INTEGER;
   colorword:                   ARRAY[color] OF STRING[5];
   usercolor:                   color;
   lastchange:                  REAL; (*time of last square change on crt*)

(*$I OTHELLINIT*)
(*$I OTHELL1*)
(*$I OTHELL2*)

BEGIN (*PROGRAM OTHELLO*)
REPEAT
   initgame;
   findlegalmoves(status,legallist);
   legalmoves[white] := legallist.movecount;
   REPEAT
      play(white);
      findlegalmoves(status,legallist);
      legalmoves[black] := legallist.movecount;
      play(black);
      findlegalmoves(status,legallist);
      legalmoves[white] := legallist.movecount;
      UNTIL (legalmoves[white]=0) and (legalmoves[black]=0);
   UNTIL userquits;
END.


========================================================================================
DOCUMENT :usus Folder:VOL03:policy.doc.text
========================================================================================


     INTERIM POLICY OF THE UCSD PASCAL USERS' GROUP LIBRARY

Obtaining Library Software.

     Floppy disks full of donated Pascal programs are available from the
Library as follows:

     8-inch, single-sided, single-density UCSD- or CP/M-format disks are $10 
each postpaid (California residents MUST add 6% sales tax; Canadian and
Mexican recipients should add $3 per order for the extra hassle involved;
other out-of-country sales must add $8 for the first disk of an order and
$1.50 per each additional disk to cover air mail) from Jim Gagne, Datamed
Research, 1433 Roscomare Road, Los Angeles CA 90024. Both UCSD Pascal and CP/M-
compatible Pascals are supported, though UCSD programs will require
modification to run under other systems.

     5-1/4 inch diskettes of UCSD software (2 or 3 are required to hold an 8-
inch volume) are available from Bruce Sherman, SofTech Microsystems, 9494
Black Mountain Road, San Diego CA 92126.  Pricing is not yet established, but
will probably exceed $20 per volume due to order processing costs.  (We are
looking for volunteers to distribute the various 5-1/4 inch formats so we can
offer them at lower cost.) Software of interest only to users of certain 
systems will as a rule not be distributed to incompatible systems.  Contact
Bruce for further information.

     Western Digital has indicated an interest in distributing Users' Group 
software on 8-inch disks compatible with the Microengine (these are NOT UCSD 
compatible because of differences in disk sectoring).  In addition, they can 
provide Microengine users with software that will enable them to convert UCSD
standard disks on their machines.  Contact them directly for more information.

     You can obtain a free disk volume of your choice by donating software to
the group if the software is accepted (see below).

     Any user may copy Users' Group software and give it away to others FREE
for nothing.  This includes OEM's and retailers.  However, if any charge
whatsoever is made to the recipient of the software, then: 1) the maximum
charge is limited to a $5 fee per volume plus the retail cost of each floppy
disk and 2) the Users' Group must be reimbursed $2 per disk volume sold.  (A
disk volume is the contents of one 8-inch, single-sided, single-density
diskette.) These charges apply no matter how indirectly the seller obtains
Users' Group software.  These editing fees should be paid to Datamed Research
at the above address, within a month's time of the sale.

     All software is furnished with the understanding that no one may sell it
for profit without the written consent of the author.  In addition, the 
software MAY NOT be copied without continuing to carry whatever statements of
authorship it may now contain.  Finally, despite hard work to maintain the 
highest standards possible, we of course cannot guarantee in any way that
programs obtained from the Users' Group Library will be suitable for your
intended purpose.

     
Submitting Software.

     We are interested in receiving software from anyone who may wish to 
contribute.  Every type of program is welcomed, and we are particularly eager
to receive donations of software tools: those procedures and programs you
have developed to make your programming simpler and more productive, and
which may be of broad interest to the Pascal community.  Such items as double-
precision integer packages, business math routines, generic input/output
processing, program timers and debuggers, system utilities, and reports of
specific techniques to speed UCSD programs are particularly desired.  It is
clear that if we can all develop the habit of donating particularly useful
tools to the Users' Group, a broad base of software support will quickly
develop which will benefit us all enormously.

     To be accepted, software must: 1) be in source form, 2) be relatively 
free of bugs, 3) be reasonably clearly written and documented so that it may
be easily modified, 4) come with sufficient instructions so that we can use
it, 5) be capable of being placed in the public domain, and 6) not have been
received previously from someone else.  If you have an especially long program
or one that is for some reason tricky to compile, you may wish to submit
object code as well as source.  Certain items may be submitted in object form
only: if you have a quality program undergoing development that you eventually
wish to sell, we would be willing to pilot it for you if it is of sufficient
interest to the group at large and works moderately well.  I am certain many
members would enjoy writing you with their comments, and you should wind up
with a product of much higher quality in a much shorter time than is the rule.

     We are also interested in reports of bugs in the system or user software
(preferably with fixes or kludges to get around them) and documentation of the
more obscure aspects of UCSD Pascal.

     
Editors.

     Many people have written to UCSD and SofTech wishing to assist in the
organization of a users group library.  We think this is grand.  Because it
makes little sense for the collection and distribution of programs to be
scattered all around the country, we plan to set up the following structure
for now and see how it works: Anyone who wishes to collect a disk full of
software may submit it to the Users' Group (send them to Datamed Research; 8-
inch diskettes preferred).  Fundamentally, the requirements for the acceptance
for the software are those stated previously; in addition, the disk editor
must have checked out the programs and organized them in some way.  You
should have a catalog of the files on the disk, and a separate file
containing: 1) descriptions of each program, 2) what you think of it, and 3)
any remaining documentation required for use.  Note that we are specifically
committed to full and complete documentation ON THE DISK whenever possible.
Programs should be of general interest, although it is all right to include
hardware-specific programs if they solve a pressing need.  (I would prefer to 
put most of the hardware-specific material on a special disk, which users can
ignore if they wish.)

     If you submit a disk that is reasonably well put together, you will: 1) 
be listed as editor of that volume, 2) receive $1 for each disk SOLD
(remember, many will be given to friends), and 3) be placed on the official
UCSD Pascal Users' Group Library Roster of Editors, and receive all past and
future volumes of the Users' Group library, so we can coordinate our efforts. 
(I reserve the right not to send you ALL the Users' Group volumes if this
thing gets too big and you haven't contributed for a while.) A word of
warning: most of the Pascal disks now floating around have much less work put
into them than we feel is required for them to be generally useful. I, in
particular, am a FANATIC about making our products helpful and/or fun to
programmers of various persuasions.  So the $1 payment per disk is intended to
reimburse you in part for the very real effort required to create a disk with
truly useful contents.

========================================================================================
DOCUMENT :usus Folder:VOL03:requests.text
========================================================================================

     
         SOME REQUESTS FOR PASCAL SOFTWARE FOR THE USERS' GROUP LIBRARY

     As a programmer, what I like most is a challange that requires careful
thought to carry off, yet is of manageable size and will make a definite
contribution to the efforts of others.  So I thought I'd offer you some
programming challenges:

     A.  A directory program that would be called up from the Command level 
(not in the filer), and display the contents of a disk in two or three 
alphabetized columns in one screenful.  The size of each file would be 
included, and perhaps the date.  Following the named files, one would list
the unutilized areas of a disk individually, by block range and size. 
For example, an unused area might be indicated in the following manner: 
"<400-450 empty>   51", where the "51" would line up with the blocks per file
column. A summary line at the bottom would list the total number of files and
the vacant space on the disk.  To save time, you would invoke the directory of
a given disk simply by typing the unit number desired.  For example, typing
"X(ecute) 4 <carriage return>" would produce the directory of the main disk
drive.

     B. We need a library of procedures to BLOCKREAD and BLOCKWRITE untyped
files, then CREAD (or whatever name you want) a character, LNREAD a line, and
CWRITE and LNWRITE respectively.  Not only would this markedly expedite
textfile handling in the present P-code Pascals that support untyped files,
but these procedures are the ONLY way to access files with the present native-
code compilers that run on micros.

     C. We need a good double-precision integer package written in Standard 
Pascal to augment the present inadequate limitations of MAXINT.

     D. We need a package of input/output procedures for money (usually 
represented as integer cents), so the user can type a decimal point and not
confuse the computer.  A nice touch is to have the cursor stay put at the
dollar units position of the number to be entered, and have the number of
dollars grow to the left as it is typed in. Then, when the decimal point is
typed, the cursor steps to the right one character at a time as the user fills
in the cents value.

     E. Someone interested in mathematics should tackle a complex-number
package.

     F. A simple "data base system" consisting of: 1) a means to define the
names of a number of fields, 2) a way of entering/correcting data within each
field, 3) successive or random access to records, 4) a disk sort by a single
field (if you wanted multiple fields in order you'd do multiple sorts), and 5)
a key extraction program, where one would make a subfile consisting of all
the records in the main file that had one field equal to a certain value or
falling within a certain range.  As an alternative to sorting the records
themselves, one could use an ISAM approach.

     Because Pascal saves textfiles as lines with dynamic length terminated by 
an end-of-line character, the easiest and most space-saving way to represent
the data would be as ASCII strings.  The program could be very general if the
zeroth record in a data file defined the data:

first  line:    Number of elements per record (in ASCII) (call it "n"). 
second line:    Name of first element, and perhaps an ASCII code of data type.
. . .           . . . 
nth    line:    Name and type code of n-1th element.
n+1th  line:    Name and type code of nth element.

     Then, each successive record might begin with an ASCII record number and 
the actual data of each record element, all of dynamic length.  So you'd never
have to specify field width; you would simply be limited by the maximum
length of the character array or string when the data was in memory.

========================================================================================
DOCUMENT :usus Folder:VOL03:snoopy.text
========================================================================================

1
-
-
                      XXXX
                     X    XX
                    X  ***  X                XXXXX
                   X  *****  X            XXX     XX
                XXXX ******* XXX      XXXX          XX
              XX   X ******  XXXXXXXXX                XX XXX
            XX      X ****  X                           X** X
           X        XX    XX     X                      X***X
          X         //XXXX       X                      XXXX
         X         //   X                             XX
        X         //    X          XXXXXXXXXXXXXXXXXX/
        X     XXX//    X          X
        X    X   X     X         X
        X    X    X    X        X
         X   X    X    X        X                    XX
         X    X   X    X        X                 XXX  XX
          X    XXX      X        X               X  X X  X
          X             X         X              XX X  XXXX
           X             X         XXXXXXXX\     XX   XX  X
            XX            XX              X     X    X  XX
              XX            XXXX   XXXXXX/     X     XXXX
                XXX             XX***         X     X
                   XXXXXXXXXXXXX *   *       X     X
                                *---* X     X     X
                               *-* *   XXX X     X
                               *- *       XXX   X
                              *- *X          XXX
                              *- *X  X          XXX
                             *- *X    X            XX
                             *- *XX    X             X
                            *  *X* X    X             X
                            *  *X * X    X             X
                           *  * X**  X   XXXX          X
                           *  * X**  XX     X          X
                          *  ** X** X     XX          X
                          *  **  X*  XXX   X         X
                         *  **    XX   XXXX       XXX
                        *  * *      XXXX      X     X
                       *   * *          X     X     X
         =======*******   * *           X     X      XXXXXXXX\
                *         * *      /XXXXX      XXXXXXXX\      )
           =====**********  *     X                     )  \  )
             ====*         *     X               \  \   )XXXXX
        =========**********       XXXXXXXXXXXXXXXXXXXXXX
        
        
                          Happy New Year, Red Baron!
                          
                          
                          
                              JANUARY                       FEBRUARY                       MARCH
  
                               1  2  3  4  5                          1  2                             1
  
                         6  7  8  9 10 11 12           3  4  5  6  7  8  9           2  3  4  5  6  7  8
  
                        13 14 15 16 17 18 19          10 11 12 13 14 15 16           9 10 11 12 13 14 15
  
                        20 21 22 23 24 25 26          17 18 19 20 21 22 23          16 17 18 19 20 21 22
  
                        27 28 29 30 31                24 25 26 27 28 29             23 24 25 26 27 28 29
  
                                                                                    30 31 
  
  
                               APRIL                          MAY                           JUNE
  
                               1  2  3  4  5                       1  2  3           1  2  3  4  5  6  7
  
                         6  7  8  9 10 11 12           4  5  6  7  8  9 10           8  9 10 11 12 13 14
  
                        13 14 15 16 17 18 19          11 12 13 14 15 16 17          15 16 17 18 19 20 21
  
                        20 21 22 23 24 25 26          18 19 20 21 22 23 24          22 23 24 25 26 27 28
  
                        27 28 29 30                   25 26 27 28 29 30 31          29 30 
  
  
  
  
                                JULY                         AUGUST                      SEPTEMBER
  
                               1  2  3  4  5                          1  2              1  2  3  4  5  6
  
                         6  7  8  9 10 11 12           3  4  5  6  7  8  9           7  8  9 10 11 12 13
  
                        13 14 15 16 17 18 19          10 11 12 13 14 15 16          14 15 16 17 18 19 20
  
                        20 21 22 23 24 25 26          17 18 19 20 21 22 23          21 22 23 24 25 26 27
  
                        27 28 29 30 31                24 25 26 27 28 29 30          28 29 30
  
                                                      31
  
  
                              OCTOBER                       NOVEMBER                      DECEMBER
  
                                  1  2  3  4                             1              1  2  3  4  5  6
  
                         5  6  7  8  9 10 11           2  3  4  5  6  7  8           7  8  9 10 11 12 13
  
                        12 13 14 15 16 17 18           9 10 11 12 13 14 15          14 15 16 17 18 19 20
  
                        19 20 21 22 23 24 25          16 17 18 19 20 21 22          21 22 23 24 25 26 27
  
                        26 27 28 29 30 31             23 24 25 26 27 28 29          28 29 30 31 
  
  
  
  

========================================================================================
DOCUMENT :usus Folder:VOL03:store.data
========================================================================================

< binary file -- not listed >

========================================================================================
DOCUMENT :usus Folder:VOL03:universal.text
========================================================================================


                     A SUGGESTION FOR A UNIVERSAL I/O UNIT

     Most of the UCSD Pascal programs that I have seen have a monotonous 
beginning consisting of hardware-specific procedures like CLEARSCREEN, 
EraseToEndOfLine, EraseToEndOfScreen, etc., required for any application that 
manipulates data on the CRT screen.  It means you always have to diddle with 
a new program before you can use it.  Although this information should be
readily available in SYSCOM, where the system functions have access to it, the
implementors of UCSD Pascal did not see fit to allow us to get at it easily.
Direct reference to the SYSCOM variables requires you to compile in the
variable declarations in GLOBALS.TEXT, then switch to the (*$U-*) compiler
option, so the compiler knows what SYSCOM^ refers to.  This is clumsy, and it
is not easy to debug software with all the checking turned off (the U- option
disables i/o checking and rangechecking).

     There are alternate ways to get at the information in SYSCOM, such as the 
routine recently published in Dr. Dobb's to read in the SYSTEM.MISCINFO file.
Programmers writing proprietary software will have to do something like this
during initialization if their productions are to use the CRT efficiently. But
there is additional problem: many programs rely on hardware-specific functions
not implemented in SYSCOM.  For example, quite a number of authors have
included routines to test if a console key has been pressed without having to
READ a character and thus hang up a program until someone types something. 
This allows optional user interaction with an ongoing program. Other programs,
such as modem controllers, read and write data to specific hardware ports. 
Finally, it would be nice to have a random-number seed available directly from
the hardware, so we don't always have to "Type a number" to begin a game.

     It seems elementary for the UCSD Pascal user community to agree on a 
minimal series of functions, which we would all include in our SYSTEM.LIBRARY. 
You would be free to add more, but at least you would be able to link the 
standard functions into your applications programs without having to fiddle
with source code.

     If we all implemented a UNIT UNIVERSAL_IO, all your application program 
would have to say is "USES UNIVERSAL_IO", and you've included all the
necessary functions.

     Here is a partial example of the way someone may implement such a UNIT:

UNIT UNIVERSAL_IO;

INTERFACE

TYPE  BYTE = 0..255;


FUNCTION KeyPress: BOOLEAN; 
FUNCTION InPort (PORTNO: BYTE): CHAR;
PROCEDURE OutPort (PORTNO: BYTE; CH: CHAR);
PROCEDURE ClearScreen;
PROCEDURE ClrToScreenEnd;
PROCEDURE ClrToLineEnd;


IMPLEMENTATION

FUNCTION READY: BOOLEAN; EXTERNAL;
{an assembly language routine that returns a "1" if a console key 
 has been pressed}

FUNCTION GetPort (PORTNO: BYTE): CHAR; EXTERNAL;
{this assy-language routine reads a character from a specific port}

PROCEDURE SendPort (PORTNO: BYTE; CH: CHAR); EXTERNAL;
{this assy-language routine puts out a chararacter to a specific port}


FUNCTION KeyPress;
BEGIN
  KeyPress := READY;
END;

FUNCTION InPort;
BEGIN
  InPort := GetPort (PORTNO);
END;

PROCEDURE OutPort;
BEGIN
  SendPort (PORTNO, CH);
END;

PROCEDURE ClearScreen;
VAR Chrbuf: PACKED ARRAY [0..1] OF CHAR;
BEGIN
  Chrbuf [0] := CHR (12);
  UNITWRITE (1, Chrbuf, 1)
END;

PROCEDURE ClrToScreenEnd;
BEGIN
. . .
END;

PROCEDURE ClrToLineEnd;
BEGIN
. . . 
END;

END.


     Of course, the implementation would vary from system to system.  And this 
would be one more thing that you would have to write and debug before you 
could use UCSD Pascal Library software.  But you have to alter the procedures 
other authors have included in their programs already!!

     In addition to the procedures and functions listed above, we should 
include FUNCTION RandomByte, which would return a random value from 0 to 255
(e.g., the contents of the Z-80 R register; the lowest byte of the system
clock if you don't reset it every time you do something; or the contents of an
address in RAM that is not used by the system but is different every time you
turn on your machine).

     
     I specifically do NOT want to implement PEEK and POKE, since we do not 
need them to pass parameters to assembly language routines or anything else.

     Let me know what you think....

     Sincerely,

     Jim Gagne, DATAMED RESEARCH.


========================================================================================
DOCUMENT :usus Folder:VOL04:catalog.4.text
========================================================================================


                UCSD PASCAL USERS' LIBRARY -**- VOLUME 4 CATALOG
          The long-awaited Bowles Database seed, plus other utilities.
                Also info on the new UCSD System Users' Society.
        
    Name        Blocks                      Description

DBBUILDER.TEXT    38    Part of K. Bowles' database seed.
DBUNIT.TEXT        4    The major data accessing routines, allowing records of
                          variable size and user-defined linkage & nesting.
DBUNIT.1.TEXT     18            Subfile of DBUNIT
DBUNIT.2.TEXT     32               "    "    "
DBUNIT.3.TEXT     34               "    "    "
DBUNIT.4.TEXT     30               "    "    "
KB.DATABASE.DOC   74    A detailed class manual to show you how to use it.
KB.DBDEMO.TEXT     4    Demo program to further document the system.
KB.SCUNIT.TEXT    16    Screen control unit with some very nice screen i/o.
KB.STARTER.TEXT   30    Help set up the data structures.
KB.TESTDB         32    A test database data file, used by DBDEMO.

COMPARE.TEXT      34    From the Pascal News No. 12; prints out textfile diff's.
COMPRESS.TEXT      8    Compress leading/strip trailing blanks; shrink files.
INDEX.TEXT        24    Expanded index to Jensen & Wirth--now you can find it.

USUS.NEWS.TEXT    20    Learn all about the UCSD System Users' Society.

VOLUME.4.TEXT     14    Commentary on the files on this disk.

WUMPUS.TEXT       28    The game of Wumpus, elegantly implemented.
TEACH.WUMPUS      10    Documentation on the wunders of Wumpus.
WUMP.CAVE0.TEXT    4    One of several cave configurations you can select from
WUMP.CAVE1.TEXT    4      within the game; if you get bored with one, try
WUMP.CAVE2.TEXT    4      another.
WUMP.CAVE3.TEXT    4      . . .
WUMP.CAVE4.TEXT    4      . . .  This one's hard.
WUMP.CAVE5.TEXT    4      . . .  This one's hard, too.

     Please note:  all software is for noncommercial use only.  It may NOT be
sold without the author's written permission.  Do not remove statements of
origin/authorship from program listings.


========================================================================================
DOCUMENT :usus Folder:VOL04:compare.text
========================================================================================

{*      COMPARE - Compare two text files and report their differences. 
*
*       Copyright (C) 1977, 1978
*       James F. Miner
*       Social Science Research Facilities Center
*       University of Minnesota
*
*       General permission to make fair use in non-profit activities
*       of all or part of this material is granted provided that
*       this notice is given. To obtain permission for other uses
*       and/or machine readable copies write to:
*
*               The Director
*               Social Science Research Facilities Center
*               25 Blegen Hall
*               269 19th Ave. So.
*               University of Minnesota
*               Minneapolis, Minnesota  55455
*               U S A
}


{*      Compare is used to display on "Output" the differences
*       between two similar texts ("Filea" and "Fileb"). Notable
*       characteristics are:
*
*       - Compare is line oriented. The smallest unit of comparison
*         is the text line (ignoring trailing blanks). The present
*         implementation has a fixed maximum line length. 
*
*       - By manipulating a program parameter, the user can affect
*         Compare's sensitivity to the "locality" of differences.
*         More specifically this parameter, "Minlinesformatch",
*         specifies the number of consecutive lines on each file
*         which must match in order that they be considered as
*         terminating the prior mismatch.  A large value of
*         "Minlinesformatch" tends to produce fewer but larger
*         mismatches than does a small value.  The value six appears
*         to give good results on Pascal source files but may be
*         inappropriate for other applications.
*
*         If compare is to be used as a general utility program,
*         "Minlinesformatch" should be treated as a program
*         parameter of some sort.  It is declared as a constant here
*         for portability's sake.
*
*         Another program parameter (constant), "Markunequalcolumns",
*         specifies that when unequal lines are found, each line from 
*         filea is printed next to its corresponding line from fileb,
*         and unequal columns are marked.  This option is particularly
*         useful for fixed-format data files.  Notes: Line pairing is
*         not attempted if the mismatching sections are not the same
*         number of lines on each file. It is not currently very smart
*         about ASCII control characters like tab. (W.Kempton, Nov 78)
*
*       - Compare employs a simple backtracking search algorithm to
*         isolate mismatches from their surrounding matches.  This
*         requires (heap) storage roughly proportional to the size
*         of the largest mismatch, and time roughly proportional to
*         the square of the size of the mismatch for each mismatch.
*         For this reason it may not be feasible to use Compare on
*         files with very long mismatches.
*
*       - To the best of the author's knowledge, Compare utilizes
*         only features of Standard Pascal. 
*
*       Modified for UCSD Pascal by T.S. Beck - 9 Jun 80.
}


program compare;

  const
    version = '1.3   (7 Nov 78)';
    linelength = 120;             { MAXIMUM SIGNIFICANT INPUT LINE LENGTH }
    minlinesformatch = 3;         { NUMBER OF CONSECUTIVE EQUIVALENT }
                                  { LINES TO END A MIS-MATCH }
    markunequalcolumns = true;    { IF UNEQUAL LINES ARE TO BE PAIRED, }
                                  {  AND UNEQUAL COLUMNS MARKED }

  type
    linepointer = ^line;
    line =                        { SINGLE LINE BUFFER }
      packed record
        nextline : linepointer;
        length : 0..linelength;
        image : packed array [1..linelength] of char
      end;

    stream =                      { BOOKKEEPING FOR EACH INPUT FILE }
      record
        name : char;
        cursor, head, tail : linepointer;
        cursorlineno, headlineno, taillineno : integer;
        endfile : boolean
      end;

    var
      filea, fileb : text;
      out : interactive;
      filename : string[24];
      a, b : stream;
      match : boolean;
      endfile : boolean;          { SET IF END OF STREAM A OR B }

      templine :                  { USED BY READLINE }
        record
          length : integer;
          image : array [0..linelength] of char
        end;

      freelines : linepointer;    { FREE LIST OF LINE BUFFERS }

      same : boolean;             { FALSE IF NO MIS-MATCHES OCCUR }
      linestoolong : boolean;     { FLAG IF SOME LINES NOT COMPLETELY CHECKED }


    procedure comparefiles;

      function endstream(var x : stream) : boolean;
      begin { ENDSTREAM }
        endstream := (x.cursor = nil) and x.endfile
      end;  { ENDSTREAM }

      procedure mark(var x : stream);

        { CAUSES BEGINNING OF STREAM TO BE POSITIONED BEFORE }
        { CURRENT STREAM CURSOR.  BUFFERS GET RECLAIMED, LINE }
        { COUNTERS RESET, ETC. }

        var
          p : linepointer;

        begin { MARK }
          with x do
            if head <> nil then
              begin
                while head <> cursor do { RECLAIM BUFFER }
                  begin
                    with head^ do
                      begin  p := nextline;
                        nextline := freelines;  freelines := head
                      end;
                    head := p
                  end;
                headlineno := cursorlineno;
                if cursor = nil then
                  begin  tail := nil;  taillineno := cursorlineno  end
              end
        end;  { MARK }

        procedure movecursor(var x : stream;  var filex : text);

          { FILEX IS THE INPUT FILE ASSOCIATED WITH STREAM X.  THE }
          { CURSOR FOR X IS MOVED FORWARD ONE LINE, READING FROM X }
          { IF NECESSARY, AND INCREMENTING THE LINE COUNT.  ENDFILE }
          { IS SET IF EOF IS ENCOUNTERED ON EITHER STREAM. }

          procedure readline;
            var
              newline : linepointer;
              c, c2 : 0..linelength;
          begin { READLINE }
            if not x.endfile then
              begin
                c := 0;
                while not eoln(filex) and (c < linelength) do
                  begin
                    c := c + 1;
                    templine.image[c] := filex^;
                    get(filex)
                  end;
                if not eoln(filex) then  linestoolong := true;
                readln(filex);
                while templine.image[c] = ' ' do c := c - 1;
                if c < templine.length then
                  for c2 := c+1 to templine.length do
                    templine.image[c2] := ' ';
                templine.length := c;
                newline := freelines;
                if newline = nil then new(newline)
                else  freelines := freelines^.nextline;
                for c2 := 1 to linelength do 
                  newline^.image[c2] := templine.image[c2];
                newline^.length := c;
                newline^.nextline := nil;
                if x.tail = nil then
                  begin  x.head := newline;
                    x.taillineno := 1;  x.headlineno := 1
                  end
                else
                  begin x.tail^.nextline := newline;
                    x.taillineno := x.taillineno + 1
                  end;
                x.tail := newline;
                x.endfile := eof(filex);
              end
          end;  { READLINE }

        begin { MOVECURSOR }
          if x.cursor <> nil then
            begin
              if x.cursor = x.tail then readline;
              x.cursor := x.cursor^.nextline;
              if x.cursor = nil then endfile := true;
              x.cursorlineno := x.cursorlineno + 1
            end
          else
            if not x.endfile then { BEGINNING OF STREAM }
              begin
                readline; x.cursor := x.head;
                x.cursorlineno := x.headlineno
              end
            else  { END OF STREAM }
              endfile := true;
        end;  { MOVECURSOR }

        procedure backtrack(var x : stream;  var xlines : integer);

          { CAUSES THE CURRENT POSITION OF STREAM X TO BECOME THAT }
          { OF THE LAST MARK OPERATION.  I.E., THE CURRENT LINE   }
          { WHEN THE STREAM WAS MARKED LAST BECOMES THE NEW CURSOR. }
          { XLINES IS SET TO THE NUMBER OF LINES FROM THE NEW CURSOR }
          { TO THE OLD CURSOR, INCLUSIVE. }

        begin { BACKTRACK }
          xlines := x.cursorlineno + 1 - x.headlineno;
          x.cursor := x.head;  x.cursorlineno := x.headlineno;
          endfile := endstream(a) or endstream(b)
        end;  { BACKTRACE }

        procedure comparelines(var match : boolean);

          { COMPARE THE CURRENT LINES OF STREAMS A AND B, RETURNING }
          { MATCH TO SIGNAL THEIR (NON-) EQUIVALENCE.  EOF ON BOTH STREAMS }
          { IS CONSIDERED A MATCH, BUT EOF ON ONLY ONE STREAM IS A MISMATCH }

        begin { COMPARELINES }
          if (a.cursor = nil) or (b.cursor = nil) then
            match := endstream(a) and endstream(b)
          else
            begin
              match := (a.cursor^.length = b.cursor^.length);
              if match then
                match := (a.cursor^.image = b.cursor^.image)
            end
        end;  { COMPARELINES }

        procedure findmismatch;
        begin { FINDMISMATCH }
          { NOT ENDFILE AND MATCH }
          repeat  { COMPARENEXTLINES }
            movecursor(a, filea); movecursor(b,fileb);
            mark(a); mark(b);
            comparelines(match)
          until endfile or not match;
        end;  { FINDMISMATCH }

        procedure findmatch;
          var
            advanceb : boolean; { TOGGLE ONE-LINE LOOKAHEAD BETWEEN STREAMS }

          procedure search(var x : stream; { STREAM TO SEARCH }
                           var filex : text;
                           var y : stream; { STREAM TO LOOKAHEAD }
                           var filey : text);

            { LOOK AHEAD ONE LINE ON STREAM Y, AND SEARCH FOR THAT LINE }
            { BACKTRACKING ON STREAM X. }

            var
              count : integer; { NUMBER OF LINES BACKTRACKED ON X }

            procedure checkfullmatch;
              { FROM THE CURRENT POSITIONS IN X AND Y, WHICH MATCH, }
              { MAKE SURE THAT THE NEXT MINLINESFORMATCH-1 LINES ALSO }
              { MATCH, OR ELSE SET MATCH := FALSE.  }
              var
                n : integer;
                savexcur, saveycur : linepointer;
                savexline, saveyline : integer;
            begin { CHECKFULLMATCH }
              savexcur := x.cursor;  saveycur := y.cursor;
              savexline := x.cursorlineno;  saveyline := y.cursorlineno;
              comparelines(match);
              n := minlinesformatch - 1;
              while match and (n <> 0) do 
                begin  movecursor(x, filex);  movecursor(y, filey);
                  comparelines(match);  n := n - 1;
                end;
              x.cursor := savexcur;  x.cursorlineno := savexline;
              y.cursor := saveycur;  y.cursorlineno := saveyline;
            end;  { CHECKFULLMATCH }

          begin { SEARCH }
            movecursor(y, filey);  backtrack(x, count);
            checkfullmatch;  count := count - 1;
            while (count <> 0) and not match do
              begin
                movecursor(x, filex);  count := count - 1;
                checkfullmatch
              end
          end;  { SEARCH }

          procedure printmismatch;
            var
              emptya, emptyb : boolean;

            procedure writeoneline(name : char; l : integer; p : linepointer);
            begin  { WRITEONELINE }
                  write(out,'   ', name, l:5,'  ');
                  if p^.length = 0 then writeln(out)
                  else writeln(out,p^.image : p^.length);
            end;  { WRITEONELINE }

            procedure writetext(var x : stream);
              { WRITE FROM X.HEAD TO ONE LINE BEFORE X.CURSOR }
              var
                p, q : linepointer;  lineno : integer;
            begin { WRITETEXT }
              p:=x.head;  q:=x.cursor;   lineno:=x.headlineno;
              while (p <> nil) and (p <> q) do 
                begin
                  writeoneline( x.name, lineno, p);
                  p := p^.nextline;
                  lineno := lineno + 1;
                end;
              if p = nil then writeln(out,' *** eof ***');
              writeln(out)
            end;  { WRITETEXT }

            procedure writepairs( pa, pb : linepointer;  la, lb : integer);
              { THIS WRITES FORM THE HEAD TO THE CURSOR, LIKE PROCEDURE }
              { WRITETEXT.  UNLIKE PROCEDURE WRITETEXT, THIS WRITES FROM }
              { BOTH FILES AT ONCE, COMPARES COLUMNS WITHIN LINES, AND MARKS }
              { UNEQUAL COLUMNS. }
            var
              tempa, tempb : array [1..linelength] of char;
              col, maxcol  : integer;
            begin  { WRITEPAIRS }
              repeat
                writeoneline('a', la, pa);   writeoneline('b', lb, pb);
                for col := 1 to linelength do
                  begin
                    tempa[col] := pa^.image[col];
                    tempb[col] := pb^.image[col]
                  end;
                if  pa^.length > pb^.length
                        then maxcol := pa^.length else maxcol := pb^.length;
                write(out,' ': 11);
                  { 11 spaces used for file name and line number }
                for col := 1 to maxcol do
                    if tempa[col] = tempb[col] then write(out,' ')
                    else write(out,'^'); 
                writeln(out);  writeln(out);
                pa := pa^.nextline;  la := la + 1;
                pb := pb^.nextline;  lb := lb + 1;
              until (pa = a.cursor) or (pa = nil);
            end;  { WRITEPAIRS }

            procedure writelineno(var x : stream);
              var
                f, l : integer;
            begin { WRITELINENO }
              f := x.headlineno;  l := x.cursorlineno - 1;
              write(out,'line');
              if f = l then write(out,' ', f:1)
              else write(out,'s ', f:1, ' thru ', l:1);
              if x.cursor = nil then write(out,' (before eof)');
            end;  { WRITELINENO }

            procedure printextratext(var x , y : stream);

            begin { PRINTEXTRATEXT }
              write(out,' extra text:  on file', x.name, ', ');

              if y.head = nil then
                writeln(out,' before eof on file', y.name)
              else
                writeln(out,' between lines ', y.headlineno-1:1, ' and ',
                        y.headlineno:1, ' of file', y.name);
              writeln(out);
              writetext(x)
            end;  { PRINTEXTRATEXT }

          begin { PRINTMISMATCH }
            writeln(out,' ':11, '**********************************');
            emptya := (a.head = a.cursor);
            emptyb := (b.head = b.cursor);
            if emptya or emptyb then
              if emptya then printextratext(b, a)
              else printextratext(a, b)
            else
              begin
                write(out,' mismatch:   ');
                write(out,' filea, ');  writelineno(a);
                write(out,'   not equal to   ');
                write(out,' fileb, ');  writelineno(b);  writeln(out,':');
                writeln(out);
                if markunequalcolumns and ((a.cursorlineno - a.headlineno) =
                  (b.cursorlineno - b.headlineno))
                then
                  writepairs(a.head, b.head, a.headlineno, b.headlineno)
                else
                  begin  writetext(a);  writetext(b)  end
              end
          end;  { PRINTMISMATCH }

        begin { FINDMATCH }
          { NOT MATCH }
          advanceb := true;
          repeat
            if not endfile then advanceb := not advanceb
            else advanceb := endstream(a);
            if advanceb then search(a, filea, b, fileb)
              else search(b, fileb, a, filea)
          until match;
          printmismatch;
        end;  { FINDMATCH }

      begin { COMPAREFILES }
        match := true;  { I.E., BEGINNINGS-OF-FILES MATCH }
        repeat
          if match then findmismatch else begin same := false; findmatch end
        until endfile and match;
        { MARK(A);  MARK(B);   MARK END OF FILES, THEREBY DISPOSING BUFFERS }
      end;  { COMPAREFILES }

      procedure initialize;

        procedure initstream(fid : char; var x : stream; var filex : text);
        
        var
          count, i : integer;
          
        begin { INITSTREAM }
          with x do
            begin
              cursor := nil;  head := nil;  tail := nil;
              cursorlineno := 0; headlineno := 0;  taillineno := 0
            end;
          repeat
            write('Type name of file ',fid,': ');
            readln(filename);
            count := length(filename);
            if count = 0 then exit(compare);
            for i := 1 to count do
              if filename[i] in ['a'..'z'] then
                filename[i] := chr(ord(filename[i]) - 32);
            if (pos('.TEXT',filename) = 0) and (filename[count] <> '.') and
              (count < 19) then filename := concat(filename,'.TEXT');
            {$i-}
            reset(filex,filename)
            {$i+}
          until ioresult = 0;
          writeln(out,' file',fid,': ',filename);
          x.endfile := eof(filex);
        end;  { INITSTREAM }


      begin { INITIALIZE }
        initstream('a',a, filea);
        initstream('b',b, fileb);
        writeln(out);
        endfile := a.endfile or b.endfile; 
        a.name := 'a';  b.name := 'b';
        linestoolong := false;
        freelines := nil;
        templine.length := linelength;
        templine.image[0] := 'x';  { SENTINEL }
      end; {INITIALIZE}


    begin {COMPARE}
      repeat
        write('Type output file name: '); readln(filename);
        if length(filename) = 0 then exit(compare);
        {$i-}
        reset(out,filename)
        {$i+}
      until ioresult = 0;
      if (filename = '#8:') or (filename = 'REMOTE:') then
        write(out,chr(27),'u',chr(24)); { set H14 printer to 96 char. }
      writeln(out,'     compare.  version ', version);
      writeln(out);
      writeln(out,' match criterion = ', minlinesformatch:1, ' lines.');
      writeln(out);
      initialize;
      if a.endfile then writeln(out,' filea is empty.');
      if b.endfile then writeln(out,' fileb is empty.');
      if not endfile then
        begin  same := true;
          comparefiles;
          if same then writeln(out,' no differences.');
          if linestoolong then
            begin     writeln(out);
              writeln(out,' WARNING:  some lines were longer than ',
                      linelength:1, ' characters.');
              writeln(out,'           they were not compared past that point.');
            end;
        end
    end.  { COMPARE }

========================================================================================
DOCUMENT :usus Folder:VOL04:compress.text
========================================================================================

program compress;

{ This program will compress a text file by removing all trailing blanks and
  recomputing the indent codes  - T. S. Beck - 8/Jun/80 }

const
  CR = 13;
  DLE = 16;
  forever = false;
  NUL = 0;
  pagemax = 1023;

type
  name = string[24];

var
  i,
  count,
  dummy,
  first,
  index,
  last     : integer;
  inname,
  outname  : name;
  line     : string[255];
  page     : packed array[0..pagemax] of char;
  infile,
  outfile  : file;
  intext   : text;


  procedure writepage;
  VAR i: integer;
      ch: char;
  begin
    ch := CHR (NUL);
    for i := index to pagemax do page [i] := ch;
    dummy := blockwrite (outfile,page,2);
    write('.');
    index := 0
  end; { writepage }


  procedure forceuppercase(var filename : name);

  var
    i : integer;

  begin
    for i := 1 to count do
      if filename[i] in ['a'..'z'] then
        filename[i] := chr(ord(filename[i]) - 32)
  end; { forceuppercase }


begin { compress }
  writeln('Type <RETURN> to quit.');
  repeat
    repeat
      write('Input file? ');
      readln(inname);
      count := length(inname);
      if count = 0 then exit(compress);
      forceuppercase(inname);
      if (pos('.TEXT',inname) = 0) and (inname[count] <> '.') and
        (count < 19) then inname := concat(inname,'.TEXT');
      {$i-}
      reset(infile,inname)
      {$i+}
    until ioresult = 0;
    repeat
      write('Output file? ');
      readln(outname);
      count := length(outname);
      if count = 0 then exit(compress);
      if (count = 1) and (outname[1] = '$') then outname := inname;
      forceuppercase(outname);
      if (pos('.TEXT',outname) = 0) and (outname[count] <> '.') and
        (count < 19) then outname := concat(outname,'.TEXT');
      {$i-}
      rewrite(outfile,outname)
      {$i+}
    until ioresult = 0;
    dummy := blockread(infile,page,2);
    dummy := blockwrite(outfile,page,2);
    close(infile);
    reset(intext,inname);
    index := 0;
    repeat
      readln(intext,line);
      count := length(line);
      if count > 0 then
        begin
          first := scan(count,<> ' ',line[1]) + 1;
          if first > 223 then first := 223;
          last := count + scan(-count,<> ' ',line[count]);
          if first > last then
            count := 0
          else
            if first <= 2 then
              count := last
            else
              count := last - first + 3
        end;
      if (index + count) >= pagemax then writepage;
      {
      if count > 0 then
        if first <= 2 then moveleft(line[1],page[index],count)
        else
          begin
            page[index] := chr(DLE);
            page[index + 1] := chr(first + 31);
            moveleft(line[first],page[index + 2],count - 2)
          end;
      }
      if count > 0 then
        if first <= 2 
          then for i := 1 to count do page [index + i-1] := line[i]
          else begin
            page[index] := chr(DLE);
            page[index + 1] := chr(first + 31);
            for i := 0 to count - 3 do 
              page [index + i + 2] := line [i + first];
          end;
      index := index + count;
      page[index] := chr(CR);
      index := index + 1
    until eof(intext);
    writepage;
    close(intext);
    close(outfile,lock);
    writeln
  until forever
end.

      

========================================================================================
DOCUMENT :usus Folder:VOL04:dbbuilder.text
========================================================================================

(*$S+*)
PROGRAM DESCRIPTORBUILDER;  (*version 0.0 - 2 Feb 1980*)
  (*Copyright 1980 Kenneth L. Bowles. All rights reserved. Permission is
    hereby granted to use this material for any non-commerical purpose*)
USES DBUNIT;

CONST
  WA0 = 0;
  FDNAMEOFFSET = 12;
  LASTFIELDDESCRIPTOR = 255;
  
TYPE
  CHSET=SET OF CHAR;
  REFLIST=ARRAY[0..0] OF INTEGER; (*index range checking off*)

  (*fixed layout parts of descriptors*)
  GRPDESCRIPTOR=
    PACKED RECORD
      OVERLINK:BYTE; (*descriptor longer than 240 bytes not allowed*)
      SWITCHES:BYTE; (*packed array gets allocated in whole words*)
                     (*bit 0 = tagged; bit 1 = linked *)
      RECLINK:BYTE;
      FILLER:BYTE;
      RECNUM:REFLIST;
      (*expand here with additional recnum's*)
    END;
  GRPDESPTR=^GRPDESCRIPTOR;
  
  RECDESCRIPTOR=
    PACKED RECORD
      OVERLINK:BYTE;
      SWITCHES:BYTE; (*bit 0 = tagged; bit 1 = fixed width; bit 2 = sparse *)
      SIZE:INTEGER;
      FIRSTLITEMNUM:BYTE;
      USECOUNT:BYTE;
      LAYOUT:BYTE; (*on a large system this could be declared TAG*)
      LASTFLDLINK:BYTE;  (*points to name field*)
      FLDREF:ARRAY [0..0] OF
               PACKED RECORD
                 FDNUM: 0..LASTFIELDDESCRIPTOR;
                 FLDOFFSET:BYTE; (*for fixed size fields; =0 for linked*)
               END;
      (*expand here with additional fldref's*)
    END;
  RECDESPTR=^RECDESCRIPTOR;

  FDTYPE=
    PACKED RECORD
      CASE BOOLEAN OF
        TRUE: (S:STRING);
        FALSE: (R:FLDDESCRIPTOR)
      END;
      
  RDTYPE=
    PACKED RECORD
      CASE BOOLEAN OF
        TRUE: (S:STRING);
        FALSE: (R:RECDESCRIPTOR)
      END;
      
  GDTYPE=
    PACKED RECORD
      CASE BOOLEAN OF
        TRUE: (S:STRING);
        FALSE: (R:GRPDESCRIPTOR)
      END;
      
  STRINGPTR = ^STRING;
      
  TRIXPTR=
    RECORD CASE DBLEVELTYPE OF
      FIELDT: (F:FLDDESPTR);
      RECORDT:(R:RECDESPTR);
      GROUPT: (G:GRPDESPTR);
      NONET:  (S:STRINGPTR)
    END (*TRIXPTR*);
      
      
  
VAR
  DONE:BOOLEAN;
  ITEMLEVEL:DBLEVELTYPE;
  REMFILE:BOOLEAN;
  FOUT:INTERACTIVE;
  
FUNCTION GETCOMMAND(S:STRING; OKSET:CHSET):CHAR;
VAR CH:CHAR;
BEGIN
  REPEAT
    WRITELN;
    WRITE(S);
    READ(CH);
    IF CH IN ['a'..'z'] THEN
      CH:=CHR(ORD(CH)-32);
    IF NOT (CH IN OKSET) THEN
      WRITE(' ORD(CH)=',ORD(CH));
  UNTIL CH IN OKSET;
  WRITELN;
  GETCOMMAND:=CH;
END (*GETCOMMAND*);

PROCEDURE LOCATOR(GROUPNUM,RECNUM:INTEGER);
VAR I:INTEGER;
BEGIN
  DBSHOWERR('LOC#1', DBHOME(WA0));
  DBSHOWERR('LOC#2', DBSEEK(WA0, GROUPNUM));
  DBSHOWERR('LOC#3', DBDESCEND(WA0));
  DBSHOWERR('LOC#4', DBSEEK(WA0, RECNUM));
END (*LOCATOR*);

FUNCTION READI(S:STRING; X:INTEGER): INTEGER;
VAR I:INTEGER;
BEGIN
  WRITE(S,X, '  >');
  READLN(I);
  IF EOF THEN
    BEGIN
      RESET(INPUT);
      READI:=X;
      WRITELN;
    END
  ELSE
    READI:=I;
END (*READI*);

PROCEDURE SHOWFLDTYPE(FLDTYPE:DBFIELDTYPES);
BEGIN
  WRITE('FLD TYPE:');
  IF NOT (FLDTYPE IN [BYTEF, GROUPF, INTEGERF, LONGINTF, STRINGF,
                     SETF, PICF]) THEN
    WRITELN('***** ILLEGAL ****')
  ELSE
    CASE FLDTYPE OF
      BYTEF: WRITELN('BYTEF');
      GROUPF: WRITELN('GROUPF');
      INTEGERF: WRITELN('INTEGERF');
      LONGINTF: WRITELN('LONGINTF');
      SETF: WRITELN('SETF');
      PICF: WRITELN('PICF');
      TEXTF: WRITELN('TEXTF');
      STRINGF: WRITELN('STRINGF')
    END (*CASE*);
END (*SHOWFLDTYPE*);

PROCEDURE SHOWFD(PS:STRING);
VAR 
  FD:FDTYPE;
BEGIN
  FD.S:=PS;
  WITH FD.R DO
    BEGIN
      (*note: link value is one more than correct string length*)
      WRITELN('FIELD DESCRIPTOR:',NAME:(LENGTH(NAME)-1));
      WRITELN('SWITCHES:', SWITCHES);
      WRITELN('MAX WIDTH:', MAXWIDTH);
      WRITELN('USECOUNT:', USECOUNT);
      SHOWFLDTYPE(FLDTYPE);
      WRITELN('FLDREF:', FLDREF);
      IF FLDREF = 0 THEN
        BEGIN
          WRITELN('ROW:', ROW);
          WRITELN('DATACOL:', DATACOL);
          WRITELN('LABELCOL:', LABELCOL);
          WRITELN('CONTROLBITS:', CONTROLBITS);
        END;
    END (*WITH*);
END (*SHOWFD*);

PROCEDURE BUILDFD;
VAR NS:STRING;
  I,FLDNUM:INTEGER;
  CH:CHAR;
  FD:FDTYPE;
BEGIN
  DBTYPECHECK:=FALSE;
  WRITELN;
  WRITE('FIELD NUMBER:');
  READLN(FLDNUM);
  LOCATOR(3(*FD'S*), FLDNUM);
  CASE GETCOMMAND('BUILDFD: C(hange old field or N(ew field?',
                        ['C','c','N','n']) OF
    'C','c': BEGIN
               DBSHOWERR('BUILDFD-GET', DBGET(WA0));
               FD.S:=DBMAIL.STRG;
             END;
    'N','n': FILLCHAR(FD.S, 82, CHR(0))
  END (*CASE*);
  WITH FD.R DO
    BEGIN
  
      WRITE('FIELD NAME:', NAME:LENGTH(NAME)-1, '  >');
      READLN(NS);
      IF LENGTH(NS) > 0 THEN
(*$R-*)
        BEGIN
          MOVELEFT(NS,NAME,LENGTH(NS)+1);
          NAME[0]:=CHR(LENGTH(NS)+1);
          OVERLINK:=LENGTH(NS)+SIZEOF(FLDDESCRIPTOR)-1;
        END
      ELSE
        WRITELN;
(*$R+*)
      SWITCHES:=READI('SWITCH BYTE:',SWITCHES);
      MAXWIDTH:=READI('MAXIMUM WIDTH:', MAXWIDTH);
      USECOUNT:=0;
      SHOWFLDTYPE(FLDTYPE);
      WRITE('  G(ROUP R(EC S(TRING B(YTE I(NTEGER  >');
      REPEAT
        READ(CH);
      UNTIL (CH IN ['G', 'S', 'B', 'I']) OR EOF;
      WRITELN;
      IF EOF THEN
        RESET(INPUT)
      ELSE
        CASE CH OF
          'B': FLDTYPE:=BYTEF;
          'G': FLDTYPE:=GROUPF;
          'I': FLDTYPE:=INTEGERF;
          'S': FLDTYPE:=STRINGF
        END (*CASE*);
      IF FLDTYPE = GROUPF THEN
        FLDREF:=READI('DESCRIPTOR NUMBER:',FLDREF)
      ELSE
        FLDREF:=READI('Displayable (=0) or not (=1):', FLDREF);
      IF FLDTYPE <> GROUPF THEN
        BEGIN
          WRITE('Set Display Params? (Y/N)');
          READ(CH);
          WRITELN;
          IF CH IN ['Y', 'y'] THEN
            BEGIN
              ROW:=READI('ROW:',ROW);
              DATACOL:=READI('DATACOL:', DATACOL);
              LABELCOL:=READI('LABELCOL:',LABELCOL);
              CONTROLBITS:=READI('CONTROLBITS:',CONTROLBITS);
            END;
        END;
    END (*WITH FD.R*);
  WRITELN;
  WRITE('<ETX> ACCEPTS; <RET> TRY AGAIN');
  READ(KEYBOARD,CH);
  IF CH = CHR(3(*ETX*)) THEN
    WITH DBMAIL DO
      BEGIN
        STRG:=FD.S;
        DBMAILTYPE:=STRINGF;
        DBSHOWERR('BUILDFD', DBPUT(WA0));
      END;
END (*BUILDFD*);

PROCEDURE SHOWRD(PS:STRING);
VAR I,J,N:INTEGER;
  NS:STRING;
  RD:RDTYPE;
BEGIN
  RD.S:=PS;
  NS:=RD.S;
  DELETE(NS,1,(RD.R.LASTFLDLINK+SIZEOF(RECDESCRIPTOR)-3));
  WRITELN('RECORD DESCRIPTOR:',NS);
  WITH RD.R DO
    BEGIN
      WRITELN('SWITCHES:', SWITCHES);
      WRITELN('SIZE:', SIZE);
      WRITELN('FIRSTLINK - ITEM# ', FIRSTLITEMNUM);
      WRITELN('USECOUNT:', USECOUNT);
      WRITELN('LAYOUT:', LAYOUT);
      WRITELN('LASTFLDLINK:', LASTFLDLINK);
    END (*WITH*);
  I:=0;
  N:=0;
  J:=RD.R.LASTFLDLINK - 2;
  WHILE I < J DO
    BEGIN
(*$R-*)
      WITH RD.R.FLDREF[N] DO
        WRITELN(' FLDREF(', N, ') - FDNUM:', FDNUM,
                                    '   OFFSET:', FLDOFFSET);
      I:=I+2;
      N:=N+1;
(*$R+*)
    END;
END (*SHOWRD*);

PROCEDURE BUILDRD;
VAR I,J,N,X,RECNUM:INTEGER;
  NAME:STRING;
  CH:CHAR;
  RD:RDTYPE;
BEGIN
  REPEAT
    FILLCHAR(RD.S, 82, CHR(0));
    WRITELN;
    WRITE('RECORD DEF NUMBER:');
    READLN(RECNUM);
    LOCATOR(2(*RD'S*), RECNUM);
    WRITE('RECDEF NAME:');
    READLN(NAME);
    WRITE('SWITCH BYTES:');
    WITH RD.R DO
      BEGIN
        READLN(I);
        SWITCHES:=I;
        WRITE('SIZE:');
        READLN(SIZE);
        WRITE('FIRSTLITEMNUM:'); READLN(I); FIRSTLITEMNUM:=I;
        USECOUNT:=0;
        WRITE('LAYOUT#:');
        READLN(I);
        LAYOUT:=I;
      END (*WITH*);
    I:=8;
    J:=3;
    REPEAT
      N:=(I-8) DIV 2;
      WRITE('FLDREF #', N, ':');
      READ(X);
      IF X >= 0 THEN
(*$R-*)
        WITH RD.R.FLDREF[N] DO
          BEGIN
            FDNUM:=X;
            WRITE('  OFFSET #', N, ':'); 
            READLN(X);
            FLDOFFSET:=X;
(*$R+*)
            J:=J+2;
            I:=I+2;
          END;
    UNTIL X < 0;
    RD.R.OVERLINK:=2+I;
    RD.R.LASTFLDLINK:=J; (*leave 2 empty bytes*)
    RD.S:=CONCAT(RD.S,NAME);
    RD.S[2+I]:=CHR(LENGTH(NAME)+1);
    WRITELN;
    SHOWRD(RD.S);
    WRITE('<ETX> ACCEPTS; <RET> TRY AGAIN');
    READ(KEYBOARD,CH);
  UNTIL CH = CHR(3(*ETX*));
  WITH DBMAIL DO
    BEGIN
      STRG:=RD.S;
      DBMAILTYPE:=STRINGF;
    END;
  READ(CH); (*flush buffered char left by READ(X) of '-1<RET>'*)
  WRITELN;
END (*BUILDRD*);

PROCEDURE SHOWGD(PS:STRING);
VAR I,J,N:INTEGER;
  A: ARRAY[0..0] OF INTEGER;
  NS:STRING;
  GD:GDTYPE;
BEGIN
  GD.S:=PS;
  NS:=GD.S;
  DELETE(NS,1,(GD.R.RECLINK+SIZEOF(GRPDESCRIPTOR)-4));
  WRITELN('GROUP DESCRIPTOR:',NS);
  WITH GD.R DO
    BEGIN
      WRITELN('SWITCHES:', SWITCHES);
      WRITELN('RECLINK:', RECLINK);
    END (*WITH*);
  I:=0;
  N:=0;
  J:=GD.R.RECLINK-2;
  WHILE I < J DO
    BEGIN
(*$R-*)
      WRITELN(' RECNUM(', N, '):', GD.R.RECNUM[N]);
(*$R+*)
      N:=N+1;
      I:=I+2;
    END;
END (*SHOWGD*);

PROCEDURE BUILDGD;
VAR I,J,N,X,GRPNUM:INTEGER;
  NAME:STRING;
  CH:CHAR;
  GD:GDTYPE;
BEGIN
  FILLCHAR(GD.S, 82, CHR(0));
  REPEAT
    WRITELN;
    WRITE('GROUP DEF NUMBER:');
    READLN(GRPNUM);
    LOCATOR(1(*GD'S*), GRPNUM);
    WRITE('GRPDEF NAME:');
    READLN(NAME);
    WRITE('SWITCH BYTES:');
    READLN(I);
    GD.R.SWITCHES:=I;
    I:=4;
    REPEAT
      N:=(I-4) DIV 2;
      WRITE('RECNUM #', N, ':');
      READLN(X);
      IF X >= 0 THEN
        BEGIN
(*$R-*)
          GD.R.RECNUM[N]:=X;
(*$R+*)
          I:=I+2;
        END;
    UNTIL X < 0;
    GD.R.OVERLINK:=2+I;
    GD.R.RECLINK:=I;
    GD.S:=CONCAT(GD.S,NAME);
    GD.S[2+I]:=CHR(LENGTH(NAME)+1);
    WRITELN;
    SHOWGD(GD.S);
    WRITE('<ETX> ACCEPTS; <RET> TRY AGAIN');
    READ(KEYBOARD,CH);
  UNTIL CH = CHR(3(*ETX*));
  WITH DBMAIL DO
    BEGIN
      STRG:=GD.S;
      DBMAILTYPE:=STRINGF;
    END;
END (*BUILDGD*);

PROCEDURE BUILDLITERAL;
VAR I:INTEGER;
  S:STRING;
BEGIN
  CASE GETCOMMAND('LITERAL: I(NTEGER S(TRING ', ['I','S']) OF
    'I': BEGIN
           WRITE('I>');
           READLN(I);
           WITH DBMAIL DO
             BEGIN
               INT:=I;
               DBMAILTYPE:=INTEGERF;
             END;
         END;
    'S': BEGIN
           WRITE('S>');
           READLN(S);
           WITH DBMAIL DO
             BEGIN
               STRG:=S;
               DBMAILTYPE:=STRINGF;
             END;
         END
  END (*CASES*);
END (*BUILDLITERAL*);

PROCEDURE SHOWLITERAL;
BEGIN
  WRITELN;
  CASE DBMAIL.DBMAILTYPE OF
    STRINGF: WRITELN('STRG: ', DBMAIL.STRG);
    INTEGERF: WRITELN('INT: ', DBMAIL.INT)
    (*LONGINTF: WRITELN('LINT: ', DBMAIL.LINT) *)
  END (*CASES*);
END (*SHOWLITERAL*);

PROCEDURE SHOWDATASTRUCTURE;
VAR TP:TRIXPTR;
  GN:INTEGER;
  
  PROCEDURE GDOUT(TP:TRIXPTR; LEVEL,GN:INTEGER); FORWARD;
  
  PROCEDURE FDOUT(TP:TRIXPTR; LEVEL,FN:INTEGER);
  VAR NS:STRING;
    GP:TRIXPTR;
  BEGIN
    WITH TP.F^ DO
      BEGIN
        NS:=NAME;
        DELETE(NS,LENGTH(NS),1);
        (*note: link value is one more than correct string length*)
        WRITE(FOUT,'FLD(':(4+LEVEL), FN, '):',NS, ' ':17-LENGTH(NS));
        WRITE(FOUT,'   SW:', SWITCHES);
        WRITE(FOUT,'  W:', MAXWIDTH);
        WRITE(FOUT,'  T:');
        IF NOT (FLDTYPE IN [BYTEF, GROUPF, INTEGERF, LONGINTF, STRINGF,
                           SETF, PICF]) THEN
          WRITE(FOUT,'***** ILLEGAL ****')
        ELSE
          BEGIN
            CASE FLDTYPE OF
              BYTEF: WRITE(FOUT,'BYT');
              GROUPF: WRITE(FOUT,'GRP');
              INTEGERF: WRITE(FOUT,'INT');
              LONGINTF: WRITE(FOUT,'LNI');
              SETF: WRITE(FOUT,'SET');
              PICF: WRITE(FOUT,'PIC');
              TEXTF: WRITE(FOUT,'TXT');
              STRINGF: WRITE(FOUT,'STR')
            END (*CASE*);
            IF FLDTYPE = GROUPF THEN
              BEGIN
                WRITELN(FOUT);
                DBGETDESCRIPTORNUM(GROUPT, FLDREF, GP.F);
                IF GP.F <> NIL THEN
                  GDOUT(GP, LEVEL+2, FLDREF);
              END
            ELSE
              BEGIN
                IF FLDREF = 0 THEN
                  WRITE(FOUT, '  ROW=', ROW,
                              '  LCOL=', LABELCOL,
                              '  DCOL=', DATACOL);
                WRITELN(FOUT);
              END;
          END (*FLDTYPE OK*);
      END (*WITH TP.F^*);
  END (*FDOUT*);
  
  PROCEDURE RDOUT(TP:TRIXPTR; LEVEL,RN:INTEGER);
  VAR I,J,N:INTEGER;
    NS:STRING;
    FP:TRIXPTR;
  BEGIN
    NS:=TP.S^;
    DELETE(NS,1,(TP.R^.LASTFLDLINK+SIZEOF(RECDESCRIPTOR)-3));
    (*correct for link to string length*)
    DELETE(NS, LENGTH(NS),1);
    WRITE(FOUT,'REC(':(4+LEVEL), RN, '):',NS, ' ':18-LENGTH(NS));
    WITH TP.R^ DO
      BEGIN
        WRITE(FOUT,'   SW:', SWITCHES);
        WRITELN(FOUT,'  SIZE:', SIZE);
      END (*WITH*);
    I:=0;
    N:=0;
    J:=TP.R^.LASTFLDLINK - 4;
    WHILE I < J DO
      BEGIN
(*$R-*)
        WITH TP.R^.FLDREF[N] DO
          BEGIN
            DBGETDESCRIPTOR(FIELDT, FDNUM, FP.F);
(*$R+*)
            IF FP.F <> NIL THEN
              FDOUT(FP, LEVEL+2, FDNUM);
          END;
        I:=I+2;
        N:=N+1;
      END;
  END (*RDOUT*);
  
  PROCEDURE GDOUT(*TP:TRIXPTR; LEVEL,GN:INTEGER*);
  VAR I,J,N:INTEGER;
    NS:STRING;
    RP:TRIXPTR;
  BEGIN
    NS:=TP.S^;
    DELETE(NS,1,(TP.G^.RECLINK+SIZEOF(GRPDESCRIPTOR)-4));
    (*correct for link to string length*)
    DELETE(NS, LENGTH(NS),1);
    WRITE(FOUT,'GRP(':(4+LEVEL), GN, '):',NS, ' ':18-LENGTH(NS));
    WITH TP.G^ DO
      BEGIN
        WRITELN(FOUT,'   SW:', SWITCHES);
        I:=0;
        N:=0;
        J:=RECLINK-4;
        WHILE I < J DO
          BEGIN
(*$R-*)
            DBGETDESCRIPTOR(RECORDT, RECNUM[N], RP.F);
(*$R+*)
            IF RP.F <> NIL THEN
              RDOUT(RP,LEVEL+2, RECNUM[N]);
            N:=N+1;
            I:=I+2;
          END;
      END (*WITH TP.G^*);
END (*GDOUT*);
  
BEGIN (*SHOWDATASTRUCTURE*)
  WRITELN(FOUT);
  GN:=0;
  DBGETDESCRIPTOR(GROUPT, GN, TP.F);
  WHILE TP.F <> NIL DO
    BEGIN
      GDOUT(TP,0, GN);
      WRITELN(FOUT);
      GN:=GN+1;
      DBGETDESCRIPTOR(GROUPT, GN, TP.F);
    END;
END (*SHOWDATASTRUCTURE*);
  
PROCEDURE SHOWITEMINFO;
VAR ITEMNUM,OFFSET,DESCRIPTORNUM:INTEGER;
  NAME:STRING;
BEGIN
  WRITELN;
  DBITEMINFO(WA0,ITEMLEVEL,ITEMNUM,OFFSET,DESCRIPTORNUM,NAME);
  WRITE('LEVEL=');
  CASE ITEMLEVEL OF
    GROUPT: WRITE('GROUPT');
    RECORDT:WRITE('RECORDT');
    FIELDT: WRITE('FIELDT');
    NONET:  WRITE('NONET')
  END (*CASES*);
  WRITELN('  ITEM#', ITEMNUM, '  OFFSET=', OFFSET,
          '  DESCRIP#', DESCRIPTORNUM, '  NAME=', NAME);
END (*SHOWITEMINFO*);

PROCEDURE NEWEMPTY;
VAR CH:CHAR;
  TAG:INTEGER;
BEGIN
  SHOWITEMINFO;
  WRITE('Make new item? (Y/N)');
  READ(CH);
  WRITELN;
  IF CH IN ['Y','y'] THEN
    BEGIN
      CASE ITEMLEVEL OF
        GROUPT: 
          CASE GETCOMMAND('new embedded R(ecord or new G(roup?',
                                          ['G','R']) OF
            'G': BEGIN
                   WRITE('TAG VALUE:');
                   READLN(TAG);
                   DBSHOWERR('NEWEMPTY-GROUPT',
                          DBEMPTYITEM(WA0,GROUPT,TAG));
                 END;
            'R': DBSHOWERR('NEWEMPTY-REC', DBEMPTYITEM(WA0,RECORDT,TAG))
          END (*CASE GROUPT*);
        RECORDT,FIELDT: 
          DBSHOWERR('NEWEMPTY', DBEMPTYITEM(WA0,ITEMLEVEL,TAG));
        NONET: BEGIN (*do nothing*) END
      END (*CASE ITEMLEVEL*);
    END (*IF CH*);
END (*NEWEMPTY*);

PROCEDURE TRANSFERPRIMITIVES;
BEGIN
  CASE GETCOMMAND('XFER: E(MPTY G(ET P(UT R(EMOUT T(YPECHECK Q(UIT ',
                        ['E', 'G', 'P', 'R', 'T', 'Q']) OF
    'E': NEWEMPTY;
    'P': DBSHOWERR('XFER-PUT', DBPUT(WA0));
    'G': DBSHOWERR('XFER-GET', DBGET(WA0));
    'R': BEGIN
           REMFILE:=NOT REMFILE;
           CLOSE(FOUT);
           IF REMFILE THEN
             BEGIN
               RESET(FOUT, 'CONSOLE:');
               WRITELN('Output now to CONSOLE:');
             END
           ELSE
             BEGIN
               RESET(FOUT, 'REMOUT:');
               WRITELN('Output now to REMOUT:');
             END;
         END;
    'T': BEGIN
           DBTYPECHECK:=NOT DBTYPECHECK;
           WRITE('DBTYPECHECK NOW ');
           IF DBTYPECHECK THEN
             WRITELN('TRUE')
           ELSE
             WRITELN('FALSE');
         END;
    'Q': BEGIN (*do nothing*) END
  END (*CASES*);
END (*TRANSFERPRIMITIVES*);

PROCEDURE FILEHANDLER;
CONST
  FNUM=0;
  PGZERO=0;
  EMPTYSTRING='';
VAR
  TITLE:STRING;
  CH:CHAR;
  DUMMY:INTEGER;
  
  PROCEDURE GETTITLE;
  BEGIN
    WRITE('FILE TITLE:');
    READLN(TITLE);
  END (*GETTITLE*);
  
BEGIN (*FILEHANDLER*)
  CASE GETCOMMAND(
        'FILE: N(EWFILE O(PEN I(NIT-GROUPS C(LOSE R(EMOVE G(ET P(UT Q(UIT',
                        ['C','G','I','N','O','P','R','Q']) OF
    'C': DBSHOWERR('FILE(C)', DBFCLOSE(FNUM));
    'G': DBSHOWERR('FILE(G)', DBGETPAGE(FNUM,WA0,PGZERO));
    'I': DBSHOWERR('FILE(I)', DBGROUPINIT(FNUM,DUMMY,'ALL'));
    'N': BEGIN
           WRITE('NEW ');
           GETTITLE;
           DBSHOWERR('FILE(N)', DBFCREATE(FNUM,WA0,EMPTYSTRING,TITLE));
         END;
    'O': BEGIN
           WRITE('OLD ');
           GETTITLE;
           DBSHOWERR('FILE(O)', DBFOPEN(FNUM, TITLE));
         END;
    'P': DBSHOWERR('FILE(P)', DBPUTPAGE(FNUM, WA0, PGZERO));
    'R': BEGIN
           WRITE('REMOVE OLD FILE (Y/N)?');
           READ(CH);
           IF CH = 'Y' THEN
             DBSHOWERR('FILE(R)', DBFREMOVE(FNUM));
         END;
    'Q': BEGIN
           (*DO NOTHING*);
         END
  END (*CASE*);
END (*FILEHANDLER*);

PROCEDURE TESTFINDREC;
VAR FN,RN:INTEGER;
  FOUND:BOOLEAN;
  KEY:STRING;
BEGIN
  WRITELN('TEST DBFINDREC PROCEDURE');
  WRITE('FIELDNUM:');
  READLN(FN);
  WRITE('KEY(STRING):');
  READLN(KEY);
  DBSHOWERR('TESTFINDREC', DBFINDREC(WA0, ASCENDING, FN, KEY, RN, FOUND));
  IF FOUND THEN WRITE('  FOUND RECORD')
           ELSE WRITE('  COULDN''T FIND KEY');
  WRITELN('  RECNUM=', RN);
  WRITELN;
END (*TESTFINDREC*);

PROCEDURE MOVER;
VAR N,G,R:INTEGER;
BEGIN
  CASE GETCOMMAND(
    'MOVE: B(EGIN-LEVEL F(IND H(OME N(EXT T(AIL S(EEK D(ESCEND L(OCATE Q(UIT',
                                ['B','F','H','N','S','T','D','L','Q']) OF
    'B': DBSHOWERR('MOVE-HEAD', DBHEAD(WA0));
    'F': TESTFINDREC;
    'H': DBSHOWERR('MOVE-HOME', DBHOME(WA0));
    'N': DBSHOWERR('MOVE-NEXT', DBNEXT(WA0));
    'T': DBSHOWERR('MOVE-TAIL', DBTAIL(WA0));
    'S': BEGIN
           WRITELN;
           WRITE('ITEM NUMBER:');
           READLN(N);
           DBSHOWERR('MOVE-SEEK', DBSEEK(WA0, N));
         END;
    'D': DBSHOWERR('MOVE-DESCEND', DBDESCEND(WA0));
    'L': BEGIN
           WRITELN;
           WRITE('GROUP:');
           READLN(G);
           WRITE('  RECORD:');
           READLN(R);
           LOCATOR(G,R);
         END;
    'Q': BEGIN
           (*DO NOTHING*)
         END
  END (*CASES*);
END (*MOVER*);

PROCEDURE SETTRACESITES;
VAR I:INTEGER;
BEGIN
  WRITELN('ENTER TRACE SITE NUMBERS (<ETX> Terminates input list)');
  REPEAT
    WRITE('>');
    READLN(I);
    IF NOT EOF THEN
      IF (I>=0) AND (I <= 100) THEN
        DBTRACESET := DBTRACESET + [I];
  UNTIL EOF;
  RESET(INPUT);
END (*SETTRACESITES*);

PROCEDURE INIT;
VAR I:INTEGER;
BEGIN
  DBINITIALIZE;
  WRITELN('DESCRIPTOR BUILDER INITIALIZING');
  DBTYPECHECK:=FALSE;
  SETTRACESITES;
  
  (*put 5 empty groups in wa0*)
  FOR I:=0 TO 4 DO DBSHOWERR('INIT#2', DBEMPTYITEM(WA0,GROUPT,0));
  
  (*put one empty linked record in each group, thus permitting traversal
    operations to function*)
  FOR I:=1 TO 4 DO
    BEGIN
      DBSHOWERR('INIT-HOME',DBHOME(WA0));
      DBSHOWERR('INIT-SEEK',DBSEEK(WA0,I));
      DBSHOWERR('INIT#4', DBEMPTYITEM(WA0, RECORDT,0));
    END;
  DONE:=FALSE;
  REMFILE:=FALSE;
  RESET(FOUT, 'CONSOLE:');
END (*INIT*);

BEGIN (*MAIN PROGRAM*)
  INIT;
  REPEAT
    CASE GETCOMMAND(
      'B(UILD X(FER D(ISPLAY F(ILE M(OVE S(TRUCT W(RITE Q(UIT',
                                ['B','X','D','F','M','S','T','W','Q']) OF
      'B': CASE GETCOMMAND('BUILD: G(ROUP R(ECORD F(IELD L(ITERAL', 
                                ['G','R','F','L']) OF
             'F': BUILDFD;
             'G': BUILDGD;
             'L': BUILDLITERAL;
             'R': BUILDRD
           END (*CASE*);
      'X': TRANSFERPRIMITIVES;
      'D': CASE GETCOMMAND('DISPLAY: G(ROUP R(ECORD F(IELD L(ITERAL', 
                                                   ['G','R','F','L']) OF
             'F': SHOWFD(DBMAIL.STRG);
             'G': SHOWGD(DBMAIL.STRG);
             'L': SHOWLITERAL;
             'R': SHOWRD(DBMAIL.STRG)
           END (*CASE*);
      'F': FILEHANDLER;
      'M': MOVER;
      'S': SHOWDATASTRUCTURE;
      'T': SETTRACESITES;
      'W': DBSHOWERR('WRITEFIELD', DBWRITEFIELD(OUTPUT,WA0));
      'Q': DONE:=TRUE
    END (*CASE*);
  UNTIL DONE;
END.


========================================================================================
DOCUMENT :usus Folder:VOL04:dbunit.1.text
========================================================================================

(* L #5:DBUNIT.LST.TEXT*) {make sure you leave plenty of room for the listing}
(*$S+*)
UNIT DBUNIT; (*version 1.2 - 5 Feb, 1980*)
  (*Copyright 1980 Kenneth L. Bowles. All rights reserved. Permission
    is hereby granted to use this material for any non-commercial 
    purpose*)
INTERFACE
CONST
  LASTWRKINDEX=20;
  LONGINTSIZE=14;
  SETSIZE=47;
  NAMESTRSIZE=30;
  LASTFILENUM=4;
  
TYPE
  BYTE=0..255;
  DBWRKINDEX=0..LASTWRKINDEX;
  DBERRTYPE=0..100; (*not a scalar to conserve symbols*)
  DBFILENUM=0..LASTFILENUM;
  DBFIELDTYPES=(GROUPF, STRINGF, BYTEF, INTEGERF, LONGINTF,
                ADDRCOUPLEF, SETF, PICF, TEXTF);
                
  DBLEVELTYPE=(NONET, GROUPT, RECORDT, FIELDT);
  DBFINDRULE=(ASCENDING, DESCENDING, RANDOM);
  
  FILETYPE=FILE; (*compiler won't acccept 'file' as parameter type*)
  
  FLDDESCRIPTOR=
    PACKED RECORD
      OVERLINK:BYTE;
      SWITCHES:BYTE; (*bit 0 = tagged; bit 1 = fixedwidth *)
      MAXWIDTH:INTEGER;
      USECOUNT:BYTE;
      FLDTYPE:DBFIELDTYPES;
      FLDREF:INTEGER; (*points to descriptor of FLDTYPE; =0 IF NOT GROUPF*)
      (*following may get moved to Layout later*)
      ROW:BYTE;
      DATACOL:BYTE;
      LABELCOL:BYTE;
      CONTROLBITS:BYTE;
      NAME:STRING[1]  (*generally will be expanded out of rangechecking*)
    END;
  FLDDESPTR=^FLDDESCRIPTOR;
  

VAR
  DBTYPECHECK:BOOLEAN; (*if false can't use fixed length records*)
  DEBUGGING:BOOLEAN;
  F0,F1,F2,F3,F4:FILETYPE;
  
  DBMAIL:
    RECORD CASE DBMAILTYPE: DBFIELDTYPES OF
      GROUPF: ( ); (*TO BE DEFINED*)
      STRINGF: (STRG:STRING[255]);
      BYTEF: (BYT:BYTE);
      INTEGERF: (INT:INTEGER);
      LONGINTF: (LINT:INTEGER[LONGINTSIZE]);
      ADDRCOUPLE:(PGE:INTEGER;
                  GRP:INTEGER;
                  REC:INTEGER);
      SETF: (SETT:PACKED ARRAY[0..SETSIZE] OF BOOLEAN);
      PICF: ( ); (* PICTURES TO BE DEFINED *)
      TEXTF: (TXT: PACKED ARRAY[0..255] OF CHAR)
    END (*DBMAIL*);
    
  DBIORESULT:INTEGER;
  DBTRACESET:SET OF DBERRTYPE;
    
(*TRAVERSAL PRIMITIVES*)
  FUNCTION DBHOME(WI:DBWRKINDEX):DBERRTYPE;
  FUNCTION DBHEAD(WI:DBWRKINDEX):DBERRTYPE;
  FUNCTION DBNEXT(WI:DBWRKINDEX):DBERRTYPE;
  FUNCTION DBTAIL(WI:DBWRKINDEX):DBERRTYPE;
  FUNCTION DBSEEK(WI:DBWRKINDEX; WHICHITEM:INTEGER):DBERRTYPE;
  FUNCTION DBDESCEND(WI:DBWRKINDEX):DBERRTYPE;
  FUNCTION DBASCEND(WI:DBWRKINDEX):DBERRTYPE;
  FUNCTION DBFINDREC(WI:DBWRKINDEX; RULE:DBFINDRULE; FIELDNUM:INTEGER;
                     KEY:STRING; VAR RECNUM:INTEGER;
                     VAR FOUND:BOOLEAN):DBERRTYPE;
  
(*DATA TRANSFER PRIMITIVES*)
  FUNCTION DBCOPY(SOURCE,DESTINATION:DBWRKINDEX):DBERRTYPE;
  FUNCTION DBEMPTYITEM(DESTINATION:DBWRKINDEX; LVL:DBLEVELTYPE;
                                               TAG:INTEGER):DBERRTYPE;
  FUNCTION DBDELETE(DESTINATION:DBWRKINDEX):DBERRTYPE;
  FUNCTION DBBLANK(DESTINATION:DBWRKINDEX):DBERRTYPE;
  FUNCTION DBREPLACE(SOURCE,DESTINATION:DBWRKINDEX):DBERRTYPE;
  FUNCTION DBRESERVE(DESTINATION:DBWRKINDEX):DBERRTYPE;
  FUNCTION DBGET(SOURCE:DBWRKINDEX):DBERRTYPE;
  FUNCTION DBPUT(DESTINATION:DBWRKINDEX):DBERRTYPE;

(*SUPPORT PRIMITIVES*)
  FUNCTION DBWRITEFIELD(VAR FID:TEXT; SOURCE:DBWRKINDEX):DBERRTYPE;
  PROCEDURE DBGETDESCRIPTOR(LEVEL:DBLEVELTYPE; 
                            DESCRIPTORNUM:INTEGER;
                            VAR PTR:FLDDESPTR);
  FUNCTION DBTAG(NAME:STRING; SOURCE:DBWRKINDEX; VAR ITEMNUM:INTEGER):DBERRTYPE;
  
(*WORKAREA PRIMITIVES*)
  FUNCTION DBWRKOPEN(WI:DBWRKINDEX; SIZE:INTEGER):DBERRTYPE;
  FUNCTION DBWRKCLOSE(WI:DBWRKINDEX):DBERRTYPE;
  PROCEDURE ZEROWORKAREA(WI:DBWRKINDEX);

(*FILE PRIMITIVES*)
  FUNCTION DBFOPEN(FNUM:DBFILENUM; TITLE:STRING):DBERRTYPE;
  FUNCTION DBFCLOSE(FNUM:DBFILENUM):DBERRTYPE;
  FUNCTION DBFCREATE(FNUM:DBFILENUM; WASCRATCH:DBWRKINDEX;
                                     SPEXTITLE,NEWTITLE:STRING):DBERRTYPE;
  FUNCTION DBFREMOVE(FNUM:DBFILENUM):DBERRTYPE;
  FUNCTION DBGETPAGE(FNUM:DBFILENUM; DESTINATION:DBWRKINDEX;
                                     PAGENUM:INTEGER):DBERRTYPE;
  FUNCTION DBPUTPAGE(FNUM:DBFILENUM; SOURCE:DBWRKINDEX;
                                     PAGENUM:INTEGER):DBERRTYPE;

(*DESCRIPTOR INITIALIZING PRIMITIVES*)
  FUNCTION DBGROUPINIT(FNUM:DBFILENUM; VAR GROUPNUM:INTEGER;
                                              GROUPNAME:STRING):DBERRTYPE;
  FUNCTION DBGROUPRELEASE(GROUPNUM:INTEGER):DBERRTYPE;
  
(*INITIALIZATION*)
  PROCEDURE DBINITIALIZE;
  
(*ORDERLY TERMINATION*)
  FUNCTION DBCLOSEDOWN:DBERRTYPE;
  
(*ERROR REPORTING AND DIAGNOSTICS*)
  PROCEDURE DBSHOWERROR(S:STRING; ERRNUM:DBERRTYPE);
  PROCEDURE DBITEMINFO(WI:DBWRKINDEX; VAR LEVEL:DBLEVELTYPE;
           VAR ITEMNUM,OFFSET,DESCRIPTORNUM:INTEGER; VAR NAME:STRING);
  
(**************************************************************)
IMPLEMENTATION
CONST
  PAGELASTBYTE=4095;
  LASTSPECIALGROUP=6;
  LASTWRKSTACKSLOT=9;
  LASTGROUPDESCRIPTOR=255;
  LASTRECDESCRIPTOR=255;
  LASTFIELDDESCRIPTOR=255;
  LINKESCAPE=240;
  DBNUL=0;
  ONEITEMRECLINK=6;
  
TYPE
  PAGEPTR=0..PAGELASTBYTE;
  PAGETYPE=PACKED ARRAY[PAGEPTR] OF BYTE;
  
  (*work area information block - WIB *)
  WIBENTRY=
    RECORD
      OFFSET:PAGEPTR;
      LEVEL:DBLEVELTYPE;
      DESCRIPTORNUM:INTEGER;
      ITEMNUM:INTEGER;
    END;
  TOSRANGE=0..LASTWRKSTACKSLOT;
  WIBTYPE=ARRAY[TOSRANGE] OF WIBENTRY;
  WIBPTR=^WIBTYPE;
  
  (*following are dummy types used for heap allocation of workareas*)
  WATYPE=PACKED ARRAY[0..63] OF BYTE; (* WA will be multiple of these*)
  WAPTR=^WATYPE;
  ONEWORDPTR=^INTEGER;
  REFLIST=ARRAY[0..0] OF INTEGER; (*index with range checking off*)
  
  (*fixed layout parts of descriptors*)
  GRPDESCRIPTOR=
    PACKED RECORD
      OVERLINK:BYTE; (*descriptor longer than 240 bytes not allowed*)
      SWITCHES:BYTE; (*packed array gets allocated in whole words*)
                     (*bit 0 = tagged; bit 1 = linked *)
      RECLINK:BYTE;
      FILLER:BYTE;
      RECNUM:REFLIST;
      (*expand here with additional recnum's*)
    END;
  GRPDESPTR=^GRPDESCRIPTOR;
  
  RECDESCRIPTOR=
    PACKED RECORD
      OVERLINK:BYTE;
      SWITCHES:BYTE; (*bit 0 = tagged; bit 1 = fixed width; bit 2 = sparse *)
      SIZE:INTEGER;
      FIRSTLITEMNUM:BYTE; (*set to 1 more than last fixed itemnumber if
                            there are only fixed fields in the record*)
      USECOUNT:BYTE;
      LAYOUT:BYTE; (*on a large system this could be declared TAG*)
      LASTFLDLINK:BYTE; (*points to name field, indirect upper bound of
                            FLDREF array*)
      FLDREF:ARRAY [0..0] OF
               PACKED RECORD
                 FDNUM: 0..LASTFIELDDESCRIPTOR;
                 FLDOFFSET:BYTE; (*for fixed size fields; =0 for linked*)
               END;
      (*expand here with additional fldref's*)
    END;
  RECDESPTR=^RECDESCRIPTOR;

  CRACKSWTYPE=  (*for accessing individual switch control bits*)
    PACKED RECORD
      CASE BOOLEAN OF
        TRUE:(BL:BYTE; BH:BYTE);
        FALSE:(A:PACKED ARRAY[0..15] OF BOOLEAN);
      END (*CRACKSWTYPE*);

VAR
  HEAPMARKER:ONEWORDPTR;
  OPENFILES: PACKED ARRAY[0..LASTFILENUM] OF BOOLEAN;
  
  (*page numbers of fixed numbered groups at beginning of file*)
  SPECIALGROUPPAGE: ARRAY[0..LASTSPECIALGROUP] OF INTEGER;
  
  (*all access to workareas flows via WRKTABLE*)
  WRKTABLE: ARRAY[DBWRKINDEX] OF
    RECORD
      TOS: TOSRANGE; (*top of stack*)
      WIB: WIBPTR; (*points to stack of offsets in WIB; NIL if none allocated*)
      WSIZE: INTEGER; (*size of Workarea in bytes*)
      SPACEINUSE: INTEGER; (*initially 0*)
      WA: WAPTR  (*the workarea itself*)
    END;
      
  (*all access to on-line descriptors is via these arrays*)
  ACTIVEGROUPS: ARRAY[0..LASTGROUPDESCRIPTOR] OF GRPDESPTR;
  ACTIVERECORDS: ARRAY[0..LASTRECDESCRIPTOR] OF RECDESPTR;
  ACTIVEFIELDS: ARRAY[0..LASTFIELDDESCRIPTOR] OF FLDDESPTR;
  
  (*Lower and Upper bound for tracing*)
  TRACELB,TRACEUB:INTEGER;
  
      

========================================================================================
DOCUMENT :usus Folder:VOL04:dbunit.2.text
========================================================================================

PROCEDURE SETTRACESITES;
CONST RET=13;
VAR I:INTEGER;
  CH:CHAR;
BEGIN
  WRITELN;
  WRITELN('Enter trace site numbers (-1 terminates)');
  REPEAT
    WRITE('>');
    READLN(I);
    IF (I>=0) AND (I<=100) THEN
      BEGIN
        IF I IN DBTRACESET THEN WRITE(' ON')
                           ELSE WRITE(' OFF');
        WRITE('   S(et or R(eset ?');
        REPEAT
          READ(CH);
        UNTIL CH IN ['R','S'];
        IF CH='S' THEN
          DBTRACESET:=DBTRACESET+[I]
        ELSE
          DBTRACESET:=DBTRACESET-[I];
      END;
    WRITELN;
  UNTIL I<0;
  REPEAT
    WRITE('L(ower Bound=', TRACELB, '  U(pper Bound=', TRACEUB, '  <RET>');
    READ(CH);
    IF EOLN THEN CH:=CHR(RET) ELSE WRITELN;
    IF CH = 'L' THEN
      BEGIN
        WRITE('  LB:');
        READLN(TRACELB);
      END
    ELSE
      IF CH = 'U' THEN
        BEGIN
          WRITE('  UB:');
          READLN(TRACEUB);
        END;
  UNTIL CH = CHR(RET);
END (*SETTRACESITES*);
  
PROCEDURE TRACEWA(TRACENUM:INTEGER; WI:DBWRKINDEX);
VAR I,L,P:INTEGER;
  DONE:BOOLEAN;
  S:STRING[10];
BEGIN
  DONE:=FALSE;
  WHILE (TRACENUM IN DBTRACESET) AND (NOT DONE) DO
    BEGIN
      WRITELN;
      WITH WRKTABLE[WI] DO
        BEGIN
          WRITELN('TRACE # ', TRACENUM, '  WA:', WI,
                  '  TOS:', TOS,
                  '  WSIZE:', WSIZE,
                  '  SPACEINUSE:', SPACEINUSE);
          IF WIB = NIL THEN
            WRITELN('  WIB = NIL ****')
          ELSE
            FOR L:=0 TO TOS DO
              WITH WIB^[L] DO
                BEGIN
                  WRITE('  L:', L, ':  OFFSET:', OFFSET, '  LEVEL:');
                  CASE LEVEL OF
                    GROUPT: WRITE('GROUP');
                    RECORDT: WRITE('RECORD');
                    FIELDT: WRITE('FIELD');
                    NONET: WRITE('NONE')
                  END (*CASE*);
                  WRITELN('  DESCR#:', DESCRIPTORNUM);
(*$L #5:DBUXXX.LST.TEXT*)
                  
                END (*WITH WIB*);
          P:=TRACELB;
          IF WA = NIL THEN
            WRITELN('    WA = NIL')
          ELSE
            WHILE P <= TRACEUB DO
              BEGIN
                WRITE('    ', P:3, ':');
                FOR I:=0 TO 9 DO
                  BEGIN
(*$R-*)
                    WRITE(WA^[P]:4);
(*$R+*)
                    P:=P+1;
                  END;
                WRITELN;
              END;
          WRITELN('<RET> CONTINUES; "D<RET>" TOGGLES DEBUGGING');
          WRITE(' "T<RET>" TO CHANGE TRACE SITES:');
          READLN(S);
          DONE:=TRUE;
          IF LENGTH(S) > 0 THEN
            IF S[1] = 'T' THEN
              BEGIN
                SETTRACESITES;
                WRITE('<RET> CONTINUES; R<RET> RE-DISPLAYS');
                READLN(S);
                IF LENGTH(S) > 0 THEN
                  DONE:=(S[1] <> 'R');
              END
            ELSE
              IF S[1] = 'D' THEN
                DEBUGGING:=NOT DEBUGGING;
        END (*WITH WRKTABLE*);
    END (*DEBUGGING*);
END (*TRACEWA*);

PROCEDURE DBSHOWERROR(*S:STRING; ERRNUM: DBERRTYPE*);
CONST
  RET=13;
  CAN=24;
  ESC=27;
VAR CH:CHAR;
BEGIN
  IF (ERRNUM<>0) OR DEBUGGING THEN
    (*temporary substitute for display of actual message*)
    BEGIN
      WRITELN;
      WRITELN('DBERROR # ', ERRNUM, ' IN ', S);
      WRITELN(' <RET> CONTINUES, <ESC> ABORTS, <CAN> TERMINATES');
      WRITELN(' "T" TO CHANGE TRACE SITES');
      REPEAT
        READ(CH);
        IF EOLN THEN CH:=CHR(RET);
      UNTIL CH IN [CHR(RET), CHR(CAN), CHR(ESC), 'T'];
      IF CH = CHR(CAN) THEN
        EXIT(PROGRAM);
      IF CH = CHR(ESC) THEN
        HALT;
      IF CH = 'T' THEN SETTRACESITES;
    END;
END (*DBSHOWERROR*);

PROCEDURE DBITEMINFO(*WI:DBWRKINDEX; VAR LEVEL:DBLEVELTYPE;
            VAR ITEMNUM,OFFSET,DESCRIPTORNUM:INTEGER; VAR NAME:STRING*);
TYPE
  TRICKPTR =
    RECORD CASE BOOLEAN OF
      TRUE: (R:RECDESPTR);
      FALSE:(G:GRPDESPTR)
    END;
VAR FP:FLDDESPTR;
  TP:TRICKPTR;
  NILMSG:STRING[25];
  DPTR:INTEGER;
  PAB:PACKED ARRAY[0..255] OF BYTE;
  
  PROCEDURE EXTRACTNAME(TP:TRICKPTR; DPTR:INTEGER);
  BEGIN
    (*get the name field length into PAB[DPTR]*)
    MOVELEFT(TP.R^, PAB, DPTR+1);
    (*this time transfer the name*)
    MOVELEFT(TP.R^, PAB, DPTR+PAB[DPTR]);
    MOVELEFT(PAB[DPTR], NAME, PAB[DPTR]);
    (*convert to string*)
    DELETE(NAME, LENGTH(NAME), 1);
  END (*EXTRACTNAME*);
  
BEGIN (*DBITEMINFO*)
  WITH WRKTABLE[WI] DO
    BEGIN
      LEVEL:=WIB^[TOS].LEVEL;
      ITEMNUM:=WIB^[TOS].ITEMNUM;
      OFFSET:=WIB^[TOS].OFFSET;
      DESCRIPTORNUM:=WIB^[TOS].DESCRIPTORNUM;
      NILMSG:='NIL Descriptor Pointer';
      WITH WIB^[TOS] DO
        BEGIN
          IF (DESCRIPTORNUM < 0) THEN
            NAME:='Uninitialized Descriptor Number'
          ELSE
            CASE LEVEL OF
              FIELDT:
                BEGIN
                  FP:=ACTIVEFIELDS[DESCRIPTORNUM];
                  IF FP=NIL THEN
                    NAME:=NILMSG
                  ELSE
                    NAME:=FP^.NAME;
                END (*FIELDT:*);
              RECORDT:
                BEGIN
                  TP.R:=ACTIVERECORDS[DESCRIPTORNUM];
                  IF TP.R = NIL THEN
                    NAME:=NILMSG
                  ELSE
                    BEGIN
                      DPTR:=7 + TP.R^.LASTFLDLINK;
                      EXTRACTNAME(TP,DPTR);
                    END;
                END (*RECORDT:*);
              GROUPT:
                BEGIN
                  TP.G:=ACTIVEGROUPS[DESCRIPTORNUM];
                  IF TP.G = NIL THEN
                    NAME:=NILMSG
                  ELSE
                    BEGIN
                      DPTR:=2 + TP.G^.RECLINK;
                      EXTRACTNAME(TP,DPTR);
                    END;
                END (*GROUPT:*)
            END (*CASES*);
        END (*WITH WIB^*);
    END (*WITH*);
END (*DBITEMINFO*);
  
  (*$L-*)
  
FUNCTION CHECKHEAP(SIZE:INTEGER):BOOLEAN;
VAR MA:INTEGER;
BEGIN
  MA:=MEMAVAIL + MEMAVAIL;
  CHECKHEAP:=(MA<0) (* i.e. more than 32767 *)
              OR (MA>SIZE);
END (*CHECKHEAP*);

FUNCTION MAX(X,Y:INTEGER):INTEGER;
BEGIN
  IF X>Y THEN MAX:=X ELSE MAX:=Y;
END;

FUNCTION CHECKWORKAREA(WI:DBWRKINDEX; SIZE:INTEGER):DBERRTYPE;
BEGIN
  WITH WRKTABLE[WI] DO
    IF (WA=NIL) OR (WIB=NIL) THEN
      CHECKWORKAREA:=8 (*workarea not open*)
    ELSE
      IF WSIZE<>SIZE THEN
        CHECKWORKAREA:=2
      ELSE
        CHECKWORKAREA:=0;
END (*CHECKWORKAREA*);

FUNCTION HEAPALLOCATE(SIZE:PAGEPTR):DBERRTYPE;
VAR
    P1:ONEWORDPTR;
    P64:WAPTR;
BEGIN
  IF CHECKHEAP(SIZE) THEN
    BEGIN
      WHILE SIZE >= 64 DO
        BEGIN
          NEW(P64);
          SIZE:=SIZE-64;
        END;
      IF ODD(SIZE) THEN
        SIZE:=SIZE+1;
      WHILE SIZE>0 DO
        BEGIN
          NEW(P1);
          SIZE:=SIZE-2;
        END;
      HEAPALLOCATE:=0;
    END
  ELSE
    HEAPALLOCATE:=1; (*insufficient memory*)
END (*HEAPALLOCATE*);

PROCEDURE ZEROWORKAREA(*WI:DBWRKINDEX*);
(*unprotected -- call checkworkarea if in doubt*)
VAR I:INTEGER;
BEGIN
  WITH WRKTABLE[WI] DO
    BEGIN
      FILLCHAR(WA^,WSIZE,CHR(0));
      FOR I:=0  TO LASTWRKSTACKSLOT DO
        WITH WIB^[I] DO
          BEGIN
            OFFSET:=0;
            LEVEL:=NONET;
            DESCRIPTORNUM:=-1;
            ITEMNUM:=-1;
          END;
      WITH WIB^[0] DO
        BEGIN
          LEVEL:=GROUPT;
          OFFSET:=0;
          ITEMNUM:=0;
        END;
      SPACEINUSE:=0;
      TOS:=0;
    END (*WITH*);
END (*ZEROWORKAREA*);

FUNCTION NEXTLEVEL(LVL:DBLEVELTYPE):DBLEVELTYPE;
BEGIN
  IF LVL=NONET THEN
    NEXTLEVEL:=NONET
  ELSE
    IF LVL=FIELDT THEN
      NEXTLEVEL:=GROUPT
    ELSE
      NEXTLEVEL:=SUCC(LVL);
END (*NEXTLEVEL*);

FUNCTION MOVETAIL(DESTINATION:DBWRKINDEX; DELTA:INTEGER;
                  OFFSET:PAGEPTR):DBERRTYPE;
(*service routine for data transfer functions. shifts tail of workarea
  after checking whether requested shift is legal *)
BEGIN
  MOVETAIL:=0;
  WITH WRKTABLE[DESTINATION] DO
    BEGIN
      TRACEWA(2,DESTINATION);
      IF (SPACEINUSE+DELTA) >= WSIZE THEN
        MOVETAIL:=14 (*insufficient space*)
      ELSE
        IF (OFFSET+DELTA) < 0 THEN
          MOVETAIL:=17 (*attempted negative offset*)
        ELSE
          BEGIN
(*$R-*)
            IF DELTA > 0 THEN
              BEGIN
                MOVERIGHT(WA^[OFFSET], WA^[OFFSET+DELTA], SPACEINUSE-OFFSET);
                FILLCHAR(WA^[OFFSET],DELTA,CHR(0));
              END
            ELSE
              IF DELTA < 0 THEN
                MOVELEFT(WA^[OFFSET], WA^[OFFSET+DELTA], SPACEINUSE-OFFSET);
            SPACEINUSE:=SPACEINUSE+DELTA;
            IF DELTA < 0 THEN
              FILLCHAR(WA^[SPACEINUSE], -DELTA, CHR(0));
(*$R+*)
          END;
      TRACEWA(3,DESTINATION);
    END (*WITH*);
END (*MOVETAIL*);

FUNCTION LINKVALUE(WA:WAPTR; OFFSET: PAGEPTR):PAGEPTR;
VAR B1:BYTE;
BEGIN
(*$R-*)
  B1:=WA^[OFFSET];
  IF B1 < LINKESCAPE THEN
    LINKVALUE:=B1
  ELSE
    LINKVALUE:=(B1-LINKESCAPE+1)*LINKESCAPE+WA^[OFFSET+1];
(*$R+*)
END (*LINKVALUE*);

PROCEDURE SAVEBIGLINK(DESTINATION:DBWRKINDEX; NEWLINK:INTEGER; OFFSET:PAGEPTR);
BEGIN
  WITH WRKTABLE[DESTINATION] DO
    BEGIN
(*$R-*)
      IF NEWLINK < LINKESCAPE THEN
        WA^[OFFSET]:=NEWLINK
      ELSE
        BEGIN
          WA^[OFFSET]:=(NEWLINK DIV LINKESCAPE)+(LINKESCAPE-1);
          WA^[OFFSET+1]:=(NEWLINK MOD LINKESCAPE);
        END;
(*$R+*)
    END;
END (*SAVEBIGLINK*);

FUNCTION LINKDELTA(DESTINATION:DBWRKINDEX; DELTA:INTEGER;
                                           OFFSET:PAGEPTR):DBERRTYPE;
(*add delta to the link at offset*)
VAR B1,OLDLINK,NEWLINK:INTEGER;
  CHOP:
    PACKED RECORD CASE BOOLEAN OF
      TRUE: (INT:INTEGER);
      FALSE: (LB:BYTE; HB:BYTE)
    END;

BEGIN
  LINKDELTA:=0;
  TRACEWA(4,DESTINATION);
  WITH WRKTABLE[DESTINATION] DO
    BEGIN
      OLDLINK:=LINKVALUE(WA,OFFSET);
      IF ((OFFSET+OLDLINK+DELTA) >= WSIZE) OR ((OLDLINK+DELTA) < 0) THEN
        LINKDELTA:=16 (*out of range*)
      ELSE
        BEGIN
          NEWLINK:=OLDLINK+DELTA;
          IF NEWLINK > 4079 (* (256-LINKESCAPE)*256+(LINKESCAPE-1) *) THEN
            LINKDELTA:=18 (* too large to be expressed as a link *)
          ELSE
            IF OLDLINK < LINKESCAPE THEN (* one byte *)
              BEGIN
                IF NEWLINK < LINKESCAPE THEN (*also one byte*)
  (*$R-*)
                  WA^[OFFSET]:=NEWLINK
                ELSE
                  BEGIN
                    NEWLINK:=NEWLINK+1; (* one more byte for 2-byte link *)
                    DBSHOWERR('LINKDELTA#1', MOVETAIL(DESTINATION,1,OFFSET));
                    SAVEBIGLINK(DESTINATION,NEWLINK,OFFSET);
                  END;
              END (*OLDLINK < LINKESCAPE*)
            ELSE
              BEGIN (*OLDLINK >= LINKESCAPE i.e. 2 bytes*)
                IF (NEWLINK < LINKESCAPE) THEN
                  BEGIN
                    IF NEWLINK > 1 THEN
                      NEWLINK:=NEWLINK-1; (*newlink 1-byte, oldlink was 2*)
                                          (*however, cannot go < 1*)
                    DBSHOWERR('LINKDELTA#2', MOVETAIL(DESTINATION,-1,
                           OFFSET + 1(*avoid tromping on previous data*)));
                    WA^[OFFSET]:=NEWLINK;
  (*$R+*)
                  END
                ELSE (*both old and new are 2 bytes*)
                  SAVEBIGLINK(DESTINATION,NEWLINK,OFFSET);
              END (*OLDLINK >= LINKESCAPE*);
        END (* (OFFSET+DELTA) < WSIZE *);
    END (*WITH WRKTABLE*);
  TRACEWA(5,DESTINATION);
END (*LINKDELTA*);

PROCEDURE FIXLINKS(DESTINATION:DBWRKINDEX; STACKCELL:TOSRANGE; DELTA:INTEGER);
(*following a change in item contents, all enclosing levels must have 
  links corrected*)
VAR ISTACK:INTEGER;
BEGIN
  WITH WRKTABLE[DESTINATION] DO
    FOR ISTACK:=STACKCELL DOWNTO 0 DO
      WITH WIB^[ISTACK] DO
        DBSHOWERR('FIXLINKS', LINKDELTA(DESTINATION,DELTA,OFFSET));
  TRACEWA(16,DESTINATION);
END (*FIXLINKS*);
              
FUNCTION LINKSIZE(LINKV:INTEGER):INTEGER;
BEGIN
  IF LINKV >= LINKESCAPE THEN LINKSIZE:=2
                         ELSE LINKSIZE:=1;
END (*LINKSIZE*);

PROCEDURE STEPLINK(WI:DBWRKINDEX);
(*advance offset at current level to step over a link-like item (either
  link or tag*)
BEGIN
  WITH WRKTABLE[WI] DO
    WITH WIB^[TOS] DO
      OFFSET:=OFFSET+1+ORD(LINKVALUE(WA,OFFSET) >= LINKESCAPE);
END (*STEPLINK*);

PROCEDURE NEXTLINK(WA:WAPTR; VAR OFFSET:PAGEPTR; VAR ITEMNUM:INTEGER);
(*advance offset to next location on list*)
VAR LINKV:INTEGER;
BEGIN
  LINKV:=LINKVALUE(WA,OFFSET);
  (*combine this guy and linkvalue call into one external proc*)
  IF LINKV > 0 THEN
    BEGIN
      OFFSET:=OFFSET+LINKV;
      ITEMNUM:=ITEMNUM+1;
    END;
END (*NEXTLINK*);

PROCEDURE SETDESCRIPTORNUM(WI:DBWRKINDEX);
(*gets descriptor number for field # ITEMNUM from list in record descriptor*)
(* group descriptor from enclosing field or tag*)
(* record descriptor from group*)
VAR RP:RECDESPTR;
  GP:GRPDESPTR;
  FP:FLDDESPTR;
  LINKV:INTEGER;
BEGIN
  WITH WRKTABLE[WI] DO
    CASE WIB^[TOS].LEVEL OF
      FIELDT:
        BEGIN (*refer to record's list of descriptor pointers*)
          RP:=ACTIVERECORDS[WIB^[TOS-1].DESCRIPTORNUM];
          WITH RP^ DO
            IF (((LASTFLDLINK-1) DIV SIZEOF(FLDREF))-2) < WIB^[TOS].ITEMNUM THEN
              (*Note: one item only (i.e. itemnum=0) goes with
                LASTFLDLINK = 5 if FLDREF is 2 bytes; end of list is one
                FLDREF entry with value of zero as stopper*)
              WIB^[TOS].DESCRIPTORNUM:=-1 (*no such field*)
            ELSE
(*$R-*)
              WITH WIB^[TOS] DO
                DESCRIPTORNUM:=RP^.FLDREF[ITEMNUM].FDNUM;
(*$R-*)
        END;
      GROUPT:
        (*all groups are tagged*)
        (*descriptor number is tag value at page level*)
        IF TOS=0 THEN
          WITH WIB^[TOS] DO
            BEGIN
              LINKV:=LINKVALUE(WA,OFFSET);
              DESCRIPTORNUM:=LINKVALUE(WA,(OFFSET+LINKSIZE(LINKV)));
            END
        ELSE
          BEGIN (*get from parent field descriptor*)
            FP:=ACTIVEFIELDS[WIB^[TOS-1].DESCRIPTORNUM];
            WITH WIB^[TOS] DO
              DESCRIPTORNUM:=FP^.FLDREF;
          END;
      RECORDT:
        BEGIN (*record is tagged if group specifies mixed records*)
          GP:=ACTIVEGROUPS[WIB^[TOS-1].DESCRIPTORNUM];
          WITH WIB^[TOS] DO
            WITH GP^ DO
              IF RECLINK > ONEITEMRECLINK THEN (*mixed*)
                BEGIN
                  LINKV:=LINKVALUE(WA,OFFSET);
                  (*get the tag*)
                  DESCRIPTORNUM:=LINKVALUE(WA,OFFSET+LINKSIZE(LINKV));
                END
              ELSE
                DESCRIPTORNUM:=RECNUM[0];
        END (*RECORDT:*);
    END (*CASES*);
END (*SETDESCRIPTORNUM*);


(*TRAVERSAL PRIMITIVES*)
FUNCTION DBHOME(*WI:DBWRKINDEX):DBERRTYPE*);
(*zero out workstack for the workarea, except for its initial location*)
VAR I:INTEGER;
BEGIN
  WITH WRKTABLE[WI] DO
    BEGIN
      IF WA=NIL THEN
        DBHOME:=8 (* workarea not open *)
      ELSE
        BEGIN
          FOR I:=1 TO TOS DO
            WITH WIB^[I] DO
              BEGIN
                OFFSET:=0;
                LEVEL:=NONET;
                DESCRIPTORNUM:=-1;
                ITEMNUM:=-1;
              END;
          WITH WIB^[0] DO
            BEGIN
              OFFSET:=0;
              ITEMNUM:=0;
              IF DBTYPECHECK THEN SETDESCRIPTORNUM(WI);
            END;
          TOS:=0;
        END (* WA <> NIL *);
    END (*WITH WRKTABLE*);
  TRACEWA(6,WI);
END (*DBHOME*);

FUNCTION DBNEXT(*WI:DBWRKINDEX):DBERRTYPE*);
(*move to head of next linked item*)
VAR RP:RECDESPTR;
  BEFOREITEM,DUMMY:INTEGER;
BEGIN
  DBNEXT:=0;
  TRACEWA(7,WI);
  WITH WRKTABLE[WI] DO
    WITH WIB^[TOS] DO
      BEGIN
        BEFOREITEM:=ITEMNUM;
        IF LEVEL = FIELDT THEN
          BEGIN
            RP:=ACTIVERECORDS[WIB^[TOS-1].DESCRIPTORNUM];
            IF RP = NIL THEN
              DBNEXT:=32
            ELSE
              WITH RP^ DO
                BEGIN
                  IF ITEMNUM < FIRSTLITEMNUM THEN
                    BEGIN
                      ITEMNUM:=ITEMNUM+1;
                      IF ITEMNUM = FIRSTLITEMNUM THEN
                        (*transition from fixed to variable fields*)
                        NEXTLINK(WA,OFFSET,DUMMY);
                    END
                  ELSE
                    NEXTLINK(WA,OFFSET,ITEMNUM);
                END (*WITH RP^*);
          END (*LEVEL=FIELDT*)
        ELSE
          (*all items assumed to be linked & all lists stopped with nul*)
          NEXTLINK(WA,OFFSET,ITEMNUM);
        IF BEFOREITEM = ITEMNUM THEN
          DBNEXT:=27 (*can't find any more*)
        ELSE
          IF DBTYPECHECK THEN SETDESCRIPTORNUM(WI);
      END;
  TRACEWA(8,WI);
END (*DBNEXT*);

FUNCTION DBHEAD(*WI:DBWRKINDEX):DBERRTYPE*);
(*move to head of list at current level*)
VAR LINKV:INTEGER;
  RP:RECDESPTR;
  PARENTOFFSET:PAGEPTR;
BEGIN
  WITH WRKTABLE[WI] DO
    BEGIN
      IF TOS > 0 THEN
        BEGIN
          PARENTOFFSET:=WIB^[TOS-1].OFFSET;
          LINKV:=LINKVALUE(WA,PARENTOFFSET);
          WITH WIB^[TOS] DO
            BEGIN
              OFFSET:=PARENTOFFSET+LINKSIZE(LINKV);
              IF LEVEL = RECORDT THEN (*step over parent group's tag*)
                STEPLINK(WI);
            END;
        END
      ELSE
        (*global group level - point to head of page*)
        WIB^[TOS].OFFSET:=0;
      WIB^[TOS].ITEMNUM:=0;
      IF DBTYPECHECK THEN SETDESCRIPTORNUM(WI);
    END (*WITH WRKTABLE*);
  TRACEWA(30,WI);
END (*DBHEAD*);

FUNCTION DBTAIL(*WI:DBWRKINDEX):DBERRTYPE*);
(*point to link position following last non-nul item at current level*)
VAR RP:RECDESPTR;
  BEFOREITEMNUM:INTEGER;
BEGIN
  WITH WRKTABLE[WI] DO
    WITH WIB^[TOS] DO
      BEGIN
        BEFOREITEMNUM:=ITEMNUM;
        REPEAT
          NEXTLINK(WA,OFFSET,ITEMNUM);
        UNTIL LINKVALUE(WA,OFFSET)=0;
        IF LEVEL = FIELDT THEN
          BEGIN
            RP:=ACTIVERECORDS[WIB^[TOS-1].DESCRIPTORNUM];
            IF RP = NIL THEN
              DBTAIL:=32
            ELSE
              WITH RP^ DO
                IF BEFOREITEMNUM < FIRSTLITEMNUM THEN
                  ITEMNUM:=ITEMNUM + (FIRSTLITEMNUM-BEFOREITEMNUM-1);
          END (*LEVEL=FIELDT*);
        SETDESCRIPTORNUM(WI);
      END (*WITH WIB*);
  TRACEWA(29,WI);
END (*DBTAIL*);



========================================================================================
DOCUMENT :usus Folder:VOL04:dbunit.3.text
========================================================================================

FUNCTION DBSEEK(*WI:DBWRKINDEX; WHICHITEM:INTEGER):DBERRTYPE*);
(*move pointer to item # itemnum in current level*)
VAR NEWOFFSET,I,LINKV:INTEGER;
  CRACKSW:CRACKSWTYPE;
  RP:RECDESPTR;

  PROCEDURE FOLLOWLINKS(NEWOFFSET:PAGEPTR; COUNT:INTEGER);
  VAR I:INTEGER;
  BEGIN
    (*all items assumed to be linked & all lists stopped with nul*)
    WITH WRKTABLE[WI] DO
      WITH WIB^[TOS] DO
        BEGIN
          LINKV:=LINKVALUE(WA,NEWOFFSET);
          (*following should be in external procedure for speed*)
          I:=0;
          WHILE (LINKV > 0 ) AND (I < COUNT) DO
            BEGIN
              NEWOFFSET:=NEWOFFSET+LINKV;
              LINKV:=LINKVALUE(WA,NEWOFFSET);
              I:=I+1;
            END;
          (*end of external proc*)
          IF (LINKV = 0) AND (I < COUNT) THEN
            DBSEEK:=27  (*cannot find requested item*)
          ELSE
            BEGIN
              OFFSET:=NEWOFFSET;
              ITEMNUM:=ITEMNUM+COUNT;
            END;
        END (*WITH WIB*);
  END (*FOLLOWLINKS*);
  
BEGIN (*DBSEEK*)
  DBSEEK:=0;
  TRACEWA(9,WI);
  WITH WRKTABLE[WI] DO
    WITH WIB^[TOS] DO
      BEGIN
        DBSHOWERR('SEEK#1',DBHEAD(WI));
        IF DBTYPECHECK THEN
          BEGIN (*assume that we are at head of this level!*)
            CASE LEVEL OF
              GROUPT,RECORDT:
                BEGIN  (*all groups and records are linked*)
                  IF WHICHITEM > 0 THEN
                    BEGIN
                      (*item #0 in a record may contain several fixed fields*)
                      FOLLOWLINKS(OFFSET,WHICHITEM); 
                      SETDESCRIPTORNUM(WI);
                    END;
                END (*GROUPT*);
              FIELDT:
                BEGIN
                  IF WHICHITEM > 0 THEN
                    BEGIN
                      (*now get offset of field within the record*)
                      RP:=ACTIVERECORDS[WIB^[TOS-1].DESCRIPTORNUM];
                      IF RP = NIL THEN
                        DBSEEK:=32
                      ELSE
                        WITH RP^ DO
                          BEGIN
                            IF WHICHITEM < FIRSTLITEMNUM THEN
                              ITEMNUM:=WHICHITEM
                            ELSE
                              BEGIN (*linked field*)
                                ITEMNUM:=FIRSTLITEMNUM-1;
                                FOLLOWLINKS(OFFSET,(WHICHITEM - FIRSTLITEMNUM 
                                                  + ORD(FIRSTLITEMNUM > 0)));
                              END (*linked field*);
                          END (*WITH RP^*);
                        SETDESCRIPTORNUM(WI); 
                    END;
                END (*FIELDT*)
            END (*CASE*);
          END (*IF DBTYPECHECK*)
        ELSE
          FOLLOWLINKS(OFFSET,WHICHITEM);
      END (*WITH*);
  TRACEWA(10,WI);
END (*DBSEEK*);

FUNCTION DBDESCEND(*WI:DBWRKINDEX):DBERRTYPE*);
VAR LINKV:PAGEPTR;
  OLDLVL:DBLEVELTYPE;
  LINKED:BOOLEAN;
  GP:GRPDESPTR;
  RP:RECDESPTR;
  FP:FLDDESPTR;
  CRACKSW:CRACKSWTYPE;

  PROCEDURE DOWNLINK;
  (*move down to head of enclosed level*)
  VAR PARENTOFFSET:PAGEPTR;
  BEGIN
    WITH WRKTABLE[WI] DO
      BEGIN
        WITH WIB^[TOS] DO
          BEGIN
            LINKV:=LINKVALUE(WA,OFFSET);
            PARENTOFFSET:=OFFSET;
          END;
        IF LINKV = 0 THEN
          DBDESCEND:=19 (*at end of list, can't descend*)
        ELSE
          BEGIN
            OLDLVL:=WIB^[TOS].LEVEL;
            IF OLDLVL=NONET THEN
              DBDESCEND:=20 (*can't continue from nonet*)
            ELSE
              BEGIN
                TOS:=TOS+1;
                WITH WIB^[TOS] DO
                  BEGIN
                    OFFSET:=PARENTOFFSET+LINKSIZE(LINKV);
                    IF OLDLVL = GROUPT THEN
                      (*step over group's tag*)
                      STEPLINK(WI);
                    LEVEL:=NEXTLEVEL(OLDLVL);
                    ITEMNUM:=0;
                  END (*WITH*);
              END (*LEVEL<>NONET*);
          END (*LINKV<>0*);
      END (*WITH WRKTABLE*);
  END (*DOWNLINK*);
  
BEGIN (*DBDESCEND*)
  DBDESCEND:=0;
  TRACEWA(11,WI);
  IF DBTYPECHECK THEN
    WITH WRKTABLE[WI] DO
      BEGIN
        CASE WIB^[TOS].LEVEL OF
          GROUPT:
            BEGIN
              (*point to first record in group*)
              GP:=ACTIVEGROUPS[WIB^[TOS].DESCRIPTORNUM];
              IF GP=NIL THEN
                DBDESCEND:=33
              ELSE
                BEGIN
                  DOWNLINK;
                  SETDESCRIPTORNUM(WI);
                END;
            END (*GROUPT*);
          RECORDT:
            BEGIN (*point to first field in record*)
              RP:=ACTIVERECORDS[WIB^[TOS].DESCRIPTORNUM];
              IF RP=NIL THEN
                DBDESCEND:=32
              ELSE
                BEGIN
                  DOWNLINK;
                  SETDESCRIPTORNUM(WI);
                END (*RP<>NIL*);
            END (*RECORDT*);
          FIELDT:
            BEGIN
              (*if the field is structured, point to the contained group*)
              FP:=ACTIVEFIELDS[WIB^[TOS].DESCRIPTORNUM];
              IF FP=NIL THEN
                DBDESCEND:=31
              ELSE
                WITH FP^ DO
                  IF FLDTYPE <> GROUPF THEN
                    DBDESCEND:=34 (*can't descend into a simple field*)
                  ELSE
                    BEGIN
                      DOWNLINK;
                      SETDESCRIPTORNUM(WI);
                    END;
            END (*FIELDT*)
        END (*CASES*);
      END (*WITH WRKTABLE*)
  ELSE
    (*assume that next level, if any, is linked*)
    DOWNLINK;
  TRACEWA(12,WI);
END (*DBDESCEND*);

FUNCTION DBASCEND(*WI:DBWRKINDEX):DBERRTYPE*);
(*return to enclosing level*)
BEGIN
  WITH WRKTABLE[WI] DO
    BEGIN
      IF TOS > 0 THEN
        BEGIN
          WITH WIB^[TOS] DO
            BEGIN
              OFFSET:=0;
              LEVEL:=NONET;
              DESCRIPTORNUM:=-1;
              ITEMNUM:=-1;
            END;
          TOS:=TOS-1;
        END (*TOS> 0*);
    END (*WITH WRKTABLE*);
  TRACEWA(31,WI);
END (*DBASCEND*);

FUNCTION DBFINDREC(*WI:DBWRKINDEX; RULE:DBFINDRULE; FIELDNUM:INTEGER;
                   KEY:STRING; VAR RECNUM:INTEGER;
                   VAR FOUND:BOOLEAN):DBERRTYPE*);
(*locate a record whose FIELDNUM field matches the KEY according to
  the comparison RULE (ascending,descending, or random equals) *)
(*$G+*)
LABEL 1;
VAR FLINKNUM,FN,RN,RLINKV,FOFFSET,DUMMY:INTEGER;
  RP:RECDESPTR;
  DONE:BOOLEAN;
  S:STRING;
BEGIN
  TRACEWA(27,WI);
(*on entry we should be at RECORDT level, with ITEMNUM=0. First find
  out if field is variable and set FLINKNUM*)
  WITH WRKTABLE[WI] DO
    WITH WIB^[TOS] DO
      BEGIN
        IF LEVEL <> RECORDT THEN
          DBFINDREC:=39 (*must be at record level*)
        ELSE
          BEGIN
            IF ITEMNUM <> 0 THEN
              DUMMY:=DBHEAD(WI);
            RP:=ACTIVERECORDS[DESCRIPTORNUM];
            IF RP = NIL THEN
              DBFINDREC:=32
            ELSE
              WITH RP^ DO
                BEGIN
                  IF (SWITCHES <> 0) OR (FIELDNUM < FIRSTLITEMNUM) THEN
                    DBFINDREC:=40 (*must be untagged record and
                                    untagged string field*)
                  ELSE
                    BEGIN
                      FLINKNUM:=FIELDNUM - FIRSTLITEMNUM
                                         + ORD(FIRSTLITEMNUM > 0);
                      DONE:=FALSE;
                      FOUND:=FALSE;
                      RN:=0;
                      RLINKV:=LINKVALUE(WA,OFFSET);
                      (*speed-up possibilities: native code; assume all
                        links are single bytes & eliminate proc calls
                        to linksize & linkvalue*)
                      WHILE RLINKV <> 0 DO
                        BEGIN
                          FN:=0;
                          FOFFSET:=OFFSET + LINKSIZE(RLINKV);
                          (*all in-field links assumed 1 byte ! *)
                          (*move to field pointer now*)
(*$R-*)
                          WHILE (FN < FLINKNUM) DO
                            BEGIN
                              FOFFSET:=FOFFSET+WA^[FOFFSET];
                              FN:=FN+1;
                            END;
                          MOVELEFT(WA^[FOFFSET],S,WA^[FOFFSET]);
(*$R+*)
                          DELETE(S,LENGTH(S),1); (*correct link to length*)
                          CASE RULE OF
                            ASCENDING: DONE:= (KEY <= S);
                            DESCENDING:DONE:= (KEY >= S);
                            RANDOM:    DONE:= (KEY =  S)
                          END (*CASES*);
                          IF DONE THEN
                            BEGIN
                              FOUND:= (KEY = S);
                              GOTO 1; (*for efficiency*)
                            END
                          ELSE
                            BEGIN (*jump to next record*)
                              OFFSET:=OFFSET+RLINKV;
                              RLINKV:=LINKVALUE(WA,OFFSET);
                              RN:=RN+1;
                            END (*NOT DONE*);
                        END (*WHILE RLINKV*);
1:
                      RECNUM:=RN;
                      ITEMNUM:=RN;
                    END (*untagged ok*);
                END (*WITH RP^*);
          END (*LEVEL = RECORDT*);
      END (*WITH WIB^*);
  TRACEWA(28,WI);
END (*DBFINDREC*);


(*DATA TRANSFER PRIMITIVES*)
FUNCTION DBCOPY(*SOURCE,DESTINATION:DBWRKINDEX):DBERRTYPE*);
(*zero out the destination workarea. copy source record or group into
  destination. initialize pointers. *)
VAR SLEVEL:DBLEVELTYPE; 
  SINUSE,SDNUM,SOFFSET,SLINKV,STOS:INTEGER;
BEGIN
  TRACEWA(24,SOURCE);
  TRACEWA(25,DESTINATION);
  ZEROWORKAREA(DESTINATION);
  WITH WRKTABLE[SOURCE] DO
    WITH WIB^[TOS] DO
      BEGIN
        SINUSE:=SPACEINUSE;
        SLEVEL:=LEVEL;
        SOFFSET:=OFFSET;
        SLINKV:=LINKVALUE(WA,OFFSET);
        STOS:=TOS;
        SDNUM:=DESCRIPTORNUM;
      END;
  IF (SLEVEL <> GROUPT) OR (STOS <> 0) THEN
    DBCOPY:=12 (*can''t yet handle anything but outer level group*)
  ELSE
    WITH WRKTABLE[DESTINATION] DO
      WITH WIB^[TOS] DO
        IF SLINKV > WSIZE THEN
          DBCOPY:=1 (*insufficient space*)
        ELSE
          BEGIN
            SPACEINUSE:=SINUSE;
            LEVEL:=GROUPT;
            OFFSET:=0;
            DESCRIPTORNUM:=SDNUM;
            ITEMNUM:=0;
(*$R-*)
            MOVELEFT(WRKTABLE[SOURCE].WA^[SOFFSET],
                     WA^[OFFSET], SLINKV);
(*$R+*)
          END;
  TRACEWA(26,DESTINATION);
END (*DBCOPY*);

FUNCTION DBEMPTYITEM(*DESTINATION:DBWRKINDEX; LVL:DBLEVELTYPE;
                                              TAG:INTEGER):DBERRTYPE*);
(*creates a new empty item at level LVL and sets its tag if required*)
VAR NEWOFFSET,LINKV:PAGEPTR;
  TAGBYTES,ISTACK:INTEGER;

  PROCEDURE NEWLINKITEM(WIDTH:INTEGER; NEWOFFSET:PAGEPTR);
  (*insert an empty linked item WIDTH bytes wide*)
  VAR I:INTEGER;
  BEGIN
    IF TAG >= LINKESCAPE THEN WIDTH:=WIDTH+1;
    WITH WRKTABLE[DESTINATION] DO
      BEGIN
        DBSHOWERR('NEWLINKITEM', MOVETAIL(DESTINATION,WIDTH,NEWOFFSET));
(*$R-*)
        WA^[NEWOFFSET]:=WIDTH;
        IF LVL = GROUPT THEN
          SAVEBIGLINK(DESTINATION,TAG,NEWOFFSET+1);
(*$R+*)
        IF LVL = WIB^[TOS].LEVEL THEN
          BEGIN
            IF TOS > 0 THEN
              FIXLINKS(DESTINATION, (TOS-1), WIDTH);
          END
        ELSE
          FIXLINKS(DESTINATION, TOS, WIDTH);
      END (*WITH*);
  END (*NEWLINKITEM*);
  
  PROCEDURE BLANKRECORD;
  (*lay out empty fields in a blank record*)
  VAR RP:RECDESPTR;
    FP:FLDDESPTR;
    FN,MAXFN,FIXWIDTH,VARWIDTH:INTEGER;
    SW:CRACKSWTYPE;
    FIRSTLINKOFFSET:PAGEPTR;
  BEGIN
    WITH WRKTABLE[DESTINATION] DO
      WITH WIB^[TOS] DO
        BEGIN
          RP:=ACTIVERECORDS[DESCRIPTORNUM];
          WITH RP^ DO
            BEGIN
              FN:=0;
              SW.BL:=SWITCHES;
              FIRSTLINKOFFSET:=OFFSET+1;
              IF SW.A[0] THEN (*tagged*)
                FIXWIDTH:=1
              ELSE
                FIXWIDTH:=0;
              MAXFN:=LASTFLDLINK DIV 2 - 1;
              (*fixed fields first*)
              WHILE (FN < FIRSTLITEMNUM) AND (FN < MAXFN) DO
                BEGIN
(*$R-*)
                  WITH FLDREF[FN] DO
(*$R+*)
                    BEGIN
                      FP:=ACTIVEFIELDS[FDNUM];
                      FIXWIDTH:=FIXWIDTH+FP^.MAXWIDTH;
                    END;
                  FN:=FN+1;
                END (*WHILE*);
              IF FN > 0 THEN
                BEGIN
                  (*one link over all fixed fields*)
                  FIXWIDTH:=FIXWIDTH+1;
                  NEWLINKITEM(FIXWIDTH, FIRSTLINKOFFSET);
                END;
              (*if there are fixed fields, FIXWIDTH now includes the link*)
              NEWOFFSET:=FIRSTLINKOFFSET+FIXWIDTH;
              (*now put links of 1 for each variable size field*)
              VARWIDTH:=MAXFN-FN+1;
              DBEMPTYITEM:=MOVETAIL(DESTINATION, VARWIDTH, NEWOFFSET);
              WHILE FN < MAXFN DO
                BEGIN
(*$R-*)
                  WA^[NEWOFFSET]:=1;
(*$R+*)
                  NEWOFFSET:=NEWOFFSET+1;
                  FN:=FN+1;
                END;
            END (*WITH RP^*);
          (*still have to set overlink of record itself*)
          IF (VARWIDTH+FIXWIDTH) >= LINKESCAPE THEN
            BEGIN
              VARWIDTH:=VARWIDTH+1;
              DBEMPTYITEM:=MOVETAIL(DESTINATION,1,OFFSET);
            END;
          SAVEBIGLINK(DESTINATION, 
                (VARWIDTH+FIXWIDTH+1(*original link assumed small*)), 
                                          OFFSET);
          (* and also the enclosing links*)
          FIXLINKS(DESTINATION, (TOS-1), VARWIDTH);
        END (*WITH WIB^[TOS]*);
  END (*BLANKRECORD*);
  
BEGIN (*DBEMPTYITEM*)
  DBEMPTYITEM:=0;
  WITH WRKTABLE[DESTINATION] DO
    BEGIN
      TRACEWA(0,DESTINATION);
      WITH WIB^[TOS] DO
        IF LVL=LEVEL THEN
          CASE LEVEL OF
            NONET: DBEMPTYITEM:=13; (*undefined level*)
            RECORDT:
              (*insert a single byte link with value of 2, with nul stopper*)
              BEGIN
                NEWLINKITEM(1,OFFSET);
                IF DBTYPECHECK THEN
                  BLANKRECORD;
              END;
            GROUPT: 
              BEGIN
                NEWLINKITEM(3,OFFSET); (*leave byte for required tag*)
                DESCRIPTORNUM:=TAG;
              END;
            FIELDT:NEWLINKITEM(2,OFFSET)
          END (*CASE LEVEL*)
        ELSE
          BEGIN (*LVL<>LEVEL*)
            IF LVL<>NEXTLEVEL(LEVEL) THEN
              DBEMPTYITEM:=15 (*improper data level*)
            ELSE (*new embedded level, probably have to update earlier link*)
              BEGIN (*create blank linked item, descend to it, make blank
                                record if needed*)
                IF LVL = GROUPT THEN
                  TAGBYTES:=2
                ELSE
                  TAGBYTES:=0;
                NEWOFFSET:=OFFSET+1+ORD(LINKVALUE(WA,OFFSET) >= LINKESCAPE);
                IF LEVEL = GROUPT THEN (*step over the tag*)
                  NEWOFFSET:=NEWOFFSET+1
                               +ORD(LINKVALUE(WA,NEWOFFSET) >= LINKESCAPE);
                NEWLINKITEM(1+TAGBYTES,NEWOFFSET);
                DBEMPTYITEM:=DBDESCEND(DESTINATION);
                IF DBTYPECHECK AND (LVL = RECORDT) THEN
                  BLANKRECORD;
              END (*LVL = NEXTLEVEL*);
          END (*LVL<>LEVEL*);
    END (*WITH WRKTABLE*);
  TRACEWA(1,DESTINATION);
END (*DBEMPTYITEM*);

FUNCTION DBDELETE(*DESTINATION:DBWRKINDEX):DBERRTYPE*);
(*eliminate the destination item (group or record only) entirely*)
VAR LINKV:INTEGER;
BEGIN
  TRACEWA(17,DESTINATION);
  DBDELETE:=0;
  WITH WRKTABLE[DESTINATION] DO
    WITH WIB^[TOS] DO
      BEGIN
        IF NOT (LEVEL IN [GROUPT,RECORDT]) THEN
          DBDELETE:=41
        ELSE
          BEGIN
            LINKV:=LINKVALUE(WA,OFFSET);
            IF LINKV <> 0 THEN
              DBDELETE:=MOVETAIL(DESTINATION, -LINKV, OFFSET+LINKV);
            IF TOS > 0 THEN
              FIXLINKS(DESTINATION, TOS-1, -LINKV);
          END (*LEVEL OK*);
      END (*WITH WIB^*);
  TRACEWA(18,DESTINATION);
END (*DBDELETE*);

FUNCTION DBBLANK(*DESTINATION:DBWRKINDEX):DBERRTYPE*);
(*replace the destination group or record with an empty item*)
VAR RSLT,DELTA:INTEGER;
BEGIN
  TRACEWA(19,DESTINATION);
  RSLT:=DBDELETE(DESTINATION);
  IF RSLT <> 0 THEN
    DBBLANK:=RSLT
  ELSE
    WITH WRKTABLE[DESTINATION] DO
      WITH WIB^[TOS] DO
        BEGIN
          IF LEVEL = GROUPT THEN
            DELTA:=3
          ELSE
            DELTA:=2;
          RSLT:=MOVETAIL(DESTINATION, DELTA, OFFSET);
          IF RSLT <> 0 THEN
            DBBLANK:=RSLT
          ELSE
            BEGIN
              WA^[OFFSET]:=DELTA;
              IF TOS > 0 THEN
                FIXLINKS(DESTINATION, TOS-1, DELTA);
            END;
          DESCRIPTORNUM:=-1;
        END (*WITH WIB^*);
  TRACEWA(20,DESTINATION);
END (*DBBLANK*);

FUNCTION DBREPLACE(*SOURCE,DESTINATION:DBWRKINDEX):DBERRTYPE*);
(*the source item replaces the destination item. must be record or group*)
VAR SLINKV,SOFFSET,STOS,DOFFSET,DTOS,RSLT:INTEGER;
  SLEVEL,DLEVEL:DBLEVELTYPE;
BEGIN
  TRACEWA(21,SOURCE);
  TRACEWA(22,DESTINATION);
  RSLT:=DBDELETE(DESTINATION);
  IF RSLT <> 0 THEN
    DBREPLACE:=RSLT
  ELSE
    BEGIN
      WITH WRKTABLE[SOURCE] DO
        WITH WIB^[TOS] DO
          BEGIN
            SLEVEL:=LEVEL;
            SOFFSET:=OFFSET;
            SLINKV:=LINKVALUE(WA,OFFSET);
            STOS:=TOS;
          END;
      WITH WRKTABLE[DESTINATION] DO
        WITH WIB^[TOS] DO
          BEGIN
            DLEVEL:=LEVEL;
            DOFFSET:=OFFSET;
            DTOS:=TOS;
          END;
      IF DLEVEL <> SLEVEL THEN
        DBREPLACE:=42 (*mismatch*)
      ELSE
        IF NOT (DLEVEL IN [GROUPT,RECORDT]) THEN
          DBREPLACE:=41
        ELSE
          BEGIN
            (*open space up to receive source copy*)
            RSLT:=MOVETAIL(DESTINATION,SLINKV,DOFFSET);
            IF RSLT <> 0 THEN
              DBREPLACE:=RSLT
            ELSE
(*$R-*)
              BEGIN
                MOVELEFT(WRKTABLE[SOURCE].WA^[SOFFSET],
                       WRKTABLE[DESTINATION].WA^[DOFFSET], SLINKV);
(*$R+*)
                IF DTOS > 0 THEN
                  FIXLINKS(DESTINATION, DTOS-1, SLINKV);
              END;
            WRKTABLE[DESTINATION].WIB^[DTOS].DESCRIPTORNUM
              := WRKTABLE[SOURCE].WIB^[STOS].DESCRIPTORNUM;
          END (*levels ok*);
    END (*DELETE worked ok*);
  TRACEWA(23,DESTINATION);
END (*DBREPLACE*);

FUNCTION DBRESERVE(*DESTINATION:DBWRKINDEX):DBERRTYPE*);
(*reserve empty space at the end of destination group*)
BEGIN
  TRACEWA(32,DESTINATION);
  TRACEWA(33,DESTINATION);
END (*DBRESERVE*);

FUNCTION GETFOFFSET(WI:DBWRKINDEX):PAGEPTR;
(*returns the offset (in record) of a fixed width field based on
  its ITEMNUM*)
VAR RP:RECDESPTR;
 DN:INTEGER;
BEGIN
  WITH WRKTABLE[WI] DO
    BEGIN
      DN:=WIB^[TOS-1].DESCRIPTORNUM;
      IF (DN >= 0) AND (DN <= LASTRECDESCRIPTOR) THEN
        BEGIN
          RP:=ACTIVERECORDS[DN];
          IF RP = NIL THEN
            DBSHOWERR('GETOFFSET - Record not active', 100)
          ELSE
(*$R-*)
            GETFOFFSET:=RP^.FLDREF[WIB^[TOS].ITEMNUM].FLDOFFSET;
(*$R+*)
        END
      ELSE
        DBSHOWERR('GETOFFSET - DESCRIPTORNUM not initialized',100);
    END;
END (*GETFOFFSET*);

FUNCTION DBGET(*SOURCE:DBWRKINDEX):DBERRTYPE*);
(*extract item value from workarea and place it in DBMAIL for pickup by
  caller*)
CONST FIXEDWIDTH = 1;
VAR LINKV: INTEGER;
  FP:FLDDESPTR;
  RP:RECDESPTR;
  SW:CRACKSWTYPE;
  FOFFSET:INTEGER;

  PROCEDURE GETLINKF(FLDTYPE:DBFIELDTYPES);
  BEGIN
    WITH WRKTABLE[SOURCE] DO
      WITH WIB^[TOS] DO
        BEGIN
          LINKV:=LINKVALUE(WA,OFFSET);
          IF LINKV >= LINKESCAPE THEN
            DBGET:=21 (*string too long to assign*)
          ELSE
            BEGIN
(*$R-*)
              MOVELEFT(WA^[OFFSET],DBMAIL.TXT,LINKV);
(*$R+*)
              DBMAIL.TXT[0]:=CHR(LINKV-1);
              DBMAIL.DBMAILTYPE:=FLDTYPE;
            END (*LINKV < LINKESCAPE*);
        END (*WITH WIB*);
  END (*GETLINKF*);
  
BEGIN (*DBGET*)
  DBGET:=0;
  TRACEWA(13,SOURCE);
  IF DBTYPECHECK THEN
    WITH WRKTABLE[SOURCE] DO
      WITH WIB^[TOS] DO
        BEGIN
          IF LEVEL = GROUPT THEN
            GETLINKF(GROUPF)
          ELSE
            IF LEVEL <> FIELDT THEN
              DBGET:=38 (*must be a field*)
            ELSE
          IF (DESCRIPTORNUM >= 0) 
                  AND (DESCRIPTORNUM <= LASTFIELDDESCRIPTOR) THEN
            BEGIN
              FP:=ACTIVEFIELDS[DESCRIPTORNUM];
              IF FP = NIL THEN
                DBGET:=31 (*no such field exists*)
              ELSE
                WITH FP^ DO
                  BEGIN
                    SW.BL:=SWITCHES;
                    IF SW.A[FIXEDWIDTH] THEN
                      WITH DBMAIL DO
                        BEGIN
(*$R-*)
                          MOVELEFT(WA^[OFFSET
                                   +GETFOFFSET(SOURCE)], TXT, MAXWIDTH);
(*$R+*)
                          DBMAILTYPE:=FLDTYPE;
                        END
                    ELSE
                      GETLINKF(FLDTYPE);
                  END (*WITH FP^*);
            END (*DESCRIPTORNUM OK*)
          ELSE
            DBGET:=31; (*no such field exists*)
        END (*WITH WIB^[TOS]*)
  ELSE (*no type checking - assume it's linked*)
    GETLINKF(STRINGF);
END (*DBGET*);



========================================================================================
DOCUMENT :usus Folder:VOL04:dbunit.4.text
========================================================================================

FUNCTION DBPUT(*DESTINATION:DBWRKINDEX):DBERRTYPE*);
(*replace current item in workarea with the contents of DBMAIL*)
VAR DELTA,OLDLINKV,NEWLINKV,ISTACK:INTEGER;
  FP:FLDDESPTR;
  
  PROCEDURE PUTLINKF;
  (*replace current linked item with the item in DBMAIL*)
  BEGIN
    WITH WRKTABLE[DESTINATION] DO
      BEGIN (*replace the linked item*)
        WITH WIB^[TOS] DO
          BEGIN
            OLDLINKV:=LINKVALUE(WA,OFFSET);
            NEWLINKV:=ORD(DBMAIL.TXT[0]);
            IF DBMAIL.DBMAILTYPE = STRINGF THEN
              NEWLINKV:=NEWLINKV+1; (*link is 1 greater than
                                                string length*)
            DELTA:=NEWLINKV-OLDLINKV;
            IF DELTA > 0 THEN
              DBSHOWERR('DBPUT#1',MOVETAIL(DESTINATION,DELTA,OFFSET))
            ELSE
              DBSHOWERR('DBPUT#2',MOVETAIL(DESTINATION,DELTA,OFFSET-DELTA));
(*$R-*)
            MOVELEFT(DBMAIL.TXT,WA^[OFFSET],NEWLINKV);
            WA^[OFFSET]:=NEWLINKV;
(*$R+*)
          END (*WITH WIB*);
        (*now correct enclosing links also*)
        IF TOS > 0 THEN
          FIXLINKS(DESTINATION,(TOS-1),DELTA);
      END (*WITH WRKTABLE*);
  END (*PUTLINKF*);
  
  PROCEDURE PUTFIXEDF(FP:FLDDESPTR);
  (*replace a fixed width item in a record assumed already present*)
  CONST FIXEDWIDTH = 1;
  VAR SW:CRACKSWTYPE;
    FOFFSET:INTEGER;
  BEGIN
    WITH WRKTABLE[DESTINATION] DO
      WITH WIB^[TOS] DO
        WITH FP^ DO
          BEGIN
            SW.BL:=SWITCHES;
            IF NOT SW.A[FIXEDWIDTH] THEN
              DBPUT:=37 (*fixed width item expected*)
            ELSE
(*$R-*)
              WITH DBMAIL DO
                MOVELEFT(TXT, WA^[OFFSET+GETFOFFSET(DESTINATION)],
                                        MAXWIDTH);
(*$R+*)
          END (*WITH FP^*);
  END (*PUTFIXEDF*);
  
BEGIN (*DBPUT*)
  DBPUT:=0;
  TRACEWA(14,DESTINATION);
  IF DBTYPECHECK THEN
    WITH WRKTABLE[DESTINATION] DO
      WITH WIB^[TOS] DO
        WITH DBMAIL DO
          BEGIN
            IF DBMAILTYPE = GROUPF THEN
              BEGIN
                IF LEVEL <> GROUPT THEN
                  DBPUT:=36
                ELSE
                  PUTLINKF;
              END
            ELSE
              IF LEVEL <> FIELDT THEN
                DBPUT:=38
              ELSE
              IF (DESCRIPTORNUM >= 0) 
                  AND (DESCRIPTORNUM <= LASTFIELDDESCRIPTOR) THEN
                BEGIN (*it's a simple field*)
                  FP:=ACTIVEFIELDS[DESCRIPTORNUM];
                  IF FP = NIL THEN
                    DBPUT:=31 (*no such field initialized*)
                  ELSE
                    WITH FP^ DO
                      IF FLDTYPE <> DBMAILTYPE THEN
                        DBPUT:=36 (*mismatch*)
                      ELSE
                        IF DBMAILTYPE IN [STRINGF,INTEGERF,LONGINTF] THEN
                          CASE DBMAILTYPE OF
                            STRINGF: PUTLINKF;
                            LONGINTF,INTEGERF: PUTFIXEDF(FP)
                          END (*CASES*)
                        ELSE
                          DBPUT:=12; (*not yet implemented*)
                END (*simple field*)
              ELSE
                DBPUT:=31 (*no such field exists*);
          END (*WITH DBMAIL*)
  ELSE (*item assumed to be linked string*)
    PUTLINKF;
  TRACEWA(15,DESTINATION);
END (*DBPUT*);


(*SUPPORT PRIMITIVES*)
FUNCTION DBWRITEFIELD(*FID:TEXT; SOURCE:DBWRKINDEX):DBERRTYPE*);
(*access to Pascal's WRITE referring to the item currently pointed to
    in the source workarea; output is to file FID*)
VAR FP:FLDDESPTR;
  S:STRING[255];
  IA:REFLIST;
BEGIN
  DBWRITEFIELD:=0;
  WITH WRKTABLE[SOURCE] DO
    WITH WIB^[TOS] DO
      BEGIN
        IF LEVEL <> FIELDT THEN
          DBWRITEFIELD:=28 (*can't write out a whole group*)
        ELSE
          BEGIN
            FP:=ACTIVEFIELDS[DESCRIPTORNUM];
            IF FP=NIL THEN
              DBWRITEFIELD:=29
            ELSE
              WITH FP^ DO
                CASE FLDTYPE OF
                  GROUPF: DBWRITEFIELD:=28;
                  STRINGF:
                    BEGIN
(*$R-*)
                      MOVELEFT(WA^[OFFSET],S,LINKVALUE(WA,OFFSET));
(*$R+*)
                      DELETE(S,LENGTH(S),1); (*correct for link*)
                      WRITE(FID,S);
                    END;
                  INTEGERF:
                    BEGIN
(*$R-*)
                      MOVELEFT(WA^[OFFSET+GETFOFFSET(SOURCE)],IA[0],2);
(*$R+*)
                      WRITE(FID,IA[0]);
                    END;
                  BYTEF,LONGINTF,TEXTF: DBWRITEFIELD:=12; (*not implemented*)
                  ADDRCOUPLEF,SETF: DBWRITEFIELD:=30
                END (*CASE*);
          END (*LEVEL=FIELDT*);
      END (*WITH WIB*);
END (*DBWRITEFIELD*);

PROCEDURE DBGETDESCRIPTOR(*LEVEL:DBLEVELTYPE; 
                           DESCRIPTORNUM:INTEGER;
                           VAR PTR:FLDDESPTR)*);
(*used to pass descriptors to external programs. to avoid excessive
  interface symbol table, TRIX record is used to pass pointer as
  FLDDESPTR. external program is expected to declare its own records
  corresponding to RECORDT and GROUPT since they are not in the interface
  part*)
TYPE
  TRIXPTR=
    RECORD CASE DBLEVELTYPE OF
      FIELDT: (F:FLDDESPTR);
      RECORDT:(R:RECDESPTR);
      GROUPT: (G:GRPDESPTR)
    END;
VAR TP:TRIXPTR;
BEGIN
  IF DESCRIPTORNUM < 0 THEN
    TP.F := NIL
  ELSE
    CASE LEVEL OF
      FIELDT:  TP.F:=ACTIVEFIELDS[DESCRIPTORNUM];
      RECORDT: TP.R:=ACTIVERECORDS[DESCRIPTORNUM];
      GROUPT:  TP.G:=ACTIVEGROUPS[DESCRIPTORNUM]
    END (*CASES*);
  PTR:=TP.F;
END (*DBGETDESCRIPTOR*);

FUNCTION DBTAG(*NAME:STRING; SOURCE:DBWRKINDEX; VAR ITEMNUM:INTEGER):DBERRTYPE*);
(*search the current level for a descriptor corresponding to NAME*)
BEGIN
END (*DBTAG*);


(**WORKAREA PRIMITIVES*)
FUNCTION DBWRKOPEN(*WI:DBWRKINDEX; SIZE:INTEGER):DBERRTYPE*);
CONST WADELTA=64;
(*open a workarea for business*)
VAR I:INTEGER;
  P:WAPTR;
BEGIN
  DBWRKOPEN:=0;
  WITH WRKTABLE[WI] DO
    IF (SIZE <= 0) OR (SIZE > (PAGELASTBYTE+1)) THEN
      DBWRKOPEN:=2 (*size out of range*)
    ELSE
      IF (WA <> NIL) OR (WIB<>NIL) THEN
        DBWRKOPEN:=3 (*workarea already open*)
      ELSE
        IF NOT CHECKHEAP(SIZE+SIZEOF(WIBTYPE)) THEN
          DBWRKOPEN:=1 (*insufficient memory*)
        ELSE
          BEGIN  (*should be safe - do it*)
            NEW(WIB);
            NEW(WA); (*allocates WADELTA bytes - minimum wa size*)
            IF SIZE > WADELTA THEN
              I:=HEAPALLOCATE(SIZE-WADELTA); (*already checked for error*)
            WSIZE:=MAX(WADELTA,SIZE);
            ZEROWORKAREA(WI);
          END;
END (*DBWRKOPEN*);

FUNCTION DBWRKCLOSE(*WI:DBWRKINDEX):DBERRTYPE*);
BEGIN
END (*DBWRKCLOSE*);


(**FILE PRIMITIVES*)
FUNCTION DBFOPEN(*FNUM:DBFILENUM; TITLE:STRING):DBERRTYPE*);
BEGIN
  DBFOPEN:=0;
(*$I-*)
  CASE FNUM OF
    0: RESET(F0,TITLE);
    1: RESET(F1,TITLE);
    2: RESET(F2,TITLE);
    3: RESET(F3,TITLE);
    4: RESET(F4,TITLE)
  END (*CASE*);
  DBIORESULT:=IORESULT;
  IF DBIORESULT <> 0 THEN
    DBFOPEN:=23 (*unable to open file*)
  ELSE
    OPENFILES[FNUM]:=TRUE;
(*$I+*)
END (*DBFOPEN*);

FUNCTION DBFCLOSE(*FNUM:DBFILENUM):DBERRTYPE*);
BEGIN
  DBFCLOSE:=0;
(*$I-*)
  CASE FNUM OF
    0: CLOSE(F0);
    1: CLOSE(F1);
    2: CLOSE(F2);
    3: CLOSE(F3);
    4: CLOSE(F4)
  END (*CASE*);
  IF IORESULT <> 0 THEN
    DBFCLOSE:=26; (*unable to close file*)
(*$I+*)
END (*DBFCLOSE*);

FUNCTION DBFCREATE(*FNUM:DBFILENUM; WASCRATCH:DBWRKINDEX;
                                    SPEXTITLE,NEWTITLE:STRING):DBERRTYPE*);
(*open a new database file; lock it into directory; if there is a non-empty
  specification file fitle, copy the spex into the new file. uses wascratch
  to initialize the file.  assumes wascratch will be associated with fnum
  file*)
VAR RSLT:INTEGER;

  PROCEDURE BLANKZEROPAGE(VAR F:FILETYPE);
  VAR BLOCKCOUNT:INTEGER;
  BEGIN
    BLOCKCOUNT:=(PAGELASTBYTE+1) DIV 512;
    RSLT:=BLOCKWRITE(F,WRKTABLE[WASCRATCH].WA^,BLOCKCOUNT,0);
    DBFCREATE:=0;
    IF RSLT <> BLOCKCOUNT THEN
      DBFCREATE:=9
    ELSE
(*$I-*)
      BEGIN
        CLOSE(F,LOCK);
        IF IORESULT <> 0 THEN
          DBFCREATE:=10  (*unable to lock file*)
        ELSE
          BEGIN
            RESET(F,NEWTITLE);
            IF IORESULT <> 0 THEN
              DBFCREATE:=11 (*unable to re-open the file*)
            ELSE
              OPENFILES[FNUM]:=TRUE;
          END;
      END (*RSLT = BLOCKCOUNT*);
  END (*BLANKZEROPAGE*);

BEGIN (*DBFCREATE*)
  RSLT:=CHECKWORKAREA(WASCRATCH,(PAGELASTBYTE+1));
  IF RSLT<>0 THEN
    DBFCREATE:=RSLT (*pass on error from checkworkarea*)
  ELSE
    IF OPENFILES[FNUM] THEN
      DBFCREATE:=5 (*file already open and in use*)
    ELSE
      IF LENGTH(NEWTITLE) = 0 THEN
        DBFCREATE:=6 (*requires non-nul title string*)
  ELSE
(*$I-*)
    BEGIN
      CASE FNUM OF
        0: RESET(F0,NEWTITLE);
        1: RESET(F1,NEWTITLE);
        2: RESET(F2,NEWTITLE);
        3: RESET(F3,NEWTITLE);
        4: RESET(F4,NEWTITLE)
      END (*CASE*);
      RSLT:=IORESULT;
  (*$I+*)
      IF RSLT=0 THEN (*file already on disk*)
        DBFCREATE:=4
      ELSE
        IF RSLT = 12 THEN (*file already open, but not caught above*)
          DBFCREATE:=99 (*system error*)
    ELSE
      BEGIN
  (*$I-*)
        CASE FNUM OF
          0: REWRITE(F0,NEWTITLE);
          1: REWRITE(F1,NEWTITLE);
          2: REWRITE(F2,NEWTITLE);
          3: REWRITE(F3,NEWTITLE);
          4: REWRITE(F4,NEWTITLE)
        END (*CASE*);
        RSLT:=IORESULT;
  (*$I+*)
        IF RSLT <> 0 THEN
          DBFCREATE:=7 (*rewrite failure*)
        ELSE
          IF LENGTH(SPEXTITLE) = 0 THEN
            BEGIN  (*ok to create the file now*)
              ZEROWORKAREA(WASCRATCH);
              CASE FNUM OF
                0: BLANKZEROPAGE(F0);
                1: BLANKZEROPAGE(F1);
                2: BLANKZEROPAGE(F2);
                3: BLANKZEROPAGE(F3);
                4: BLANKZEROPAGE(F4)
              END (*CASE*);
            END (*LENGTH(SPEXTITLE) = 0*)
          ELSE
            DBFCREATE:=12; (*spexfile transfer not yet implemented*)
      END (*RSLT <> 12*);
    END (*LENGTH(NEWTITLE) <> 0*);
END (*DBFCREATE*);

FUNCTION DBFREMOVE(*FNUM:DBFILENUM):DBERRTYPE*);
BEGIN
  DBFREMOVE:=0;
(*$I-*)
  CASE FNUM OF
    0: CLOSE(F0,PURGE);
    1: CLOSE(F1,PURGE);
    2: CLOSE(F2,PURGE);
    3: CLOSE(F3,PURGE);
    4: CLOSE(F4,PURGE)
  END (*CASE*);
  IF IORESULT <> 0 THEN
    DBFREMOVE:=22
  ELSE
    OPENFILES[FNUM]:=FALSE;
(*$I+*)
END (*DBFREMOVE*);

FUNCTION DBGETPAGE(*FNUM:DBFILENUM; DESTINATION:DBWRKINDEX;
                                   PAGENUM:INTEGER):DBERRTYPE*);
VAR BLOCKSMOVED,BLOCKSINPAGE,LINKV,LX,DUMMY:INTEGER;

  PROCEDURE MOVEWA(VAR F:FILETYPE);
  BEGIN
    BLOCKSMOVED:=BLOCKREAD(F,WRKTABLE[DESTINATION].WA^,
                                    BLOCKSINPAGE, (PAGENUM*BLOCKSINPAGE));
  END;

BEGIN
  DBGETPAGE:=DBHOME(DESTINATION);
  BLOCKSINPAGE:=(PAGELASTBYTE+1) DIV 512;
  WITH WRKTABLE[DESTINATION] DO
    CASE FNUM OF
      0: MOVEWA(F0);
      1: MOVEWA(F1);
      2: MOVEWA(F2);
      3: MOVEWA(F3);
      4: MOVEWA(F4)
    END (*CASE*);
  IF BLOCKSMOVED <> BLOCKSINPAGE THEN
    DBGETPAGE:=25
  ELSE
    WITH WRKTABLE[DESTINATION] DO
      BEGIN
        (*get SPACEINUSE by following links to end*)
        LX:=0;
        LINKV:=LINKVALUE(WA,0);
        WHILE LINKV<>0 DO
          BEGIN
            LX:=LX+LINKV;
            LINKV:=LINKVALUE(WA,LX);
          END;
        SPACEINUSE:=LX+1;
        WITH WIB^[0] DO
          BEGIN
            LINKV:=LINKVALUE(WA,0);
            DESCRIPTORNUM:=LINKVALUE(WA,LINKSIZE(LINKV)); (*tag*)
          END;
      END (*WITH WRKTABLE*);
END (*DBGETPAGE*);

FUNCTION DBPUTPAGE(*FNUM:DBFILENUM; SOURCE:DBWRKINDEX;
                                   PAGENUM:INTEGER):DBERRTYPE*);
VAR BLOCKSMOVED,BLOCKSINPAGE:INTEGER;

  PROCEDURE MOVEWA(VAR F:FILETYPE);
  BEGIN
    BLOCKSMOVED:=BLOCKWRITE(F,WRKTABLE[SOURCE].WA^,
                          BLOCKSINPAGE, (PAGENUM*BLOCKSINPAGE));
  END;

BEGIN
  DBPUTPAGE:=0;
  BLOCKSINPAGE:=(PAGELASTBYTE+1) DIV 512;
  WITH WRKTABLE[SOURCE] DO
    CASE FNUM OF
      0: MOVEWA(F0);
      1: MOVEWA(F1);
      2: MOVEWA(F2);
      3: MOVEWA(F3);
      4: MOVEWA(F4)
    END (*CASE*);
  IF BLOCKSMOVED <> BLOCKSINPAGE THEN
    DBPUTPAGE:=24;
END (*DBPUTPAGE*);


(**DESCRIPTOR INITIALIZING PRIMITIVES*)
FUNCTION DBGROUPINIT(*FNUM:DBFILENUM; VAR GROUPNUM:INTEGER;
                     GROUPNAME:STRING):DBERRTYPE*);
(*load the descriptor lists from groups 1,2,3 of the database using
  workarea 0 as temporary store. note: these groups may extend over
  more than one page*)
CONST
  WA0=0; (*work area #0*)
VAR GN,LINKV,PAGENUM,DUMMY:INTEGER;

  PROCEDURE LOADDESCRIPTORS(LVL:DBLEVELTYPE);
  VAR GPTR:GRPDESPTR;
    RPTR:RECDESPTR;
    FPTR:FLDDESPTR;
  BEGIN
    WITH WRKTABLE[WA0] DO
      WITH WIB^[TOS] DO
        BEGIN
          GN:=0;
          LINKV:=LINKVALUE(WA,OFFSET);
          WHILE LINKV > 2 (*ignore empty dummy records*) DO
            BEGIN
              CASE LVL OF
                GROUPT:
                  BEGIN
                    NEW(GPTR);
                    DBSHOWERR('GROUPINIT(G)',
                              HEAPALLOCATE(LINKV-SIZEOF(GRPDESCRIPTOR)));
      (*$R-*)
                    MOVELEFT(WA^[OFFSET],GPTR^,LINKV);
      (*$R+*)
                    ACTIVEGROUPS[GN]:=GPTR;
                  END (*GROUPT*);
                RECORDT:
                  BEGIN
                    NEW(RPTR);
                    DBSHOWERR('GROUPINIT(R)',
                              HEAPALLOCATE(LINKV-SIZEOF(RECDESCRIPTOR)));
      (*$R-*)
                    MOVELEFT(WA^[OFFSET],RPTR^,LINKV);
      (*$R+*)
                    ACTIVERECORDS[GN]:=RPTR;
                  END (*RECORDT*);
                FIELDT:
                  BEGIN
                    NEW(FPTR);
                    DBSHOWERR('GROUPINIT(F)',
                              HEAPALLOCATE(LINKV-SIZEOF(FLDDESCRIPTOR)));
      (*$R-*)
                    MOVELEFT(WA^[OFFSET],FPTR^,LINKV);
      (*$R+*)
                    ACTIVEFIELDS[GN]:=FPTR;
                  END (*FIELDT*)
              END (*CASE*);
              DUMMY:=DBNEXT(WA0);
              LINKV:=LINKVALUE(WA,OFFSET);
              IF LINKV <> 0 THEN GN:=GN+1;
            END (*WHILE*);
        END (*WITH*);
  END (*LOADDESCRIPTORS*);
  
  PROCEDURE NEWPAGE;
  BEGIN
    PAGENUM:=PAGENUM+1;
    DBSHOWERR('GROUPINIT#2',DBGETPAGE(FNUM,WA0,PAGENUM));
  END (*NEWPAGE*);
                     
BEGIN (*DBGROUPINIT*)
  DBGROUPINIT:=0;
  (*initially load all descriptors - selection to be added later*)
  IF GROUPNAME <> 'ALL' THEN
    DBGROUPINIT:=12;
  (*loads descriptor groups into WA0*)
  PAGENUM:=-1;
  NEWPAGE;
  SPECIALGROUPPAGE[1]:=PAGENUM;
  DUMMY:=DBHOME(WA0);
  DUMMY:=DBNEXT(WA0); (*go to head of group descriptor list*)
  DUMMY:=DBDESCEND(WA0); (*head of 1st record*)
  WITH WRKTABLE[WA0] DO
    WITH WIB^[TOS] DO
      BEGIN
        LOADDESCRIPTORS(GROUPT);
        GROUPNUM:=GN;
        (*now load record descriptors*)
        DUMMY:=DBHOME(WA0);
        IF DBSEEK(WA0,2(*RD'S*)) <> 0 THEN NEWPAGE;
        SPECIALGROUPPAGE[2]:=PAGENUM;
        DUMMY:=DBDESCEND(WA0);
        LOADDESCRIPTORS(RECORDT);
        (*now fields*)
        DUMMY:=DBHOME(WA0);
        IF DBSEEK(WA0,3(*FD'S*)) <> 0 THEN NEWPAGE;
        SPECIALGROUPPAGE[3]:=PAGENUM;
        DUMMY:=DBDESCEND(WA0);
        LOADDESCRIPTORS(FIELDT);
      END (*WITH WIB*);
END (*DBGROUPINIT*);

FUNCTION DBGROUPRELEASE(*GROUPNUM:INTEGER):DBERRTYPE*);
(*de-allocate storage for the designated group descriptors, and
  their dependent record and field descriptors*)
BEGIN
END (*DBGROUPRELEASE*);


(**INITIALIZATION*)
PROCEDURE DBINITIALIZE;
VAR WI:INTEGER;
BEGIN
  FOR WI:=0 TO LASTFILENUM DO OPENFILES[WI]:=FALSE;
  FOR WI:=0 TO LASTWRKINDEX DO
    WITH WRKTABLE[WI] DO
      BEGIN
        TOS:=0;
        WIB:=NIL;
        WSIZE:=0;
        SPACEINUSE:=0;
        WA:=NIL;
      END;
  FOR WI:=0 TO LASTSPECIALGROUP DO SPECIALGROUPPAGE[WI]:=0;
  FOR WI:=0 TO LASTGROUPDESCRIPTOR DO ACTIVEGROUPS[WI]:=NIL;
  FOR WI:=0 TO LASTRECDESCRIPTOR DO ACTIVERECORDS[WI]:=NIL;
  FOR WI:=0 TO LASTFIELDDESCRIPTOR DO ACTIVEFIELDS[WI]:=NIL;
  MARK(HEAPMARKER);
  WI:=DBWRKOPEN(0,(PAGELASTBYTE+1)); (*open wa # 0 for full page*)
  DBTYPECHECK:=TRUE;
  
  (*following lines are for debugging*)
  DEBUGGING:=FALSE;
  DBTRACESET:=[ ];
  TRACELB:=0;
  TRACEUB:=99;
END (*DBINITIALIZE*);


(**ORDERLY TERMINATION*)
FUNCTION DBCLOSEDOWN(*:DBERRTYPE*);
BEGIN
END (*DBCLOSEDOWN*);



END. (*END OF DBUNIT*)


========================================================================================
DOCUMENT :usus Folder:VOL04:dbunit.text
========================================================================================

{Professor Ken Bowles' database seed.  Please see the statement at the
 start of the actual file, DBUNIT.1.TEXT, for his copyright notice
 
 This is a dummy file that contains the I)nclude compiler directives allowing
 the source to be broken up into parts that will fit into the E6 editor's
 wholly memory-resident buffer.}
 
 {$IDBUNIT1.TEXT}
 
 {$IDBUNIT.2.TEXT}
 
 {$IDBUNIT.3.TEXT}
 
 {$IDBUNIT.4.TEXT}
 
 

========================================================================================
DOCUMENT :usus Folder:VOL04:index.text
========================================================================================

Index to Pascal Report(2nd. ed.) by Niklaus Wirth 

ABS                                     11.1.1
actual parameter                        9.1.2
adding operator                         8.1.3
AND                                     8.1.2
ARRAY                                   6.2.1
array type                              6.2.1
array variable                          7.2.1
ARCTAN                                  11.1.1
assignment statement                    9.1.1
base type                               6.2.3/14.3
BEGIN                                   9.2.1
blank                                   14.4/14.6
block                                   10.
BOOLEAN                                 6.1.2
buffer variable                         7./7.2.3
CASE                                    6.2.2/9.2.2.2
case label                              6.2.2
case label list                         6.2.2/9.2.2.2
case list element                       9.2.2.2
case statement                          9.2.2.2
CHAR                                    6.1.2
CHR                                     11.1.3
component type                          6.2.1
component variable                      7.2
compound statement                      9.2.1
conditional statement                   9.2.2
CONST                                   10.
constant                                5.
constant definition                     5.
constant definition part                10.
constant identifier                     5.
control variable                        9.2.3.3
COS                                     11.1.1
digit                                   3.
digit sequence                          4.
DISPOSE                                 10.1.2
DIV                                     8.1.2
DO                                      9.2.3.1/9.2.3.3/9.2.4
DOWNTO                                  9.2.3.3
E                                       4.
element                                 8.
element list                            8.
ELSE                                    9.2.2.1 
empty                                   ???
empty statement                         9.1
END                                     6.2.2/9.2.1/9.2.2.2
entire variable                         7.1
EOF                                     11.1.2
EOLN                                    11.1.2
EXP                                     11.1.1
expression                              8.
external                                13.
factor                                  8.
FALSE                                   6.1.2
field designator                        7.2.2
field identifier                        7.2.2
field list                              6.2.2
FILE                                    6.2.4
file buffer                             7.2.3
file type                               6.2.4
file variable                           7.2.3
final value                             9.2.3.3
fixed part                              6.2.2
FOR                                     9.2.3.3
for list                                9.2.3.3
for statement                           9.2.3.3
formal parameter section                10.
FUNCTION                                10./11.
function declaration                    11.
function designator                     8.2
function heading                        11.
function identifier                     8.2
GET                                     10.1.1
GOTO                                    9.1.3
goto statement                          9.1.3
identifier                              4./14.1
IF                                      9.2.2.1
if statement                            9.2.2.1
IN                                      8.1.4
index type                              6.2.1
indexed variable                        7.2.1
initial value                           9.2.3.3
INPUT                                   12./13.
INTEGER                                 6.1.2
LABEL                                   10.
label                                   9./14.4
label declaration part                  10. 
letter                                  3.
letter or digit                         4.
LN                                      11.1.1
MAXINT                                  ???
MOD                                     8.1.2
multiplying operator                    8.1.2
NEW                                     10.1.2
NIL                                     6.3/8.
NOT                                     8.1.1
ODD                                     11.1.2
OF                                      6.2.1/6.2.2/6.2.3/6.2.4/9.2.2.2
operator precedence                     8.
OR                                      8.1.3
ORD                                     11.1.3
OUTPUT                                  12./13.
PACK                                    10.1.3
PACKED                                  6.2
PAGE                                    12.5
parameter group                         10.
pointer type                            6.3
pointer variable                        7.3 
PRED                                    11.1.4
printer control character               14.4
PROCEDURE                               10.
procedure and function declaration part 10.
procedure declaration                   10.
procedure heading                       10.
procedure identifier                    9.1.2
procedure or function declaration       10.
procedure statement                     9.1.2
PROGRAM                                 13.
program                                 13.
program heading                         13.
program parameters                      13.
PUT                                     10.1.1
READ                                    12.1
READLN                                  12.2
REAL                                    6.1.2
RECORD                                  6.2.2
record section                          6.2.2
record type                             6.2.2
record variable                         7.2.2
record variable list                    9.2.4
recursive                               10.
referenced variable                     7.3
relational operator                     8.1.4
REPEAT                                  9.2.3.2
repeat statement                        9.2.3.2
repetitive statement                    9.2.3
RESET                                   10.1.1
REWRITE                                 10.1.1
result type                             11.
ROUND                                   11.1.3
scalar type                             6.1.1
scale factor                            4.
scope                                   10.
separator                               14.6/14.7
SET                                     6.2.3
set                                     8.
set type                                6.2.3
sign                                    4.
simple expression                       8.
simple statement                        9.1
simple type                             6.1
SIN                                     11.1.1 
special symbol                          3.
space                                   14.4/14.6
SQR                                     11.1.1
SQRT                                    11.1.1
standard functions                      11.1
standard procedures                     10.1
statement                               9.
statement part                          10.
string                                  4.
structured statement                    9.2
structured type                         6.2
subrange type                           6.1.3
SUCC                                    11.1.4
tag field                               6.2.2
term                                    8.
TEXT                                    6.2.4
THEN                                    9.2.2.1
TO                                      9.2.3.3
TRUE                                    6.1.2
TRUNC                                   11.1.3
TYPE                                    10.
type                                    6.
type definition                         6.
type definition part                    10.
type identifier                         6.1
unlabelled statement                    9.
UNPACK                                  10.1.3
unpacked structured type                6.2
unsigned constant                       8.
unsigned integer                        4.
unsigned number                         4.
unsigned real                           4.
UNTIL                                   9.2.3.2
VAR                                     10.
varible                                 7.
variable declaration                    7.
variable declaration part               10.
variable identifier                     7.1
variant                                 6.2.2
variant part                            6.2.2
WHILE                                   9.2.3.1
while statement                         9.2.3.1
WITH                                    9.2.4
with statement                          9.2.4
WRITE                                   12.3
WRITELN                                 12.4
' (single quote)                        4.
(                                       6.1.1/6.2.2/8./8.2/9.1.2/13.
(*                                      3.
)                                       6.1.1/6.2.2/8./8.2/9.1.2/13.
*                                       8.1.2
*)                                      3.
+                                       4./8.1.3/14.4
, (comma)                               6.1.1/6.2.1/6.2.2/7./7.2.1/8./
                                        8.2/9.1.2/9.2.2.2/9.2.4/10./13.
- (minus sign)                          4./8.1.3
. (period)                              4./7.2.2/13.
..                                      6.1.3./8.
/                                       8.1.2
0                                       14.4
1                                       14.4
: (colon)                               9./9.2.2.2/11.
:=                                      9.1.1/9.2.3.3
; (semicolon)                           6.2.2/9.2.1/9.2.2.2/9.2.3.2/10./11.
<                                       8.1.4
<=                                      8.1.4
<>                                      8.1.4
=                                       8.1.4
>                                       8.1.4
>=                                      8.1.4
[                                       6.2.1/8.
]                                       6.2.1/8.
^ (up arrow)                            6.3/7./7.2.3/7.3
{ (left brace)                          3.
} (right brace)                         3.


========================================================================================
DOCUMENT :usus Folder:VOL04:kb.dbdemo.text
========================================================================================

(*$S+*)
PROGRAM DBTEST;
USES DBUNIT,SCUNIT,STARTER;

BEGIN (*DBDEMO PROGRAM*)
  STINITIALIZE;
  REPEAT
    GOTOXY(0,0);
    BLANKTOPLINE;
    CASE GETCOMMAND('DBDEMO: C(hangerec F(indrec G(etrec N(ewrec Q(uit T(race',
                                ['C', 'F', 'G', 'N', 'Q', 'T']) OF
      'C': IF CHANGEREC(WA1) THEN SAVEREC;
      'F': FINDREC;
      'G': GETREC;
      'N': NEWREC;
      'T': BEGIN
             DEBUGGING:=TRUE;
             DBSHOWERR('Halt request from keyboard - allows trace change',100);
             DEBUGGING:=FALSE;
           END;
      'Q': DONE:=TRUE
    END (*CASE*);
  UNTIL DONE;
END.


========================================================================================
DOCUMENT :usus Folder:VOL04:kb.scunit.text
========================================================================================

(*$L #5:SCUNIT.LST.TEXT*)
(*$S+*)
UNIT SCUNIT;
  (*Copyright 1980 Kenneth L. Bowles, All rights reserved. Permission is
    hereby granted to use this material for any non-commercial purpose*)
  
  (*This version includes specific constants for Terak 8510A*)
INTERFACE
TYPE
    SCCHSET = SET OF CHAR;
    SCKEYCOMMAND = (BACKSPACEKEY,ETXKEY,ESCKEY,DELKEY,UPKEY,DOWNKEY,
                                LEFTKEY,RIGHTKEY,NOTLEGAL);
    
VAR
  SCCH:CHAR;

PROCEDURE SCINITIALIZE;
PROCEDURE SCLEFT;
PROCEDURE SCRIGHT;
PROCEDURE SCUP;
PROCEDURE SCDOWN;
PROCEDURE SCGETCCH(VAR CH:CHAR; OKSET:SCCHSET);
FUNCTION  SCMAPCRTCOMMAND(KCH: CHAR): SCKEYCOMMAND;
PROCEDURE SCREADSTRG(VAR S:STRING; WIDTH:INTEGER; 
                                 CCHSET:SCCHSET; ROW,COL:INTEGER);
PROCEDURE SCREADINT(VAR X: INTEGER; WIDTH:INTEGER; ROW,COL:INTEGER);

IMPLEMENTATION
CONST
  SCEOL=13;
  BELL=7;
  UNDERLINE='_';
  
VAR
  TRANSLATE: PACKED ARRAY[CHAR] OF SCKEYCOMMAND;
  KEYBRD: PACKED ARRAY[SCKEYCOMMAND] OF CHAR;

PROCEDURE SCINITIALIZE;
  VAR I:INTEGER;
  BEGIN
    FOR I:=0 TO 255 DO TRANSLATE[CHR(I)]:=NOTLEGAL;
    
    TRANSLATE[CHR(8)]:=BACKSPACEKEY;
    KEYBRD[BACKSPACEKEY]:=CHR(8);
    
    TRANSLATE[CHR(3)]:=ETXKEY;
    KEYBRD[ETXKEY]:=CHR(3);
    
    TRANSLATE[CHR(26)]:=UPKEY;
    KEYBRD[UPKEY]:=CHR(26);
    
    TRANSLATE[CHR(12)]:=DOWNKEY;
    KEYBRD[DOWNKEY]:=CHR(12);
    
    TRANSLATE[CHR(23)]:=LEFTKEY;
    KEYBRD[LEFTKEY]:=CHR(23);
    
    TRANSLATE[CHR(11)]:=RIGHTKEY;
    KEYBRD[RIGHTKEY]:=CHR(11);
    
    KEYBRD[ESCKEY]:=CHR(27);
    
    KEYBRD[DELKEY]:=CHR(127);
    
  END (*INITIALIZE*);

FUNCTION SCMAPCRTCOMMAND(*(VAR KCH:CHAR): SCKEYCOMMAND*);
BEGIN
  SCMAPCRTCOMMAND:=TRANSLATE[KCH]
END;

PROCEDURE SCLEFT;
BEGIN
  WRITE(CHR(8));
END (*SCLEFT*);

PROCEDURE SCRIGHT;
BEGIN
  WRITE(CHR(28));
END (*SCRIGHT*);

PROCEDURE SCUP;
BEGIN
  WRITE(CHR(31));
END (*SCUP*);

PROCEDURE SCDOWN;
BEGIN
  WRITE(CHR(10));
END (*SCDOWN*);

PROCEDURE SQUAWK;
BEGIN
  WRITE(CHR(BELL));
END;

PROCEDURE SCGETCCH(*VAR CH: CHAR; OKSET: SCCHSET*);
BEGIN
  REPEAT (*If user wants a character then get one that's LEGAL*)
    READ(KEYBOARD,CH);
    IF EOLN(KEYBOARD) THEN CH:=CHR(SCEOL);
    IF NOT (CH IN OKSET) THEN
      SQUAWK;
  UNTIL (CH IN OKSET);
END;
    
PROCEDURE UCLC(VAR CH:CHAR);
BEGIN
  IF CH IN ['a'..'z'] THEN CH:=CHR(ORD(CH)-32);
END (*UCLC*);

PROCEDURE FILLFIELD(CH:CHAR; WIDTH:INTEGER);
(*fill a field on screen with CH by fastest method (in practice) *)
VAR A:PACKED ARRAY[0..79] OF CHAR;
BEGIN
  FILLCHAR(A[0], WIDTH, CH);
  WRITE(A:WIDTH);
END (*FILLFIELD*);

PROCEDURE TRUNCSTRING(WIDTH:INTEGER; INSTRG:STRING; 
                        VAR OUTSTRG: STRING);
BEGIN
  IF LENGTH(INSTRG)<=WIDTH THEN
    OUTSTRG:=INSTRG
  ELSE
    OUTSTRG:=COPY(INSTRG,1,WIDTH);
END (*TRUNCSTRG*);

(*$G+*)

PROCEDURE SCREADSTRG(*VAR S:STRING; WIDTH:INTEGER; 
                                 CCHSET:SCCHSET; ROW,COL:INTEGER*);
(*this is (hopefully) a reasonably friendly string read to replace the
  standard routine in the system*)
(*display S, with underlining to fill out remainder of WIDTH columns.
  allow editing within the displayed field. See embedded comments
  regarding edit commands.*)
LABEL 2;
VAR
  CH:CHAR;
  X:STRING[1];
  CURSINX,CHCNT:INTEGER;
  CHOK:SCCHSET;
  TS,TAILS:STRING;
BEGIN
  X:=' ';
  TS:=S;
  CHCNT:=LENGTH(TS);
  GOTOXY(COL,ROW);
  IF LENGTH(TS) > WIDTH THEN
    DELETE(TS,WIDTH+1, (WIDTH-LENGTH(TS)));
  WRITE(TS);
  IF LENGTH(TS) < WIDTH THEN
    FILLFIELD(UNDERLINE, WIDTH - LENGTH(TS));
  GOTOXY(COL,ROW);
  CURSINX:=1;
  CHOK:=CCHSET + [CHR(SCEOL), KEYBRD[ESCKEY], KEYBRD[RIGHTKEY],
            KEYBRD[LEFTKEY], KEYBRD[BACKSPACEKEY], KEYBRD[DELKEY] ];
  REPEAT
    SCGETCCH(CH,CHOK);
    IF CH=KEYBRD[ESCKEY] THEN
      BEGIN (*restore previous string to screen & bail out*)
        GOTOXY(COL,ROW);
        FILLFIELD(' ',WIDTH);
        GOTOXY(COL,ROW);
        WRITE(S);
        GOTO 2;
      END;
    IF CH IN [KEYBRD[BACKSPACEKEY], KEYBRD[LEFTKEY] ] THEN
      BEGIN (*move cursor left one position*)
        IF CURSINX > 1 THEN
          BEGIN
            SCLEFT;
            CURSINX:=CURSINX-1;
          END;
      END
    ELSE
      IF CH=KEYBRD[RIGHTKEY] THEN
        BEGIN (*move cursor right one position*)
          IF (CURSINX < (CHCNT+1)) AND (CURSINX < WIDTH) THEN
            BEGIN
              SCRIGHT;
              CURSINX:=CURSINX+1;
            END;
        END
      ELSE
        IF CH=KEYBRD[DELKEY] THEN
          BEGIN (*delete one character, redisplay the tail*)
            IF CHCNT > 0 THEN
              BEGIN
                DELETE(TS,CURSINX,1);
                CHCNT:=CHCNT-1;
                TAILS:=TS;
                IF CURSINX > 1 THEN
                  DELETE(TAILS,1,CURSINX-1);
                WRITE(TAILS);
                WRITE(UNDERLINE);
                GOTOXY((COL+CURSINX-1),ROW);
              END;
          END
        ELSE
          IF CH <> CHR(SCEOL) THEN
            (*insert the character and redisplay the tail*)
            IF CHCNT < WIDTH THEN
              BEGIN
                X[1]:=CH;
                INSERT(X,TS,CURSINX);
                CHCNT:=CHCNT+1;
                TAILS:=TS;
                DELETE(TAILS,1,CURSINX-1);
                WRITE(TAILS); (*only the tail needs to be rewritten*)
                IF CURSINX < WIDTH THEN
                  CURSINX:=CURSINX+1;
                GOTOXY((COL+CURSINX-1),ROW);
              END;
  UNTIL (CH = CHR(SCEOL));
  S:=TS;
2:
END (*SCREADSTRG*);

PROCEDURE SCREADINT(*VAR X: INTEGER; WIDTH:INTEGER; ROW,COL:INTEGER*);
(*read integers in as friendly a way as possible - without blowing up*)
(*This is for reading 16 bit integers - not long integers*)
LABEL 1,2;
CONST
  BADINT= -32767;
VAR NUM,PCH,PWRTEN,DIGIT:INTEGER;
  CH:CHAR;
  NEGATIVE,DONE:BOOLEAN;
  S:STRING[7];
BEGIN
  GOTO 2; (*Jump over error handling*)
1:
  GOTOXY(COL,ROW);
  FOR PCH:=1 TO WIDTH DO WRITE('*');
  SQUAWK;
2:
  S:='';
  SCREADSTRG(S,WIDTH,[' ','-','+','0'..'9'],ROW,COL);
  NUM:=0;
  PWRTEN:=1;
  PCH:=1;
  NEGATIVE:=FALSE;
  DONE:=FALSE;
  X:=BADINT;
  (*Strip off leading blanks*)
  WHILE (LENGTH(S)>0) AND (NOT DONE) DO
    IF S[1]=' ' THEN
      DELETE(S,1,1)
    ELSE
      DONE:=TRUE;
  IF LENGTH(S)>0 THEN
    BEGIN
      IF S[1] IN ['+','-'] THEN
        BEGIN
          NEGATIVE:=(S[1]='-');
          DELETE(S,1,1);
        END;
      PCH:=LENGTH(S);
      WHILE (PCH>=1) AND (NUM<10000) DO
        BEGIN
          IF S[PCH] IN [' ','+','-'] THEN
            GOTO 1
          ELSE
            DIGIT:=ORD(S[PCH])-ORD('0');
          IF NUM>1000 THEN
            CASE S[PCH] OF
              '0','1','2': NUM:=NUM+DIGIT*PWRTEN;
                      '3': IF NUM<=2767 THEN
                             NUM:=NUM+30000
                           ELSE
                             GOTO 1;
              '4','5','6','7','8','9': GOTO 1
            END (*CASES*)
          ELSE
            NUM:=NUM+DIGIT*PWRTEN;
          PWRTEN:=PWRTEN*10;
          PCH:=PCH-1;
        END (*WHILE*);
      IF NEGATIVE THEN
        X:=-NUM
      ELSE
        X:=NUM;
    END (*LENGTH(S)>0*);
END (*READINT*);


END.


========================================================================================
DOCUMENT :usus Folder:VOL04:kb.starter.text
========================================================================================

(*$S+*)
UNIT STARTER;
INTERFACE
USES DBUNIT,SCUNIT;
CONST
  WA0=0;
  WA1=1;
  WA2=2;
  FNUM=0;
  PAGEZERO=0;
  EOL=13;
  ESC=27;
  ETX=3;
  LASTSELCH='Z';
  PAGELASTBYTE=4095;
  MINRECSPACE=250;
  PEOPLEGROUP=0;
  PERSONREC=0;
  INDEXGROUP=1;
  INDEXREC=1;
  KEYFIELD=4;
  
TYPE
  STRINGPTR = ^STRING;
  
  TRIXPTR =
    RECORD CASE DBLEVELTYPE OF
      FIELDT: (F:FLDDESPTR);
      RECORDT:( (*R:RECDESPTR*) );
      GROUPT: ( (*G:GRPDESPTR*) );
      NONET:  (S:STRINGPTR)
    END;
    
  SELECTITEM =
    RECORD
      SFP: FLDDESPTR;
      SITEMNUM: INTEGER;
      SDESCRIPTORNUM: INTEGER;
    END;
    
VAR
  PAGENUM,GROUPNUM, RECNUM:INTEGER;
  INDEXPAGE, (*temporarily - fixed index page; later - coarse index*)
    FIRSTAVAILPAGE, (*page into which next person record should be placed*)
    DUMMY:INTEGER;
  DONE:BOOLEAN;
  CHOK:SCCHSET;
  MAXSELCH:CHAR;
  SELECT: ARRAY['A'..LASTSELCH] OF SELECTITEM;
  INDEXITEMS: STRING[20];
  PAGEINWA: ARRAY[DBWRKINDEX] OF INTEGER;
  
PROCEDURE BLANKTOPLINE;
FUNCTION GETCOMMAND(S:STRING; OKSET:SCCHSET):CHAR;
PROCEDURE CHECKPAGE(WI:DBWRKINDEX; PAGENUM:INTEGER);
PROCEDURE STINITIALIZE;
PROCEDURE SHOWREC(WI:DBWRKINDEX);
FUNCTION CHANGEREC(WI:DBWRKINDEX):BOOLEAN;
PROCEDURE SAVEINDEXITEM(SELCH:CHAR);
PROCEDURE SAVEREC;
PROCEDURE FETCHREC;
PROCEDURE FINDREC;
PROCEDURE NEWREC;
PROCEDURE GETREC;

  
IMPLEMENTATION

PROCEDURE BLANKTOPLINE;
BEGIN
  GOTOXY(0,0);
  WRITE(
'                                                                           ');
  GOTOXY(0,0);
END (*BLANKTOPLINE*);
  
FUNCTION GETCOMMAND(*S:STRING; OKSET:SCCHSET):CHAR*);
VAR CH:CHAR;
BEGIN
  REPEAT
    BLANKTOPLINE;
    WRITE(S);
    READ(KEYBOARD,CH);
    IF EOLN(KEYBOARD) THEN CH:=CHR(EOL);
    IF CH IN ['a'..'z'] THEN
      CH:=CHR(ORD(CH)-32);
  UNTIL CH IN OKSET;
  GETCOMMAND:=CH;
END (*GETCOMMAND*);

PROCEDURE CHECKPAGE(*WI:DBWRKINDEX; PAGENUM:INTEGER*);
VAR DUMMY:INTEGER;
BEGIN
  IF PAGEINWA[WI] <> PAGENUM THEN
    BEGIN
      DUMMY:=DBGETPAGE(FNUM, WI, PAGENUM);
      PAGEINWA[WI]:=PAGENUM;
    END;
  DUMMY:=DBHOME(WI);
END (*CHECKPAGE*);

PROCEDURE MOVETOFIRSTAVAILPAGE;
VAR DUMMY:INTEGER;
BEGIN
  CHECKPAGE(WA0, PAGEZERO);
  DUMMY:=DBHOME(WA0);
  DUMMY:=DBDESCEND(WA0); (*to record level*)
  DUMMY:=DBDESCEND(WA0); (*to field level*)
  DUMMY:=DBGET(WA0);
END (*MOVETOFIRSTAVAILPAGE*);

PROCEDURE GETFIRSTAVAIL;
VAR DUMMY:INTEGER;
BEGIN
  MOVETOFIRSTAVAILPAGE;
  FIRSTAVAILPAGE:=ORD(DBMAIL.STRG[2]); (*temporary kludge*)
  INDEXPAGE:=ORD(DBMAIL.STRG[1]);
END (*GETFIRSTAVAIL*);

PROCEDURE SAVEFIRSTAVAIL;
VAR DUMMY:INTEGER;
BEGIN
  MOVETOFIRSTAVAILPAGE;
  DBMAIL.STRG[2]:=CHR(FIRSTAVAILPAGE); (*temporary kludge*)
  DBMAIL.DBMAILTYPE:=STRINGF;
  DUMMY:=DBPUT(WA0);
  DUMMY:=DBPUTPAGE(FNUM,WA0,PAGEZERO);
END (*SAVEFIRSTAVAIL*);
  
PROCEDURE STINITIALIZE;
VAR NWA,RSLT:INTEGER;
  TITLE:STRING;
BEGIN
  DBINITIALIZE;
  SCINITIALIZE;
  REPEAT
    WRITE('Data Base File Title:');
    READLN(TITLE);
    RSLT:=DBFOPEN(FNUM,TITLE);
    IF RSLT <> 0 THEN
      WRITELN('Can''t open the file');
  UNTIL RSLT = 0;
  DBSHOWERR('Init-Getpage', DBGETPAGE(FNUM, WA0, PAGEZERO));
  PAGEINWA[WA0]:=PAGEZERO;
  DBTYPECHECK:=FALSE;
  DBSHOWERR('Init-descriptors', DBGROUPINIT(FNUM,RSLT,'ALL'));
  DBTYPECHECK:=TRUE;
  DONE:=FALSE;
  DBSHOWERR('Init-open(WA1)', DBWRKOPEN(WA1,(PAGELASTBYTE+1)));
  DBSHOWERR('Init-open(WA2)', DBWRKOPEN(WA2, MINRECSPACE));
  FOR NWA:=1 TO LASTWRKINDEX DO
    PAGEINWA[NWA]:=-1;
  GETFIRSTAVAIL;
  WRITELN;
  WRITELN('First available page is # ', FIRSTAVAILPAGE);
  WRITELN('Index page is # ', INDEXPAGE);
  INDEXITEMS:='DE'; (*Name, Company fields - could be chosen from keyboard
                        if we wanted slightly fancier program*)
END (*STINITIALIZE*);

PROCEDURE LOCATOR(WI:DBWRKINDEX; GROUPNUM,RECNUM:INTEGER);
VAR I:INTEGER;
BEGIN
  DBSHOWERR('LOC#1', DBHOME(WI));
  DBSHOWERR('LOC#2', DBSEEK(WI, GROUPNUM));
  DBSHOWERR('LOC#3', DBDESCEND(WI)); (*to record level*)
  DBSHOWERR('LOC#4', DBSEEK(WI, RECNUM));
END (*LOCATOR*);

PROCEDURE SHOWREC(*WI:DBWRKINDEX*);
(*show the content of a data record within its labelled form*)
VAR FP:FLDDESPTR;
  TP:TRIXPTR;
  OFFSET,ITEMNUM,DESCRIPTORNUM,RSLT:INTEGER;
  LEVEL:DBLEVELTYPE;
  SELCH:CHAR;
  NS:STRING;
BEGIN
  PAGE(OUTPUT);
  DBITEMINFO(WI,LEVEL,ITEMNUM,OFFSET,DESCRIPTORNUM,NS);
  IF LEVEL = RECORDT THEN
    BEGIN
      RSLT:=DBDESCEND(WI); (*to field level*)
      DBITEMINFO(WI,LEVEL,ITEMNUM,OFFSET,DESCRIPTORNUM,NS);
      DBGETDESCRIPTOR(FIELDT,DESCRIPTORNUM,FP);
      SELCH:='A';
      MAXSELCH:=SELCH;
      CHOK:= [];
      WHILE (RSLT = 0) AND (FP <> NIL) DO
        WITH FP^ DO
          BEGIN
            IF FLDTYPE IN [STRINGF,INTEGERF] THEN
              BEGIN
                GOTOXY(LABELCOL, ROW);
                (*note link value is one more than correct string length*)
                WRITE(SELCH,'>');
                WRITE(NAME:(LENGTH(NAME)-1));
                GOTOXY(DATACOL, ROW);
                DBSHOWERR('Showrec-Data', DBWRITEFIELD(OUTPUT, WI));
                CHOK:=CHOK+[SELCH];
                WITH SELECT[SELCH] DO
                  BEGIN
                    SFP:=FP;
                    SITEMNUM:=ITEMNUM;
                    SDESCRIPTORNUM:=DESCRIPTORNUM;
                  END;
                MAXSELCH:=SELCH;
                SELCH:=CHR(ORD(SELCH)+1);
              END (*FLDTYPE <> GROUPF*);
            RSLT:=DBNEXT(WI);
            IF RSLT = 0 THEN
              BEGIN (*get the descriptor number, then with that FP*)
                DBITEMINFO(WI,LEVEL,ITEMNUM,OFFSET,DESCRIPTORNUM,NS);
                DBGETDESCRIPTOR(FIELDT,DESCRIPTORNUM,FP);
              END;
          END (*WITH FP^*);
    END
  ELSE
    BEGIN
      WRITELN;
      WRITELN('ERROR - Call SHOWREC when pointing at a record');
    END;
  GOTOXY(0,0);
END (*SHOWREC*);

FUNCTION CHANGEREC(*WI:DBWRKINDEX):BOOLEAN*);
(*after record is shown on screen in its form by SHOWREC, this routine
  allows editing any or all fields in the form*)
VAR SELCH,CH:CHAR;
  SELCHSET:SCCHSET;
  DUMMY:INTEGER;
  MSG:STRING;
BEGIN
  BLANKTOPLINE;
  SELCHSET:=CHOK+[CHR(EOL), CHR(ETX), CHR(ESC)];
  MSG:=
    'Pick item by lead char; <RET> next item; <ETX> accept rec; <ESC> abort';
  WRITE(MSG);
  REPEAT
    SCGETCCH(CH,SELCHSET);
    IF CH=CHR(EOL) THEN
      BEGIN
        IF SELCH < MAXSELCH THEN
          SELCH:=CHR(ORD(SELCH)+1);
        CH:=SELCH;
      END;
    IF CH IN CHOK THEN
      WITH SELECT[CH] DO
        BEGIN
          DUMMY:=DBSEEK(WI,SITEMNUM);
          DBSHOWERR('CHANGEREC-DBGET', DBGET(WI));
          WITH SFP^ DO
            IF FLDTYPE IN [STRINGF,INTEGERF] THEN
              BEGIN
                SELCH:=CH;
                CASE FLDTYPE OF
                  STRINGF: SCREADSTRG(DBMAIL.STRG, MAXWIDTH,
                                      [' '..'~'], ROW, DATACOL);
                  INTEGERF:SCREADINT(DBMAIL.INT, 6, ROW, DATACOL)
                END (*CASE*);
                DBMAIL.DBMAILTYPE:=FLDTYPE;
                DBSHOWERR('CHANGEREC-DBPUT', DBPUT(WI));
              END (*IF FLDTYPE*);
          BLANKTOPLINE;
          WRITE(MSG); (*flash top line, leave cursor at end*)
        END (*WITH SELECT*)
      ELSE
        BEGIN (*do nothing*) END;
  UNTIL CH IN [CHR(ETX),CHR(ESC)];
  CHANGEREC:= (CH = CHR(ETX));
  DUMMY:=DBASCEND(WI); (*leave pointing at parent record*)
END (*CHANGEREC*);

PROCEDURE SAVEINDEXITEM(*SELCH:CHAR*);
(*called once for each item to be indexed. data record is in WA1 with
  pointer at field level*)
VAR ITEMNUM, TAGVALUE, RSLT, NREC, DUMMY:INTEGER;
  FOUND:BOOLEAN;

  PROCEDURE PUTNEXT(I:INTEGER);
  BEGIN
    DBMAIL.INT:=I;
    DUMMY:=DBPUT(WA2);
    DUMMY:=DBNEXT(WA2);
  END (*PUTNEXT*);

BEGIN (*SAVEINDEXITEM*)
  WITH SELECT[SELCH] DO
    BEGIN
      ITEMNUM:=SITEMNUM;
      TAGVALUE:=SDESCRIPTORNUM;
    END;
  
  (*build index record in WA2*)
  ZEROWORKAREA(WA2);
  DUMMY:=DBEMPTYITEM(WA2, GROUPT, INDEXGROUP);
  DUMMY:=DBEMPTYITEM(WA2, RECORDT, INDEXREC);
  DUMMY:=DBHOME(WA2);
  DUMMY:=DBDESCEND(WA2); (*to record level*)
  DUMMY:=DBDESCEND(WA2); (*to field level*)
  DBMAIL.DBMAILTYPE:=INTEGERF;
  PUTNEXT(PAGEINWA[WA1]); (*page#*)
  PUTNEXT(GROUPNUM);
  PUTNEXT(RECNUM);
  PUTNEXT(TAGVALUE);
  (*WA1 assumed in field level on entry to this routine*)
  DUMMY:=DBSEEK(WA1,ITEMNUM); (*point to field to be indexed*)
  (*pick up the key value from data record in WA1, insert in WA2*)
  DUMMY:=DBGET(WA1); (*KEY to mailbox*)
  DUMMY:=DBPUT(WA2);
  
  (*prepare to insert in index in WA0*)
  CHECKPAGE(WA0, INDEXPAGE);
  RSLT:=DBDESCEND(WA0); (*to index rec*)
  IF RSLT = 19 (*reached end of list error, WA0 is empty*) THEN
    BEGIN (*use WA2 to start new WA0*)
      DUMMY:=DBHOME(WA2);
      DBSHOWERR('SAVEINDEXITEM - copy WA2 to WA0', DBCOPY(WA2,WA0));
    END
  ELSE
    IF RSLT <> 0 THEN
      DBSHOWERR('SAVEINDEXITEM - cant''t descend in WA0', 100)
  ELSE
    BEGIN
      (*point to location where the new item is to be placed in index*)
      DBSHOWERR('SAVEINDEXITEM - findrec',
                DBFINDREC(WA0, ASCENDING, KEYFIELD,
                DBMAIL.STRG, (*KEY*)
                NREC, FOUND)); 
      IF FOUND THEN (*KEY matches exactly*)
        BEGIN
          (*code to eliminate only those duplicates with same page, group,
            and record numbers might go here*)
        END
      ELSE
        BEGIN (*insert the new index record into index in WA0*)
          DBSHOWERR('SAVEINDEXITEM - emptyitem', 
                     DBEMPTYITEM(WA0, RECORDT, INDEXREC));
          DUMMY:=DBASCEND(WA2); (*to record level*)
          DBSHOWERR('SAVEINDEXITEM - replace WA0', DBREPLACE(WA2,WA0));
        END;
    END (*RSLT OK*);
END (*SAVEINDEXITEM*);

PROCEDURE SAVEREC;
(*save both the new or changed record, and updated index, in file*)
VAR I,DUMMY:INTEGER;
BEGIN
  DBSHOWERR('SAVEREC - People Group', DBPUTPAGE(FNUM,WA1,PAGEINWA[WA1]));
  (*enter with WA1 in Record level*)
  DUMMY:=DBDESCEND(WA1); (*to field level*)
  FOR I:=1 TO LENGTH(INDEXITEMS) DO
    SAVEINDEXITEM(INDEXITEMS[I]);
  DBSHOWERR('SAVEREC - INDEX', DBPUTPAGE(FNUM, WA0, INDEXPAGE));
END (*SAVEREC*);

PROCEDURE FETCHREC;
(*get the required page into WA1, if not already there. then display
  the record in GROUPNUM, RECNUM*)
BEGIN
  IF PAGEINWA[WA1] <> PAGENUM THEN
    BEGIN
      DBSHOWERR('GETREC', DBGETPAGE(FNUM, WA1, PAGENUM));
      PAGEINWA[WA1]:=PAGENUM;
    END;
  LOCATOR(WA1,GROUPNUM,RECNUM);
  SHOWREC(WA1);
END (*FETCHREC*);

PROCEDURE FINDREC;
CONST FIRSTLINE = 5;
VAR
  RN,RSLT,DUMMY:INTEGER;
  CH,SELCH:CHAR;
  FOUND:BOOLEAN;
  KEY:STRING;
  OFFSET,ITEMNUM,DESCRIPTORNUM:INTEGER;
  LEVEL:DBLEVELTYPE;
  NS:STRING;

  PROCEDURE PICKNEXT(VAR I:INTEGER);
  VAR DUMMY:INTEGER;
  BEGIN
    DUMMY:=DBGET(WA0);
    I:=DBMAIL.INT;
    DUMMY:=DBNEXT(WA0);
  END (*PICKNEXT*);

BEGIN
  CHECKPAGE(WA0, INDEXPAGE);
  PAGE(OUTPUT);
  WRITE('Search Key:');
  READLN(KEY);
  DUMMY:=DBDESCEND(WA0); (*to record level*)
  DBSHOWERR('FINDREC #1', DBFINDREC(WA0, ASCENDING, KEYFIELD, KEY,
                                    RECNUM, FOUND));
  (*establish beginning of range of keys to be displayed*)
  IF RECNUM > 5 THEN
    RN:=RECNUM-5
  ELSE
    RN:=0;
  DUMMY:=DBSEEK(WA0,RN);
  SELCH:='A';
  RSLT:=0;
  
  (*display up to 10 keys, identified by letters for user selection*)
  WHILE (SELCH < 'J') AND (RSLT = 0) DO
    BEGIN
      RSLT:=DBDESCEND(WA0); (*to field level*)
      (* descend should fail on nul record at tail of list *)
      IF RSLT = 0 THEN (*descend ok*)
        BEGIN
          RSLT:=DBSEEK(WA0, KEYFIELD); (*should also fail at tail*)
          IF RSLT = 0 THEN
            BEGIN
              GOTOXY(0,(FIRSTLINE+ORD(SELCH)-ORD('A')));
              WRITE(SELCH, '>');
              DUMMY:=DBWRITEFIELD(OUTPUT, WA0);
              SELCH:=CHR(ORD(SELCH)+1);
              DUMMY:=DBASCEND(WA0); (*back to record level*)
              RSLT:=DBNEXT(WA0);
            END (* SEEK RSLT OK*);
        END (*DESCEND RSLT OK*);
    END (*WHILE*);
  
  (*now check to make sure we are still at the record level - debugging*)
  DBITEMINFO(WA0,LEVEL,ITEMNUM,OFFSET,DESCRIPTORNUM,NS);
  IF LEVEL <> RECORDT THEN
    DBSHOWERR('FINDREC - not at record level!', 100)
  ELSE
    BEGIN
                
      (*ask user which entry to pick*)
      GOTOXY(0,1);
      WRITE('Pick item by initial char; <ESC> to escape');
      SCGETCCH(CH, ['A'..CHR(ORD(SELCH)-1), CHR(ESC)]);
      IF CH <> CHR(ESC) THEN
        BEGIN
          RN:=RN+ORD(CH)-ORD('A');
          DUMMY:=DBSEEK(WA0,RN);
          DUMMY:=DBDESCEND(WA0); (*to field level*)
          
          (*Pick up page, group, record numbers from index record*)
          PICKNEXT(PAGENUM);
          PICKNEXT(GROUPNUM);
          PICKNEXT(RECNUM);
          
          (*get the data record and display it*)
          FETCHREC;
        END (*CH <> ESC*);
    END (*RECORD level ok*);
END (*FINDREC*);

PROCEDURE NEWREC;
(*display a blank form, create a blank record, and collect data content
  for it from keyboard. save the new record if requested*)
VAR DUMMY,RSLT:INTEGER;
  OFFSET,ITEMNUM,DESCRIPTORNUM:INTEGER;
  LEVEL:DBLEVELTYPE;
  NS:STRING;
BEGIN
  (*Assume page PAGENUM has one group only, of People_group*)
  ZEROWORKAREA(WA2);
  DUMMY:=DBEMPTYITEM(WA2, GROUPT, PEOPLEGROUP);
  DUMMY:=DBEMPTYITEM(WA2, RECORDT, PERSONREC);
  SHOWREC(WA2); (*display the empty form with labels*)
  DUMMY:=DBHEAD(WA2);
  IF CHANGEREC(WA2) THEN (*should save it*)
    BEGIN
      DUMMY:=DBHOME(WA1);
      DUMMY:=DBDESCEND(WA1);
      DUMMY:=DBTAIL(WA1);
      RSLT:=DBREPLACE(WA2,WA1);
      IF RSLT <> 0 THEN (*insufficient room in WA1*)
        BEGIN
          (*blank out WA1, put in new record, prepare to save in a
            new page*)
          ZEROWORKAREA(WA1);
          DUMMY:=DBEMPTYITEM(WA1, GROUPT, PEOPLEGROUP);
          DUMMY:=DBEMPTYITEM(WA1, RECORDT, PERSONREC);
          DUMMY:=DBHOME(WA1);
          DUMMY:=DBDESCEND(WA1);
          RSLT:=DBREPLACE(WA2,WA1);
          FIRSTAVAILPAGE:=FIRSTAVAILPAGE+1;
          PAGEINWA[WA1]:=FIRSTAVAILPAGE;
        END (*REPLACE failed*);
      IF RSLT = 0 THEN
        BEGIN (*save the newly assigned record # in RECNUM, then
          save the record*)
          DBITEMINFO(WA1,LEVEL,ITEMNUM,OFFSET,DESCRIPTORNUM,NS);
          RECNUM:=ITEMNUM;
          SAVEREC;
        END (*RSLT OK*);
    END (*changerec succeeded*);
END (*NEWREC*);

PROCEDURE GETREC;
(*display the content of a specific record in selected page and group*)
BEGIN
  PAGE(OUTPUT);
  WRITELN;
  (*put index search calls here in place of following explicit setting
    of PAGENUM, RECNUM. Assume GROUPNUM is 0 by default*)
  WRITE('PAGE#:');
  READLN(PAGENUM);
  WRITE('GROUP#:');
  READLN(GROUPNUM);
  WRITE('RECORD#:');
  READLN(RECNUM);
  FETCHREC;
END (*GETREC*);


END.


========================================================================================
DOCUMENT :usus Folder:VOL04:kb.testdb
========================================================================================

  Y      
People_Group    Index_Group    TransGroup    Avail_Pages_Group  +           	 
   Person_Rec 6   

   
Index_Rec   	
  	Transref 2       Avail_Pages_Rec }     A4 	Category     A4 
Last_Date     A4 Access#  #      Name  #      Company  #      Street/Box  #      City        State/Country      A4 	Zip Code      >4 Phone           
Transactions        Page#        Group#        Rec#         Tag  (        Key  
       Avail_Pages_Fld   g d s { James W. BandyTexas Instruments12860 Hillcrest, MS 370DallasTexas75230(214)980-6107                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                         ;	     Bandy, James W. 	     Byte Books 	     Byte Magazine ,	     !Computer Power of Australia Pty. $	     Daneva Control Pty. Ltd. (	     Electronic Engineering Times &	      Fenwick Software Pty. Ltd. 	     Forsyth, Dr.Daniel ,	     !Helmers, Carl T. Jr. - Edit Dir. .	      #Hunt, Helen - Principal Programmer -	     "Integrated Computer Systems, Inc. .	   	  #Israel, Marvin - Computer Sci. Ed. %	     Japan Automation Co. Ltd. .	     #Japan Business Automation Co. Ltd. "	     Kojima, Jun - Director +	      Liffick, Blaise W. - Sr. Editor *	   
  Missler, Charles W. - Chairman $	     Mote, Michael - Director *	     Ortex Computer Sales & Service $	     Sale, Prof. Arthur H. J. &	   	  Springer Verlag Publishers /	     $Tasmania, Univ of - Inf. Sci. Dept. "	     Texas Instruments Inc. 	     Trewin, Bob '	     Wadham, Ian D. - Tech. Mgr. *	     Werner, Jerry - Western Editor !	   
  Western Digital Corp.                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                            #Hunt, Helen - Principal ProgrammerFenwick Software Pty. Ltd.140 William St.
MelbourneVictoria 3000, Australia300067-9265 r    Trewin, BobOrtex Computer Sales & Service37 Townshend St.PhillipA.C.T. 2606, Australia260682-4995 j    Bandy, James W.Texas Instruments Inc.12860 Hillcrest, MS 370DallasTexas75230(214)980-6107     Sale, Prof. Arthur H. J.$Tasmania, Univ of - Inf. Sci. Dept.Box 252C G.P.O.HobartTasmania, Australia7001
(002)23-0561   Wadham, Ian D. - Tech. Mgr.!Computer Power of Australia Pty.244 Canterbury RoadSurrey Hills, MelbourneVictoria, Australia3127	690-3288     Mote, Michael - DirectorDaneva Control Pty. Ltd.70 Bay RoadSandringham, MelbourneVictoria, Australia3191
(03)598-5622 {    Forsyth, Dr.Daniel"Integrated Computer Systems, Inc.3304 Pico Blvd.
Santa MonicaCalifornia90405(213)450-2060 t    !Helmers, Carl T. Jr. - Edit Dir.Byte Magazine70 Main St.
PeterboroughNew Hampshire03458(603)924-7217 p   	  Liffick, Blaise W. - Sr. EditorByte Books70 Main St.
PeterboroughNew Hampshire03458(603)924-7217 }   
 #Israel, Marvin - Computer Sci. Ed.Springer Verlag Publishers175 Fifth Ave.	New York	New York10010(212)477-8200     Missler, Charles W. - ChairmanWestern Digital Corp.3128 Red Hill Ave, Box 2180Newport Beach California92663(714)557-3550     Werner, Jerry - Western EditorElectronic Engineering Times4500 Campus Drive, Suite 112Newport BeachCalifornia92660(714)631-3322 @      Kojima, Jun - DirectorJapan Automation Co. Ltd.                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                       FSET,ITEMNUM,DESCRIPTORNUM:INTEGER;
"LEVEL:DBLEVELTYPE;
"NS:STRING;
 BEGIN
"(*Assume page PAGENUM has one group only, of People_group*)
"ZEROWORKAREA(WA2);
"DUMMY:=DBEMPTYITEM(WA2, GROUPT, PEOPLEGROUP);
"DUMMY:=DBEMPTYITEM(WA2, RECORDT, PERSONREC);
"SHOWREC(WA2); (*display the empty form with labels*)
"DUMMY:=DBHEAD(WA2);
"IF CHANGEREC(WA2) THEN (*should save it*)
$BEGIN
&DUMMY:=DBHOME(WA1);
&DUMMY:=DBDESCEND(WA1);
&DUMMY:=DBTAIL(WA1);
&RSLT:=DBREPLACE(WA2,WA1);
                              &IF RSLT <> 0 THEN (*insufficient room in WA1*)
(BEGIN
*(*blank out WA1, put in new record, prepare to save in a
,new page*)
*ZEROWORKAREA(WA1);
*DUMMY:=DBEMPTYITEM(WA1, GROUPT, PEOPLEGROUP);
*DUMMY:=DBEMPTYITEM(WA1, RECORDT, PERSONREC);
*DUMMY:=DBHOME(WA1);
*DUMMY:=DBDESCEND(WA1);
*RSLT:=DBREPLACE(WA2,WA1);
*FIRSTAVAILPAGE:=FIRSTAVAILPAGE+1;
*PAGEINWA[WA1]:=FIRSTAVAILPAGE;
(END (*REPLACE failed*);
&IF RSLT = 0 THEN
(BEGIN (*save the newly assigned record # in RECNUM, then
*save the record*)
*DBITEMINFO(WA1,LEVEL,ITEMNUM,OFFSET,DESCRIPTORNUM,NS);
*RECNUM:=ITEMNUM;
*SAVEREC;
$    END (*RSLT OK*);
$END (*changerec succeeded*);
 END (*NEWREC*);
 
 PROCEDURE GETREC;
 (*display the content of a specific record in selected page and group*)
 BEGIN
"PAGE(OUTPUT);
"WRITELN;
"(*put index search calls here in place of following explicit setting
$of PAGENUM, RECNUM. Assume GROUPNUM is 0 by default*)
"WRITE('PAGE#:');
"READLN(PAGENUM);
"WRITE('GROUP#:');
"READLN(GROUPNUM);
               "WRITE('RECORD#:');
"READLN(RECNUM);
"FETCHREC;
 END (*GETREC*);
 
 BEGIN (*DBDEMO PROGRAM*)
"INIT;
"REPEAT
$GOTOXY(0,0);
$BLANKTOPLINE;
$CASE GETCOMMAND('DBDEMO: C(hangerec F(indrec G(etrec N(ewrec Q(uit T(race',
@['C', 'F', 'G', 'N', 'Q', 'T']) OF
&'C': IF CHANGEREC(WA1) THEN SAVEREC;
&'F': FINDREC;
&'G': GETREC;
&'N': NEWREC;
&'T': BEGIN
-DEBUGGING:=TRUE;
-DBSHOWERR('Halt request from keyboard - allows trace change',100);
-DEBUGGING:=FALSE;
+END;
&'Q': DONE:=TRUE
$END (*CASE*);
"UNTIL DONE;
 END.
 
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                           "IF PAGEINWA[WA1] <> PAGENUM THEN
$BEGIN
&DBSHOWERR('GETREC', DBGETPAGE(FNUM, WA1, PAGENUM));
&PAGEINWA[WA1]:=PAGENUM;
"  END;
"LOCATOR(WA1,GROUPNUM,RECNUM);
"SHOWREC(WA1);
 END (*FETCHREC*);
 
 PROCEDURE FINDREC;
 CONST FIRSTLINE = 5;
 VAR
"RN,RSLT,DUMMY:INTEGER;
"CH,SELCH:CHAR;
"FOUND:BOOLEAN;
"KEY:STRING;
 
"PROCEDURE PICKNEXT(VAR I:INTEGER);
"VAR DUMMY:INTEGER;
"BEGIN
"  DUMMY:=DBGET(WA0);
$I:=DBMAIL.INT;
$DUMMY:=DBNEXT(WA0);
"END (*PICKNEXT*);
 
 BEGIN
"CHECKPAGE(WA0, INDEXPAGE);
"PAGE(OUTPUT);
"WRITE('Search Key:');
"READLN(KEY);
"DUMMY:=DBDESCEND(WA0); (*to record level*)
"DBSHOWERR('FINDREC #1', DBFINDREC(WA0, ASCENDING, KEYFIELD, KEY,
DRECNUM, FOUND));
"(*establish beginning of range of keys to be displayed*)
"IF RECNUM > 5 THEN
$RN:=RECNUM-5
"ELSE
$RN:=0;
   DUMMY:=DBSEEK(WA0,RN);
"SELCH:='A';
"RSLT:=0;
"
"(*display up to 10 keys, identified by letters for user selection*)
"WHILE (SELCH < 'J') AND (RSLT = 0) DO
$BEGIN
&GOTOXY(0,FIRSTLINE);
                1                                                                                                                                                                                                      !                                                            E   ^ Ҡ                                                                                                                                                                                                                         
========================================================================================
DOCUMENT :usus Folder:VOL04:teach.wumpus
========================================================================================

Welcome to 'Hunt the Wumpus' 

     The Wumpus lives in a cave of 20 rooms.  Each room has 3 tunnels leading 
to other rooms.  There are several caves that you can play in.  With only a
small change in the program, you can even invent you own cave!

     Hazards:  
     
Bottomless Pits - Two rooms have bottomless pits in them.  If you go there,  
     you fall into the pit and lose!
     
Super Bats - Two rooms have super bats.  If you go there, a bat grabs you and 
     takes to some other room at random.  (which mignt be troublesome)
     
     Wumpus:

     The Wumpus is not bothered by the hazards (he has sucker feet and is too 
big for a super bat to lift).  Usually he is asleep.  Two things wake him up:  
your entering his room or your shooting an arrow.

     If the Wumpus wakes he moves (p=.75) one room or stays still (p=.25).  
After that, if he is where you are, he eats you up and you lose!
$pause

     You:

     Each turn you can move or shoot a crooked arrow.  Moving:  you can go one 
room (thru one tunnel).  Arrows:  you have 5 arrow.  You lose when you run 
out.  Each arrow can go from 1 to 5 rooms.  You aim by telling the computer 
the room numbers you want the arrow to go to.  If the arrow can't go that way 
(ie. no tunnel) it moves at random to the next room.  If the arrow hits the 
Wumpus, you win.  If the arrow hits you, you lose.

     Warnings:

     When you are one room away from the Wumpus or a hazard, the cumputer 
says:
Wumpus - 'I smell a Wumpus'
Bat    - 'Bats nearby'
Pit    - 'I feel a draft'

  Caves:

      All caves have have 20 rooms and 3 tunnels leading from one room
to other rooms.  The caves are: 
$pause 
0 - Dodecahedron 
     The rooms of this cave are on a 12-sided object, each forming a pentagon.
The rooms are at the corners of the pentagons.  Each room has tunnels that 
lead to 3 other rooms.  

1 - Mobius Strip
     This cave is two rooms wide and 10 rooms around (like a belt).  You will 
notice that there is a half twist somewhere.

2 - String of Beads
     Five beads in a circle.  Each bead is a diamond with a virtical cross-
bar.  The right and left corners lead to neighboring beads. (This one is 
difficult to play)

3 - Toroidal Hex Network
     Imagine a hex tile floor.  Take a rectangle with 20 points (inter-
sections) inside (4 X 4).  Join right and left sides to make a cylinder.  Then 
join top and bottom to form a torus (doughnut).  Have fun imagining this one!

$pause
Caves 0-3 are regular in the sense that each room goes to three other rooms
and each tunnel allows two-way traffic.  Caves 4 and 5 do not have these
properties.

4 - Dendrite with Degeneracies
     Pull a plant from the ground.  The roots and branches form a Dendrite.
There are no looping paths.  Degeneracy means that some rooms connect to
themselves and some rooms have more than one tunnel to the same other room.

5 - One Way Latice
     Here all tunnels go one way only.  To return to the room you just left,
you must go all the way around the cave (only 5 moves).

GOOD LUCK - HAPPY WUMPUS HUNTING!
$pause

========================================================================================
DOCUMENT :usus Folder:VOL04:usus.news.text
========================================================================================

                                                            22 July 1980

                   TO USERS OF THE UCSD PASCAL USERS' LIBRARY

     Here's some news from the UCSD Pascal front lines (I am reporting
according to the way I saw it, so don't be surprised if others also present
interpreted events differently):

     The UCSD System Users Society (USUS) was formed last month at San
Diego.  It is a vigorous, alive, and independent organization that right now
is oriented to those who plan to make their living using the UCSD system,
primarily the Pascal language.  It is possible that hobbiest users may play
more of a role in the future.

     SofTech Microsystems organized the meeting and was extremely careful to 
clearly give it away to the users.  The users in turn made no bones about 
their needs and gripes with SofTech, particularly the importance to them of
SofTech's releasing Version 4.0 in the NEAR future.  For months the word has
been that it's been only a few weeks away from being marketed.  The purpose of
4.0 is twofold, I gathered: 1) to clean up the "warts" and weird system
dependencies of the UCSD system and to finally remove it from the realm of a
highly advanced student project, plus 2) to restore total object-code machine
independence, where programs will run unaltered on multiple machines.  Most of
the users agreed that even more than implementing Pascal on a micro, what they
liked most about the UCSD system was its uniformity across multiple systems. 
TI and Boeing, for instance, chose the UCSD system for these reasons, though
the man from Boeing noted that alterations were required for total machine
transparency.  The delays in releasing 4.0 apparently stem from the intention
at SofTech that it be fully compatible with 2.1 (the Apple system) and 3.0
(the Microengine), despite less than optimal cooperation from the
manufacturers involved.

     The things that will be cleaned up include the UNITS system (allowing
linkage at runtime, plus a greatly expanded number of available segments),
subtle compiler bugs, and a few fixes in the editor and operating system.  The
minimal facilities for concurrancy present in the Microengine system will
apparantly be extended to all.  Despite the fact that many people would like
to expand the operating system beyond the present single-user development
system model, these features won't be changed a great deal at present. 

     The future holds a number of tantalizing possibilities and promises.  A 
major emphasis will be the extension of addressing beyond the present maximum 
of 64K, requiring (of course) more than 16-bit integer arithmetic as a
standard, something I feel is a limitation of the present system anyway.  No
one has talked about how this will be done and yet retain compatibility with
present systems.  We need improved error handling that does not all to be done
by the user program, so commercial applications programs do not bomb out to
the operating system (although there are some tricky, kludgy ways involving a
fake SYSTEM.DEBUGGER program that EXITS back to the user program; I know no
more).  We need a more flexible front end (GETCOMMAND, the main command
processor), so writers of business systems can disguise the operating system
from the user.  There was considerable interest in a UNIX-like operating
system with concurrancy, multi-user and multi-tasking capabilities, and
shells and pipes.  More than likely, this is a good way into the future;
first, we've got to get an expanded system going on the new 16-bit micros.

     Ideas like the ones above aroused considerable interest at the meeting, 
and the Advanced Planning Special Interest Group was among the best attended. 
For further information, contact the chairperson, Randy Bush, at 503/572-
5391.  It is clear that one of the most important things we users can offer
SofTech is a coherent feedback mechanism with courage and clout; this was
already very much in evidence in San Diego.  Al Irvin of SofTech made an
impassioned plea that anyone who has developed new capabilities of the UCSD
system contact him for a mutually satisfying discussion concerning SofTech's
licensing the new development.

     I am chairperson of the software library, which will announce offerings 
in the newsletter and will sell disks in much the same way that I am now, 
except that there will be: a) multiple distribution centers, b) several 
software reviewers, each concentrating on a specific area, and c) the 
requirement that purchasers of the software either be members ($20 per year) 
or pay a $20 premium per order.  Only UCSD-compatible software will be
offered, and all policy is being set by a policy board of interested users. 
Realistically, we will not be shipping USUS software before 1 September. 
Because of my announcements of software available from me without such
restrictions, the group agreed that I should continue as before, although
eventually I will continue my operations through the USUS exclusively.

     Dr. Ken Bowles will be on sabbatical leave next year, and he is making no 
secret of his next project:  to get an Ada compiler going on the UCSD system 
(P-machine compatible only, I imagine).  Because it is no more expensive to 
have the more distant members of his group work at home and communicate via 
modem, he plans to implement a full-fledged Telenet host with a hard-disk-
based microcomputer.  Enough time will be left over on the system to devote
to an innovative project: interested users will be invited to subscribe to a
users' bulletin board and software supermarket, where users' group software
can be downloaded at cost and proprietary programs purchased, all via the
phone.  The bulletin board would include any comments on the proprietary
software users cared to leave, which should (with luck) stimulate the rapid
development of reliable, quality UCSD-compatible products.  Further, and more 
important, this concept will help overcome the insane proliferation of 
incompatible floppy disk formats.

     One interesting note: the Pascal Transfer Program from Vol. 2A has turned
out to be excellent, and has been selected for the "official" modem transfer
routine by the group, a step approved by its author, Mark Gang.  Thus we can
all talk with each other. The protocol used is the PCNET "standard" (Mark
indicated that not all aspects of the protocol had been formalized), so that
we can talk with non-UCSD processors as well.  The program lets you transfer
files to another user in both directions at once, while simultaneously
conversing on your terminals. The only problem is that program overhead is
high and the data rate low; you can expect about 16 char/sec if your line is
not too noisy.  Mark promised a new version, somewhat incompatible with the
old, that involves much more system handshaking to set modem speed and select
binary vs Radix-41 (PCNET standard) transmission.  We'll probably stick to the 
old version, since it should run on ANY UCSD system, even on personal 
computers.

     I also volunteered to be chairperson of the Medical Special Interest 
Group, and we dreamed up a project to adapt to the UCSD System whatever we 
could of the expanse of public-domain clinical applications software, 
developed under grant.  Contact Porter Welbourne, M.D., of Patient Care Data 
Systems, 418 North Main St., Penn Yan, NY 14527, who volunteered to head up
this effort.  In addition, we are looking for volunteers to transcribe the 
programs to UCSD-compatible floppies from 9-track tapes.

     Other special interest groups include the Newsletter (direct all articles 
to Keith Shillington, c/o SofTech Microsystems), European, Computer Aided 
Instruction, Standards, Word Processing, Real-Time Applications, Industrial, 
and Compatibility and Communications.

     To join the UCSD System User Society, send a self-addressed envelope to
Chip Chapin, Secretary, c/o SofTech Microsystems, 9494 Black Mountain Road,
San Diego CA 92126, or use the membership form I sent out with the disks.  The 
next general meeting will be in San Francisco (same time as another, general 
computer conference) on October 16 to 18, 1980.  Tentative cost is $25.


     Keep in touch.

     Jim Gagne.

========================================================================================
DOCUMENT :usus Folder:VOL04:volume.4.text
========================================================================================


                          DOCUMENTATION FOR THE FILES 
                   ON THE UCSD PASCAL USERS' LIBRARY VOLUME 4

1.  PROF. KEN BOWLES' DATABASE SEED

     The major portion of the disk is taken up by Prof. Ken Bowles' database
seed, which he donated to the users' library as a tutorial on how to build a
data structure with records of variable size. Originally, it functioned as the
starting point for student homework projects within a course at UCSD.  It is
not intended as a commercial product, nor as a foundation for one, and is
available to users explicitly for noncommercial purposes only.

     This is not a database system; rather, it is a collection of routines 
to represent and access data structured in various ways.  To get a real
database management system, you would have to add a means of logically
grouping and structuring your data, as well as a representation-independent
user interface.  Many of the required utilities are suggested in the
documentation as student projects.

     The file KB.DATABASE.DOC is taken from the handout given to the students. 
The handout also contained listings of the routines of the data system itself,
all of which are present on the disk in source form.  Program listing page
numbers referenced in the handout are not available, but program line numbers
are also given; you should be able to figure out which portions of the
programs are being referred to by Dr. Bowles.  Missing from the disk are three
figures diagramming the heirarchical nature of the data structure, showing
that fields and records can be declared recursively and referenced by links of
pointers, all within a fixed, 4-kilobyte frame.

     I have not personally tried out any of the routines, except to run the 
demo program DBDEMO.TEXT, which must be given the database name "TESTDB" when 
it asks for the name of the database file.  It is complex and fancy.  

     However, I found the comments within the handout illuminating, and I 
suspect that the many projects suggested by Prof. Bowles within the handout 
would make fascinating exercises for experienced programmers seeking to learn 
more about Pascal.  I doubt that the database holds more than an example of 
good programming for beginners, although if you're good at learning on your 
own and stick with it, you may get quite a bit out of it.

     Note that the screen control unit KB.SCUNIT.TEXT must be reconfigured
for your CRT terminal and then compiled before the rest of the programs will
work properly.  I have taken care of breaking up DBUNIT.TEXT into smaller 
chunks that will fit in memory for the E6 editor; remember to compensate for
the $I compiler directives when calculating line numbers on the listing.  I 
made no other changes.

     
2.  OTHER ITEMS ON THE DISK

     INDEX.TEXT is a greatly expanded index (by section, alas not by page) to 
Jensen and Wirth's PASCAL USER MANUAL AND REPORT.  It greatly aids looking up 
those syntactical queries.

     COMPARE.TEXT is from the Pascal User Group's PASCAL NEWS No. 12, pp. 20-
23, June, 1978, and was written by James F. Miner, who retains copyright but 
has released the program for non-profit use.  It does a very good job of 
comparing similar textfiles and pointing out differences.  Notably, it is good 
at discovering chunks of text that are present in one file but not in the 
other, and then discovering where the files are the same again.  The printout 
is pretty; the runtime is long.  It ran well on my system.  It is documented 
further within the source text.

     COMPRESS.TEXT was written and donated by Ted Beck.  It compresses spaces
at the beginning of a line of text (changing them to the UCSD blank
compression code, 16 [control P or DLE], followed by a byte representing the
number of spaces plus 31) and removes blanks at the end of each line.  It is
intended to shrink files transferred from other operating systems.  I found a
curious bug when I tried to compile Ted's original program: my 2.0 compiler
would die when it confronted a FILLCHAR, MOVELEFT, or MOVERIGHT intrinsic--
everything just stopped.  So I altered the program to use more standard Pascal
syntax, and it runs well.

     DISK_COPY.TEXT is Ted Beck's version of MAPPER, the routine available 
from Western Digital to translate the "standard" RT-11-like UCSD 8-inch disk 
format to that used by the Microengine.  Unlike other versions I have heard 
about, it will run ONLY on a Microengine, not on other systems (even if 
recompiled).  Since Microengine users can't read this disk without a 
functioning mapper program, the chief value of this program is that it is 
available in source form.  Because I don't have a Microengine, I have not 
tried out the program.

     USUS.NEWS.TEXT tells you all about the new UCSD System Users' Society.

     WUMPUS hardly needs documentation, and what is required is provided by 
the program.  I thought the author implemented it well.  I removed the
requirement for asynchronous i/o in order to initialize the random number
generator (which ran until a key was pressed), without apparant difficulty.

========================================================================================
DOCUMENT :usus Folder:VOL04:wump.cave0.text
========================================================================================

a Dodecahedron
02 05 08   01 03 10   02 04 12   03 05 14   01 04 06
05 07 15   06 08 17   01 07 09   08 10 18   02 09 11
10 12 19   03 11 13   12 14 20   04 13 15   06 14 16
15 17 20   07 16 18   09 17 19   11 18 20   13 16 19


========================================================================================
DOCUMENT :usus Folder:VOL04:wump.cave1.text
========================================================================================

a Mobius Strip
20 02 03   19 01 04   01 04 05   02 03 06   03 06 07
04 05 08   05 08 09   06 07 10   07 10 11   08 09 12
09 12 13   10 11 14   11 14 15   12 13 16   12 16 17
14 15 18   15 18 19   16 17 20   02 17 20   01 18 19

========================================================================================
DOCUMENT :usus Folder:VOL04:wump.cave2.text
========================================================================================

a String of Beads
02 03 20   01 03 04   01 02 04   02 03 05   04 06 07
05 07 08   05 06 08   06 07 09   08 10 11   09 11 12
09 10 12   10 11 13   12 14 15   13 15 16   13 14 16
14 15 17   16 18 19   17 19 20   17 18 20   01 18 19

========================================================================================
DOCUMENT :usus Folder:VOL04:wump.cave3.text
========================================================================================

a Toroidal Hex Net
19 02 03   20 01 04   01 08 05   02 19 06   03 06 07
04 05 08   05 12 09   06 03 10   07 10 11   08 09 12
09 16 13   10 07 14   11 14 15   12 13 16   13 20 17
14 11 18   15 18 19   16 17 20   17 04 01   18 15 02

========================================================================================
DOCUMENT :usus Folder:VOL04:wump.cave4.text
========================================================================================

a Dendrite with Degeneracies
01 01 05   02 02 05   03 03 06   04 04 06   01 02 07 
03 04 07   05 06 10   08 09 09   08 08 10   07 09 11
10 13 14   12 13 13   11 12 12   11 15 16   14 17 18
14 19 20   15 17 17   15 18 18   16 19 19   16 20 20

========================================================================================
DOCUMENT :usus Folder:VOL04:wump.cave5.text
========================================================================================

a One Way Lattice
02 16 17   03 17 18  04 18 19   05 19 20   01 20 16
07 01 02   08 02 03  09 03 04   10 04 05   06 05 01
12 06 07   13 07 08  14 08 09   15 09 10   11 10 06
17 11 12   18 12 13  19 13 14   20 14 15   16 15 11

========================================================================================
DOCUMENT :usus Folder:VOL04:wumpus.text
========================================================================================

program  wumpus;
 
{
        This program was written by Paul J. Gilliam from the basic
        programs "wumpus 1" and "wumpus 2" in "More BASIC Computer
        Games", edited by David H. Ahl.  The original games were
        written by Gregory Yob.  
        
        This game will teach you how to play it. 
        
        Happy wumpus hunting!
        
        (c) 1980 Palouse Software
        
        NOTICE:
        This program was the product of:
            
                     Palouse Software
                     P.O. Box 2202 
                     Pullman, WA 99163
                      
        Permission is hereby given to copy, modify, distribute, and in  
        any other way use this program, provided that this notice is not 
        removed from it.
         
}
  type    
    room = 1 .. 20;
    tunnel = 1 .. 3;
  
  var
    cave : array[room, tunnel] of room; 
    initlocate : array[1..6] of room;
    seed : integer;
    needhelp : boolean;
    i, j, arrowcount : integer;
  
  {*   
   *   The following strings can be used for control of the system console.
   *   The procedure  "terminit"  must be invoked before any of these are
   *   used.
   *} 
  cursorhome, cursorup, cursordown, cursorleft, cursorright,  
  clearscreen, clearline, beep  :  string[2];
  
  procedure  terminit;  
  {*
   *   This routine initializes the terminal control strings
   *}   
    
    var  
      esc : string[1];
    
    begin 
      {*  initialize for TVI-920c  *}
      esc         :=  ' ';  esc[1]  :=  chr(27);  
      cursorhome  :=  ' ';  cursorhome[1]  :=  chr(26);
      cursorup    :=  ' ';  cursorup[1]    :=  chr(23);;   
      cursordown  :=  ' ';  cursordown[1]  :=  chr(10);
      cursorleft  :=  ' ';  cursorleft[1]  :=  chr(8);
      cursorright :=  ' ';  cursorright[1] :=  chr(20);  
      clearscreen :=  ' ';  clearscreen[1] :=  chr(12);
      clearline   :=  ' ';  clearline[1] :=  chr(21);
      beep        :=  ' ';  beep[1]  :=  chr(7)
      end  { terminit };
   
FUNCTION  RANDOM (VAR SEED : INTEGER) : REAL;       
{*
 *   This is Algorithm A-1 from Pascal News #12
 *}

  CONST 
    PSHIFT  =  1024;    {  2 ^ 10  }
    PMOD    =    32;    {  2 ^ 5   }
    QSHIFT  =    16;    {  2 ^ 4   }
  
  VAR 
    A, B :
      RECORD  CASE BOOLEAN OF
        TRUE  : (I : INTEGER);
        FALSE : (S : PACKED SET OF 0..15);
      END;
  
  BEGIN
  
    { EXCLUSIVE OR NUMBER AND NUMBER SHIFTED 4 PLACES }  
    A.I := ABS(SEED);  B.I := A.I DIV QSHIFT;  { RIGHT SHIFT 4 }
    A.S := (A.S - B.S) + (B.S - A.S);  { XOR }
    
    { EXCLUSIVE OR NUMBER AND NUMBER SHIFTED 10 PLACES LEFT }
    B.I := A.I MOD PMOD * PSHIFT + A.I DIV PMOD;  { CIRCULAR LEFT SHIFT 10 } 
    A.S := (A.S - B.S) + (B.S - A.S);
    
    { CONVERT TO REAL RESULT }
    SEED := A.I;  RANDOM := A.I / (1.0 + MAXINT)
  END  { RANDOM };

function  randomize : char;   
  {*
   *   This routine will step thru random numbers until a key is pressed
   *   on the system console. 
   *}
   
{  The next version should work on your system, but I don't know.  }  
   
(* Paul Gilliam feels that this routine will work on most systems, but in
   fact only a few UCSD implementations support asynchronous i/o.  Apple
   users and others who have implemented KEYPRESS (a machine-language
   function true if a console key has been pressed) can use version B; on
   systems like mine, we'll have to make do with version C, which is the only
   one not commented out.
   By the way, if you use version A or B, you can initialize seed with a
   constant.                                            Jim Gagne       *)
(* VERSION A:  ORIGINAL:*)
(*var
    junk : real;
    ch : char;
    
  begin  { randomize } 
    unitread(1{console}, ch, 1,,1{asynch});
    while  unitbusy(1)  do  junk  :=  random(seed);
    randomize  :=  ch
    end  { randomize };
 *)
 
 (*VERSION B: USING KEYPRESS *)
 (* VAR
        junk: real;
        ch: char;
        
    BEGIN {randomize}
      WHILE NOT Keypress DO junk := random (seed);
      Read (ch);
      randomize := ch;
    END;
  *)
  
  (*VERSION C: SYNCHRONOUS *)
     VAR
        junk : real;
        ch: char;
    BEGIN
      junk := random (seed);
      Read (ch);
      randomize := ch;
    END;
 

  
  function  randroom : room; 
    begin
      randroom  :=  trunc(random(seed) * 20) + 1
      end  { randroom };
      
  function  randtunnel : tunnel;
    begin
      randtunnel  :=  trunc(random(seed) * 3) + 1
      end  { randtunnel };
      
  function  wumpmove : integer; 
    var
      i : integer;
    begin
      i  :=  trunc(random(seed) * 4) + 1;
      if  i > 3  then  wumpmove  :=  -1  else  wumpmove  :=  i;
      end  { wumpmove };
        
  function  instruct(filename : string) : boolean;       
  {*
   *   This function uses the input from a file to teach the player
   *   how to play the game.  When the string "$pause" starts in the
   *   first position of a line in the file,  'instruct' will pause in
   *   its listing of the file until the player hits the space bar.
   *}
    
    var    
      line : string;  
      ifile : text;
      ch : char;
    
    begin  { instruct }  
      gotoxy(0,0);
      write(clearline);
      write('Do you want instructions on how to play? ');
      ch  :=  randomize;
      writeln;
      instruct  :=  false; 
      if  (ch <> 'y')  and  (ch <> 'Y')  then  exit(instruct);  
      {$I- }  { turn off i/o checking } 
      reset(ifile,filename);
      {$I+ }  { turn on i/o checking }
      if  ioresult <> 0  then  begin
        writeln;
        writeln('Sorry,  instructions not availiable yet.');
        exit(instruct)  end;
      instruct  :=  true;  
      gotoxy(0,1);
      write(clearscreen);
      while  not eof(ifile)  do  begin; 
        readln(ifile,line);
        if  (line = '$pause')  or  (line = '$PAUSE')  then  begin    
          gotoxy(0,0);
          write(clearline);
          write('Hit <sp> to continue.'); 
          repeat read(keyboard,ch) until ch = ' ';
          gotoxy(0,23);
          writeln  end
        else
          writeln(line)  end;
      end  { instruct };
    
  procedure  getacave;
    var
      i : room;
      j : tunnel;
      k : integer;
      cavename : string; 
      cavein : text;
      ch : char;
    begin 
      cavename  :=  'wump.cave'; 
      k := length(cavename) + 1;
      cavename  :=  concat(cavename, '$', '.text');
      writeln; 
      repeat  
        write('cave #(0-5) '); 
        read(ch);
        writeln;
        until  ch in ['0'..'5'];
      cavename[k]  :=  ch;   
      reset(cavein,cavename);    
      writeln('reading ',cavename,' '); 
      readln(cavein, cavename); 
      write('.');
      for  i := 1 to 20  do  begin
        write('.');
        for  j := 1 to 3  do  read(cavein,cave[i,j])  end;   
      writeln;
      writeln('you are in ',cavename);
      writeln;
      end  { getacave }; 
  
  procedure  initsetup; 
    var
      locatesunique : boolean;
      i, j : integer;  
    begin
      repeat
        for  i := 1 to 6  do  initlocate[i]  :=  randroom;  
        locatesunique  :=  true;
        i  :=  1;              
        while  locatesunique  and  (i <= 6)  do  begin 
          j  :=  1;  
          while  locatesunique  and  (j <= 6)  do  begin
            if  (initlocate[i] = initlocate[j])  and  (j <> i) then  begin    
              locatesunique  :=  false  end
            else  begin 
              j  :=  j + 1  end
            end;
          i  :=  i + 1  end;
        until  locatesunique; 
      end  { initsetup }; 
      
  procedure  HuntTheWumpus;
    type
      long = integer[35];
    var 
      i : integer;
      game : (inprogress, youlost, youwon);
      locate : array[1..6] of room;
      escape : char;
    
    procedure  warnings;  
      var
        location, i, j: integer;
      begin
        writeln;
        location := locate[1];   
        for  i := 2 to 6  do  begin
          for  j := 1 to 3  do  begin
            if  cave[location,j] = locate[i]  then  begin
              case  i  of
                2   :  writeln('I smell a Wumpus!');
                3, 4:  writeln('I feel a draft!');
                5, 6:  writeln('Bats nearby!');
                end
              end
            end
          end;
        writeln('You are in Room ',location:2);
        write('Tunnels lead to');
        for  i := 1 to 3  do  write(cave[location,i]:3); 
        writeln;
        end  { warnings };
    
    function  wanttoshoot : boolean;   
      var
        ch : char;      
      begin
        repeat
          write('Shoot or move (s-m) <esc>');     
          read(keyboard,ch);
          writeln;
          if  ch = escape  then  begin   
           game  :=  youlost;
           exit(HuntTheWumpus)  end;
          if  ch = 'l'  then  begin  
            write('you = ',locate[1]);
            write(' wumpus = ',locate[2]);
            write(' pits = ',locate[3],',',locate[4]);
            write(' bats = ',locate[5],',',locate[6]);
            writeln  end;
          until  ch in ['m', 'M', 's', 'S'];   
        wanttoshoot  :=  ch in ['S', 's'];
        end  { wanttoshoot }; 
    
    procedure  movewumpus; 
      var
        i : integer;
      begin
        i  :=  wumpmove;
        if  i > 0  then  locate[2]  :=  cave[locate[2],i];
        if  locate[1] = locate[2]  then  begin      
          writeln('Tsk Tsk Tsk - Wumpus got you!');
          game  :=  youlost  end;
        end  { movewumpus };
    
    function  lint(s : string; var l : long) : integer;  
      var
        i, j : integer;
        negitive : boolean;
        ch : char;
      begin 
        j  :=  0;
        l  :=  0;
        lint  :=  -1;
        negitive  :=  false;
        for  i := 1 to length(s)  do  begin 
          ch  :=  s[i];
          if  ch in ['0'..'9']  then  begin
            j  :=  j + 1;
            if  j > 36  then  begin
              lint  :=  -2;
              exit(lint)  end;
            l  :=  l * 10 + (ord(ch) - ord('0'))  end 
          else if  ch = '-'  then  begin
            if  negitive  then  exit(lint)  end
          else  exit(lint);
          end;
        if  l > maxint   
          then  lint  :=  j
          else  lint  :=  0;
        if  negitive  then  l  :=  -l;
        end;
    
    procedure  doshot;
      var
        path : array[1..5] of integer;
        rooms, i, j, arrow : integer;
        roomok, targethit : boolean;
        l : long;
        ans : string;
      begin
        { program the arrow }
        repeat
          write('No. of rooms (1-5) ');
          readln(ans);   
          i  :=  lint(ans, l);
          rooms  :=  trunc(l);
          until  (i = 0) and (rooms >= 1) and (rooms <= 5);              
        for  i := 1 to rooms  do begin
          repeat
            roomok := true;
            write('Room # ');
            readln(ans);  
            j  :=  lint(ans, l);
            roomok  :=  (j = 0) and  (l > 0)  and  (l < 21);
            path[i]  :=  trunc(l);
            if  i > 2  then  begin   
              if  path[i] = path[i-2]  then  begin
                writeln('Arrows aren''t that crooked - try another room');
                roomok  :=  false  end
              end;
            if  not roomok  then  write(beep);  
            until  roomok;
          end;
        { shoot the arrow }
        arrowcount  :=  arrowcount - 1;
        I  :=  1;
        arrow  :=  locate[1];
        repeat 
          roomok  :=  false; 
          for  j := 1 to 3  do  begin
            if  cave[arrow,j] = path[i]  then  roomok  :=  true  end;
          if  roomok  then  begin
            arrow  :=  path[i]  end
          else  begin 
            arrow  :=  randroom  end;    
          if  arrow = locate[1]  then  begin    
            writeln('OUCH! Arrow got YOU!');
            game  :=  youlost  end 
          else  if  arrow = locate[2]  then  begin 
            writeln('Aha! You got the Wumpus!'); 
            game  :=  youwon  end;
          i  :=  i + 1;
          until  (i > rooms) or (game <> inprogress);
        if  (game = inprogress) and (arrowcount = 0)  then  begin
          writeln('Out of arrows!!'); 
          game  :=  youlost  end;
        if  game = inprogress  then  writeln('missed'); 
        movewumpus;
        end  { doshot };
    
    procedure  domove; 
      var
        room, i, location : integer;
        roomok, movefinished : boolean;
        l : long;
        ans : string;            
      begin
        location  :=  locate[1];
        repeat
          write('Where to? '); 
          readln(ans); 
          roomok  :=  false;
          i  :=  lint(ans, l);
          room  :=  trunc(l);
          if  i = 0  then  begin
            for  i := 1 to 3  do  begin   
              if  room = cave[location,i]  then  roomok  :=  true  end;
            if  room = location  then  roomok  :=  true  end; 
          if  not roomok  then  begin
            writeln('Not possible')  end
          until  roomok;
        location  :=  room;
        repeat  
          locate[1]  :=  location;
          movefinished  :=  true; 
          if  location = locate[2]  then  begin
            writeln('... OOPS!  Bumped a Wumpus');
            movewumpus  end;
          if  game = inprogress  then  begin
            if  (location = locate[3]) or (location = locate[4])  then  begin
              writeln('YYYIIEEEE . . . Fell in a pit!');
              game  :=  youlost  end
            else if (location = locate[5]) or (location = locate[6]) then begin
              writeln('ZAP -- Super bat snatch! Elsewhereville for you!'); 
              movefinished  :=  false;
              location  :=  randroom  end
            end
          until  movefinished;
        end  { do move }; 
    
    begin { huntthewumpus } 
      escape  :=  chr(27);
      arrowcount  :=  5; 
      for  i := 1 to 6  do  locate[i]  :=  initlocate[i];       
      game  :=  inprogress;
      writeln;
      writeln('Hunt the Wumpus'); 
      writeln;
      while  game = inprogress  do  begin 
        warnings;
        if  wanttoshoot  then  doshot  else  domove;
        end;
      if  game = youwon  then
        writeln('Hee Hee Hee - The Wumpus''ll getcha next time.')
        else
        writeln('Ha Ha Ha - You lose!');
      end  { huntthewumpus };
      
  function  newsetup : boolean; 
    var
      ch : char;
    begin
      writeln;
      repeat 
        write('Same set-up (y-n) ');
        read(ch);
        writeln;
        until  ch in ['y', 'Y', 'n', 'N'];
      newsetup  :=  ch in ['n', 'N'];
      end  { newsetup };
  
  function  newcave : boolean;
    var
      ch : char;
    begin
      writeln;
      repeat
        write('Same cave (y-n) '); 
        read(ch);
        writeln
        until  ch in ['y', 'Y', 'n', 'N'];
      newcave  :=  ch in ['n', 'N'];
      end  { newcave };
       
  function  alldone : boolean; 
    var
      ch : char;
    begin
      writeln;
      repeat 
        write('Play again (y-n) ');
        read(keyboard,ch);
        writeln;
        until  ch in ['y', 'Y', 'n', 'N'];
      alldone  :=  ch in ['n', 'N'];
      end  { alldone };
      
  begin  
    Write ('Type a four-digit number -->  ');
    Readln (seed); 
    terminit; 
    needhelp  :=  instruct('teach.wumpus'); 
    repeat
      getacave;
      repeat 
        initsetup;
        repeat
          huntthewumpus;
          until  newsetup
        until  newcave
      until  alldone
    end  { wumpus }.

========================================================================================
DOCUMENT :usus Folder:VOL05:addrs.doc.text
========================================================================================


                           Monaco's Address Programs
                                  Version 2.0



     These address programs (STRUCT, UPDATE AND GETSORT) are designed to
manage a database of up to 1000 records consisting of "arbitrary records". An
"arbitrary" record is simply defined as five strings of text, each string up
to 80 characters long, and the fifth string being the "key" by which the
records are sorted and accessed. The routines will build the database, allow
dynamic updates, and sort the entire database for a printable output file. The
selected application presented here is for maintaining an address file, but
the source can be easily changed to reflect any application. 

     Use "STRUCT" to convert a standard ascii file (built in the editor called
#5:adds.text) to the diskfile #5:address.text. The file #5:adds.text must look
like this: 

                                    Nameline
                                   Streetline
                                CitystateZipline
                                   Phoneline
                                    Keyline
                                 Nextnameline 
                                     etc...

     Note that no blank intervening lines are permitted, and that no
completely blank fields are allowed.  Also, the keyline should contain the
collating sequence key you want the record accessed by (keys must be, on the
whole, unique). Use #5:update.code to update/modify or print mailing labels
from the database, and use #5:getsort.code to build a sorted, full copy of
#5:address.text called #5:printf.text. You can spool #5:printf.text; do not
attempt to use #5:address.text for anything (editor, line printer, etc) as it
is a structured file! 
         
     HINTS: you only have to use #5:struct.code once; #5:update.code and
#5:getsort.code do everything for you automatically once you have the
structured file #5:address.text.  Both #5:update.code and #5:getsort.code will
build files of keys (these will magically appear on #5:); do not mess with
these phantom files! The user should only ensure that a few free blocks appear
right after #5:address.text to allow dynamic file increase. 

     The user should modify the global variables for terminal control in
#5:update.text (since I built it for a Hazeltine 1510); see the main program
for documentation for what the global terminal variables handle. 

     When #5:update.code prompts for a key, the first record in address.text
having the string typed after the prompt will be retrieved; the entire key
need not be typed! Also, if the key is not found, update will prompt for
another try. Update understands "stop" and "print" as reserved keys with
obvious meanings. 

     Last, when adding new records with new keys, bracket the key field with
"*" as "*keyfield*". Notice that character cases are important in keys! The
user will find the program #5:getsort.text extremely instructional in tech-
niques of sorting large files with little memory... 

                      
     Please address comments to:
                      
                            Cpt Francis J. Monaco
                 Department of Geography and Computer Science
                      The United States Military Academy
                          West Point, New York 10996

========================================================================================
DOCUMENT :usus Folder:VOL05:catalog.5.text
========================================================================================


                                VOLUME 5 CATALOG
                           UCSD PASCAL USERS' LIBRARY
  Many software tools written by Frank Monaco and me, plus a few odds and ends

ADDRS.DOC.TEXT    10    Doc for STRUCT, UPDATE, and GETSORT address database.
CRTINPUT.TEXT     20    A tuned-up string, boolean & textfile input package.
DIR.TEXT          16    See the directory, double-column & alphabetized, with
                          file date & size, plus a list of unused areas.
DISKREAD.TEXT     26    Similar to UCSD's PATCH, lets you alter disks directly.
FMT.1.5.CODE      27    Frank's text formatter program -- tell him how you
FMT.2.0.CODE      26      like it -- code for UCSD versions I.5 & 2.0.
FMT.EXAMP.TEXT    16    Sample text for FMT - "before" version of READ.DISKR.
GETNUMBER.TEXT    30    Fancy, sophisticated integer & decimal input routines.
GETSORT.TEXT      12    Part of the mailing list "database" system.
HEXDECOCT.TEXT    18    Convert integers any way you want: HEX, DECimal, OCTal.
ID2ID.TEXT        36    From the PASCAL NEWS No. 15, converted by Frank.  Lets
                          you change one or more identifiers in Pascal source
                          to others of your choice.
MAKEMASKS.TEXT    18    Allows you to edit SUPER CRT masks, put them on disk.
MONACO.DOC.TEXT   14    Documentation for some of the files on this disk.
PEEK.POKE.TEXT     8    Thought you couldn't PEEK or POKE?  Shows you how.
QUICKSORT.TEXT     4    Example of fast disk sorting algorithm.
READ.DISKR.TEXT   24    Documentation for DISKREAD and example of FMT at work.
READ.FMT.TEXT     82    Documentation for FMT.x.x.CODE and example of output.
SCREENCNTL.TEXT    4    Example of SEPARATE UNITS, with some nice routines.
SOFT.TOOLS.DOC    18    Doc for CRTINPUT, GETNUMBER, MAKEMASKS, & SCREENCNTL.
SP.TEXT           14    Allows your line printer to follow FORTRAN conventions.
STRUCT.TEXT        8    Part of the mailing address "database" system.
UNIT.GOOD.TEXT    22    Should be called WONDERSTUFF; solves those nagging
                          terminal dependencies for good, plus allows you to
                          read the directory from any disk, get date, etc.
UPDATE.TEXT       22    Part of the mailing address "database" system.

NOTE:  The UCSD Pascal Users' Library material may be used only in accordance
with policy outlined elsewhere.  No commercial use may be made of these routines
without the written permission of the authors.

========================================================================================
DOCUMENT :usus Folder:VOL05:crtinput.text
========================================================================================

UNIT CRTINPUT;

{Special procedures for controlled CRT input of string, textfile,
 and boolean variables.
 
 COPYRIGHT (c) 1980, James Gagne, President
                     DATAMED RESEARCH
                     1433 Roscomare Road
                     Los Angeles, CA 90024
                     213/472-8825
 ALL RIGHTS RESERVED.  These routines may be used for nonprofit, non-
 commercial purposes only, unless written consent of the author is obtained.}
 
INTERFACE
    
    TYPE
      FileAction = (GetOld, Create) {equivalent to Reset/Rewrite};
      FNameString = string [30];
      chset = set OF char;

    
    PROCEDURE AllCaps (VAR s:string);
        {convert string to all capital letters}
    
    FUNCTION GetLetter (y: integer; s: string; cset: chset): char;
        {  Writes S at line Y; reads w/o echo, converting alpha to upper case,
         until char is in CSET, then returns this char after erasing line Y.
         The cursor is not moved if Y < 0 or > 23.}
    
    PROCEDURE GetString (MaxLength: integer; VAR Typed: string);
        {See description in IMPLEMENTATION section.}
    
    FUNCTION OpenTextFile 
       (Prompt: string       {your request for the filename}; 
    VAR FileName: FNameString{filename string};
        Action: FileAction   {"GetOld" or "Create"};
        Startline: integer   {linenumber on which to start dialogue}; 
    VAR F: text              {file to be opened})
     : boolean               {true = file opened; false = user aborted};
    
    PROCEDURE GetBoolean (x, y: integer;  VAR DesiredValue: boolean);
    
    
IMPLEMENTATION

  CONST 
     {ASCII characters}
        etx = 3;
        bel = 7;
        bs = 8;
        htab = 9;
        esc = 27;
        del = 127;
        
        RCurs = 18      {Control R ==> move cursor right};
        ErrorLine = 23  {last line on screen is for error messages};
        
  VAR
       Response, ch, EscapeCh: char;
    
        
PROCEDURE GoAndClearLine (y: integer); EXTERNAL;

FUNCTION Yes (prompt: string) : boolean; EXTERNAL;

PROCEDURE OptionalGotoxy (x,y: integer);
{Leave the cursor where it is if x or y is < 0}
BEGIN
  IF (x >= 0) AND (y >= 0) THEN Gotoxy (x,y);
END;


PROCEDURE AllCaps  {(VAR s:string)};
VAR i, LittletoBig : integer;
BEGIN
  LittletoBig := ORD ('A') - ORD ('a');
  FOR i := 1 TO Length (s) DO
    IF s[i] IN ['a'..'z'] THEN s[i] := CHR (Ord (s[i]) + LittletoBig);
END;


FUNCTION GetLetter {(y: integer; s: string; cset: chset): char};
VAR ch: char;

BEGIN
  IF (y>=0) AND (y<24) THEN GoAndClearLine(y);
  Write(s);
  REPEAT
    Read(keyboard, ch);
    IF (ch IN ['a'..'z']) THEN ch := CHR( ORD(ch) + ORD('A') - ORD('a') )
  UNTIL ch IN cset;
  IF (y >= 0) AND (y < 24) THEN GoAndClearLine (y) ELSE writeln(ch);
  GetLetter := ch
END;


{GETSTRING does the following:
  This routine first types the original string (Typed), followed by dots to the 
maximum string length.  If any char is typed but ETX or ESCAPE, the original 
string is replaced by a row of dots to the maximum length of the string as 
passed by the calling routine.  GetString then reads characters 
until terminated by a typed return or escape or at the point that the string 
is filled by the maximum allowed characters.  Typing a control R at any point
will fill that character with one from the original string; a horizontal tab
will either fill in text, or add spaces, depending on whether the end of the
original string has been reached.  If at any time escape is typed, the original 
string (TYPED) is restored and the procedure terminated.  Otherwise, either a 
return or a full string are taken as end-of-string.  Backspace and Delete work 
per the usual UCSD standard.}

PROCEDURE GetString {(MaxLength: integer; VAR Typed: string[255])};
CONST MaxString = 250;
      FillChar = '.';
VAR j, k, MaxL, StringLength: integer;
    ReadCh: boolean;
    HTabCh, backsp, DeleteCh: char;
    Newstring: String[MaxString];
    Didtype: PACKED ARRAY [1..MaxString] OF char;
    
BEGIN
  IF MaxLength > MaxString THEN MaxL := MaxString ELSE MaxL := MaxLength;
  IF MaxLength = 0
    THEN BEGIN
      Typed := '';
      Exit (GetString);
    END;
  backsp := CHR (bs);
  HTabCh := CHR (Htab);
  EscapeCh := CHR (esc);
  DeleteCh := CHR (del);
  REPEAT        {loop repeated only if DELETE typed}
    StringLength := LENGTH (typed);
    IF StringLength > MaxL
      THEN BEGIN
        Delete (Typed, MaxL+1, StringLength-MaxL);
        StringLength := LENGTH (typed);
      END;
    Write (typed);
    FOR j := StringLength+1 TO maxlength DO Write (FillChar);
    FOR j := 1 TO Maxlength DO write (backsp);
    Read (Keyboard, ch);
    IF ch = EscapeCh
      THEN BEGIN
        Write (typed, ' ': MaxL - StringLength);
        EXIT (GetString)
      END
      ELSE BEGIN
        IF ch = CHR (etx)
          THEN ReadCh := true
          ELSE BEGIN   {If the 1st char <> control C,}
            ReadCh := false; {then erase original string.  }
            FOR j := 1 TO StringLength DO Write (FillChar);
            FOR j := 1 TO StringLength DO Write (backsp);
          END;
        j := 1;
        REPEAT
          IF ReadCh THEN Read (keyboard, ch);
          ReadCh := true;
          IF (ch = CHR (RCurs)) AND (j <= StringLength)
            THEN BEGIN  {The Right-cursor character will keep one     }
              ch := Typed [j];  {character at a time from the original string.}
              Write (ch);
              Didtype[j] := ch;
              j := j + 1
            END
          ELSE IF (ch >= ' ') AND (ch < DeleteCh)
            THEN BEGIN
              Write (ch);
              Didtype[j] := ch;
              j := j + 1
            END
          ELSE IF ch = HTabCh
            THEN REPEAT
              IF j <= StringLength THEN ch := Typed [j] ELSE ch := ' ';
              Write (ch);
              Didtype [j] := ch;
              j := j + 1
            UNTIL (j MOD 8 = 1) OR (j > MaxL)
          ELSE IF (ch = backsp) AND (j > 1) 
            THEN BEGIN
              Write (backsp, FillChar, backsp);
              j := j - 1;
            END
        UNTIL (j > MaxL) OR (ch IN [EscapeCh, DeleteCh]) OR EOLN (keyboard);
        k := j - 1;
        IF EOLN (keyboard) AND (k = 1) THEN k := 0;
        FOR j := 1 TO k DO Write (backsp);
      END
  UNTIL ch < DeleteCh;
  IF ch <> EscapeCh
    THEN BEGIN
      NewString := '';
      FOR j := 1 TO k DO 
        BEGIN
          NewString := CONCAT (NewString, ' ');
          NewString [j] := Didtype [j]
        END;
      Typed := NewString
    END;                {else typed is left alone}
  Write (typed, ' ':(maxlength - Length (typed)));
END (*GetString*);


PROCEDURE WriteErr (Message: string);
BEGIN
  Gotoxy (0, ErrorLine);
  Write (CHR (bel), '-** ERROR **-  ', Message, 
         '.  Tap <spacebar> to continue...');
  REPEAT Read (keyboard, ch) UNTIL ch = ' ';
  GoAndClearLine (ErrorLine)
END;


{OPENTEXTFILE will open a textfile, prompting at lines STARTLINE to STARTLINE+3
 --except for the error message, which is always at the bottom of the screen.  
 It returns the filename and the opened file.  ".TEXT" is added to any filename 
 that needs it.  It returns false if the user quit.}
 
FUNCTION OpenTextFile {(Prompt: string; 
                     VAR FileName: FNameString;
                         Action: FileAction;
                         Startline: integer; 
                     VAR F: text) : boolean};

VAR gotfn: boolean;
    Typed: string [255];
  
BEGIN
  REPEAT
    GoAndClearLine (StartLine);
    GoAndClearLine (StartLine+1);
    GoAndClearLine (StartLine+2);
    GoAndClearLine (StartLine+3);
    Gotoxy (5,StartLine);
    Write (Prompt);
    Gotoxy (15,StartLine+1);
    Write ('-->      ');
    Gotoxy (8,StartLine+2);
    Write ('  (Or just press the <return> key if you wish to quit.)');
    Typed := '';
    Gotoxy (20, StartLine+1);
    GetString (23, Typed);
    IF (typed = ' ') OR (typed = '')
      THEN BEGIN
        GoAndClearLine (StartLine+3);
        Gotoxy (11,StartLine+3);
        IF Yes ('Would you prefer to skip this file')
          THEN BEGIN
            OpenTextFile := false;
            EXIT (OpenTextFile);
          END;
        GoAndClearLine (StartLine+3);
      END
      ELSE BEGIN
        FileName := Typed;
        AllCaps (FileName);
        (*$I-*)
        IF Action = getold
          THEN BEGIN
            Reset (F, typed);
            IF IORESULT > 0 THEN Reset (F, CONCAT (typed, '.TEXT'))
          END
          ELSE BEGIN
            IF (POS ('.TEXT', typed) = 0)
              THEN typed := CONCAT (typed, '.TEXT');
            Rewrite (F, typed);
          END;
        (*$I+*)
        Gotfn := IORESULT = 0;
        IF NOT Gotfn
          THEN CASE IORESULT OF
            1, 4:  WriteErr ('Please check your disk--hardware problem');
            2:     WriteErr ('Unit number is incorrect');
            5, 9:  WriteErr ('Unit or Volume is off line at present');
            6, 10: WriteErr ('Can''t find this file on this disk');
            7:     WriteErr ('Illegal file name...probably too long');
            8:     WriteErr ('No room on this disk for this file');
          END;
      END(*else*)
  UNTIL Gotfn;
  OpenTextFile := true
END;
  

{GETBOOLEAN is a routine to read in a boolean variable; gotoxy
 is optional as before.  If you don't want GOTOXY, consider also
 'YES' from SCREENCONTROL.}
 
PROCEDURE GetBoolean {(x, y: integer; VAR DesiredValue:  boolean)};
VAR ch: char;
    DontGotoxy: boolean;

BEGIN
  DontGotoxy := (x<0) OR (y<0);
  Escapech := CHR (esc);
  IF NOT DontGotoxy
    THEN BEGIN
      GoAndClearLine (22);
      Write ('  Type "Y" for yes, or "N" for no.');
      Gotoxy (x,y);
    END;
  REPEAT Read (keyboard, ch) 
  UNTIL (ch IN ['Y', 'y', 'T', 't', 'N', 'n', 'F', 'f', EscapeCh]);
  CASE ch OF
    'Y', 'y', 'T', 't': BEGIN
                          Write ('YES');
                          DesiredValue := true
                        END;
    'N', 'n', 'F', 'f': BEGIN
                          Write (' no');
                          DesiredValue := false
                        END
  END;
  IF NOT DontGotoxy THEN GoAndClearLine (22)
END;


END.

========================================================================================
DOCUMENT :usus Folder:VOL05:dir.text
========================================================================================

PROGRAM   DIR;

{ This program was originally written by Frank Monaco, I believe, and appears
  in its original form as part of UNIT.GOOD.  I've been hankering after a
  decent directory lister for a while; so I took over and basically rewrote
  the program, though chunks of Frank's code are scattered here and there.
  Now I like it.  You may feel the screen is too cluttered and want to remove
  the last column of the directory list, the first block no., but I find this
  useful.  
  
  Meagre attempts were made to format the display properly for terminals with 
  less than 80-column lines, though you will have to pay attention to that if 
  you have a narrow screen.  It should work OK for terminals of any number of
  lines if you correct the constant LastLine.  The constant UserPicksUnit gives
  you the option (at compile time) to fix the unit # of the directory to be
  displayed, or to ask for it at run time.
  
  This program is for NONcommercial use only, without written permission from
  the authors.  Jim Gagne, Datamed Research, 1433 Roscomare Road, Los Angeles,
  California 90024.}
  
CONST
        ScreenWidth = 80;
        LastLine = 23;          {last line no. on screen, starting from line 0.}
        MaxDirEnt   = 77;
        Testing = true; 
        UserPicksUnit = true;   
{if false, name the program by the unit number and just type, for example, 
 "X)ecute 4" to see the directory of Unit 4}
        
        FixedUnitNum = 4;
{used only if UserPicksUnit = false; choose whichever unit you want to display}

TYPE 

     DATEREC = PACKED RECORD
                        MONTH: 0..12;
                        DAY: 0..31;
                        YEAR: 0..100
               END;

     DIRRANGE = 0..MaxDirEnt;

     VID = STRING[7];
     TID = STRING[15];
     FILEKIND = (UNTYPED,XDISK,CODE,TEXT,
                 INFO,DATA,GRAF,FOTO,SECUREDIR);

     DIRENTRY = RECORD
                  DFIRSTBLK: INTEGER;
                  DLASTBLK: INTEGER;
                  CASE DFKIND:FILEKIND OF
                    SECUREDIR,UNTYPED: 
                                       (DVID:VID;
                                        DEOVBLK,
                                        DLOADTIME,
                                        DBLOCKS:INTEGER;
                                        DLASTBOOT:DATEREC);
                    XDISK,CODE,TEXT,INFO,DATA,
                    GRAF,FOTO: 
                               (DTID:TID;
                                DLASTBYTE:1..512;
                                DACCESS:DATEREC)
                END;

     DIRP = ^DIRECTORY;
     DIRECTORY = ARRAY[DIRRANGE] OF DIRENTRY;


VAR 

    UNITNUM, I, J, RoomLeft, TotlBlocks, SCount, FCount,
      DirLinesThatFit: INTEGER;
    CHBUF : char;
    IdxArry: ARRAY [DIRRANGE] OF Integer;
    BUFR: PACKED ARRAY[0..2048] OF CHAR;
    DIRX: DIRECTORY;


PROCEDURE AlphabetizeDirectory;
VAR i, j, k, temp: integer;
    Done: boolean;

BEGIN
  Write (i, j);         {I don't know why I need this statement, but without
                         it I get a value range error, because the assignment
                         statements for i & j do not appear to execute.}
  i := 1;
  j := Dirx[0].DLOADTIME;
  REPEAT
    IF Length (DIRX[i].DTID) > 0
      THEN IdxArry[i] := i
      ELSE IdxArry[i] := 0;
    i := i + 1
  UNTIL i > j;
  FOR i := 2 TO DIRX[0].DLOADTIME DO IF IdxArry[i] > 0
    THEN BEGIN
      j := i;
      k := j;
      REPEAT k := k - 1 UNTIL (IdxArry [k] > 0) OR (k = 0);
      Done := false;
      REPEAT IF (k > 0) AND (j > 1) 
        THEN IF (DIRX [IdxArry [j]].DTID < DIRX [IdxArry [k]].DTID) 
          THEN BEGIN
            temp := IdxArry[k];
            IdxArry[k] := IdxArry[j];
            IdxArry[j] := temp;
            j := j - 1;
            k := j;
            REPEAT k := k-1 UNTIL (IdxArry[k] > 0) OR (k = 0);
          END
          ELSE Done := true
        ELSE Done := true
      UNTIL Done;
    END {then};
END {AlphabetizeDirectory};


PROCEDURE WriteDate (Date: DateRec);
BEGIN
  WITH Date DO
    BEGIN
      WRITE(DAY:3,'-');
      CASE MONTH OF
        1: WRITE('Jan');
        2: WRITE('Feb');
        3: WRITE('Mar');
        4: WRITE('Apr');
        5: WRITE('May');
        6: WRITE('Jun');
        7: WRITE('Jul');
        8: WRITE('Aug');
        9: WRITE('Sep');
        10: WRITE('Oct');
        11: WRITE('Nov');
        12: WRITE('Dec');
      END {case};
      WRITE('-',YEAR:2);
    END {with};
END;


PROCEDURE ListUnusedBlocks;
VAR i, j, Next: integer;

BEGIN
  i := 1;
  WHILE (Length (DIRX[0].DTID) = 0) AND (i < TotlBlocks) DO i := i + 1;
  Next := DIRX[i].DLASTBLK;
  Write ('Unused blocks = ');
  FOR i := i + 1 TO DIRX[0].DLOADTIME DO WITH DIRX[i] DO
    IF Length (DTID) > 0
      THEN BEGIN
        IF DFIRSTBLK > Next
          THEN Write (Next, '-', DFIRSTBLK - 1, '=', DFIRSTBLK - Next, ', ');
        Next := DLASTBLK;
      END;
  IF Next < TotlBlocks
    THEN Write (Next, '-', TotlBlocks - 1, '=', TotlBlocks - Next)
END;
  

BEGIN
IF UserPicksUnit
  THEN BEGIN
   {note: extend the prompt if you really do have units 9 & 10 on line}
     WRITE ('Enter the unit number (4 or 5) for the directory you wish --> ');
     REPEAT Read (keyboard, chbuf) UNTIL (chbuf IN ['4', '5', '9', '1']);
     Unitnum := ORD (chbuf) - ORD ('0');
     IF Unitnum = 1 then Unitnum := 10;
     Writeln (Unitnum);
  END
  ELSE Unitnum := FixedUnitNum;
  {$I-}
  UNITREAD(UNITNUM,DIRX[0],2048,2);
  {$I+}
  IF IORESULT <> 0
    THEN
      BEGIN
        WRITELN('Unit No. ', Unitnum, 'is not on line.');
        EXIT(DIR);
      END;
  AlphabetizeDirectory;
  Gotoxy (0,LastLine);
  Writeln; Writeln; Writeln; {clear screen}
  Gotoxy ((ScreenWidth - 44) DIV 2, 1);
  WITH DIRX[0] DO 
    BEGIN
      WRITELN ('Directory of Unit #', Unitnum, ' -**- Volume ', DVID,':');
      RoomLeft := DBLOCKS;
      TotlBlocks := DBLOCKS;
    END;
  I := 1;
  WHILE (Length (DIRX[I].DTID) = 0) AND (I < DIRX[0].DLOADTIME) DO I := I + 1;
  RoomLeft := RoomLeft - DIRX[I].DFIRSTBLOCK;
  SCount := 0;
  FCount := 0;
  DirLinesThatFit := LastLine - 4;
  FOR I:=1 TO DIRX[0].DLOADTIME DO
    BEGIN
      IF IdxArry[I] > 0 THEN WITH DIRX[IdxArry[I]] DO
        BEGIN
          Gotoxy 
      ((SCount DIV DirLinesThatFit) * 40, (SCount MOD DirLinesThatFit) + 3);
          SCount := SCount + 1;
          J := DLASTBLK-DFIRSTBLK;
          WRITE(DTID,' ':16-LENGTH(DTID), J: 3, ' ');
          RoomLeft := RoomLeft - J;
          WriteDate ( DACCESS );
          Write (DFIRSTBLK:5);
        END {then};
     if SCount mod (DirLinesThatFit * 2) = 0
       then begin
         gotoxy ((ScreenWidth - 32) DIV 2, LastLine);
         write ('tap <space bar> to continue ');
         SCount := 0;
         FCount := FCount + (DirLinesThatFit * 2);
         repeat
           read ( chbuf )
         until chbuf = ' ';
       end;
    END {for};
  Gotoxy ((ScreenWidth - 52) DIV 2, LastLine-1);
  SCount := SCount + FCount;
  Write (SCount);
  IF SCount = 1 THEN Write (' file; ') ELSE Write (' files; '); 
  Writeln (TotlBlocks - RoomLeft, ' blocks used, ', 
    RoomLeft, ' remaining, ', TotlBlocks, ' total.');
  ListUnusedBlocks;
END.




========================================================================================
DOCUMENT :usus Folder:VOL05:diskread.text
========================================================================================


PROGRAM DISKREAD;

(*$I-,R-*)
(*$C DISKREAD BY ROGER L. SOLES - GEORGIA INSTITUTE OF TECHNOLOGY *)

CONST 

      STATUS = 2;
      PROMPT = 4;
      MAXBLOCKS = 493; (* NUMBER OF BLOCKS ON DISK *)

TYPE 
     CRTCOMMAND = (ERASEOS,ERASEOL,UP,DOWN,RIGHT,LEFT,LEADIN);

VAR 
    MODE: (ASCII, HEX);
    ST: STRING;
    CH,BELL: CHAR;
    UNITNUM,BLOCKNUM: INTEGER;
    I,J,K: INTEGER;
    BUF: PACKED ARRAY [0..511] OF 0..255;
    CRTINFO:   PACKED ARRAY[CRTCOMMAND] OF CHAR;
    PREFIXED:  ARRAY[CRTCOMMAND] OF BOOLEAN;

PROCEDURE GETCRTINFO;

(* READ SYSTEM.MISCINFO AND GET CRT CONTROL CHARACTER INFO *)

VAR 

    BUFFER: PACKED ARRAY[0..511] OF CHAR;
    BYTE: INTEGER;
    F: FILE;

BEGIN
  RESET(F,'*SYSTEM.MISCINFO');
  I := BLOCKREAD(F,BUFFER,1);
  CLOSE(F);
  BYTE := ORD(BUFFER[72]);       (* PREFIX INFORMATION BYTE *)
  CRTINFO[LEADIN] := BUFFER[62];
  PREFIXED[LEADIN] := FALSE;
  CRTINFO[ERASEOS] := BUFFER[64];
  PREFIXED[ERASEOS] := ODD(BYTE DIV 8);
  CRTINFO[ERASEOL] := BUFFER[65];
  PREFIXED[ERASEOL] := ODD(BYTE DIV 4);
  CRTINFO[RIGHT] := BUFFER[66];
  PREFIXED[RIGHT] := ODD(BYTE DIV 2);
  CRTINFO[UP] := BUFFER[67];
  PREFIXED[UP] := ODD(BYTE);
  CRTINFO[LEFT] := BUFFER[68];
  PREFIXED[LEFT] := ODD(BYTE DIV 32);
  CRTINFO[DOWN] := CHR(10);
  PREFIXED[DOWN] := FALSE;
END; (* GETCRTINFO *)

PROCEDURE CRT(C: CRTCOMMAND);

(* CRT COMMANDS ARE: ERASEOS,ERASEOL,UP,DOWN,RIGHT,LEFT *)

BEGIN
  IF PREFIXED[C]
    THEN
      UNITWRITE(1,CRTINFO[LEADIN],1,0,12);
  UNITWRITE(1,CRTINFO[C],1,0,12);
END; (* CRT *)

PROCEDURE PRINTBYTE(BYTE: INTEGER);

(* PRINT A BYTE AS A HEXSTRING *)

BEGIN
  IF BYTE > 255
    THEN
      BEGIN
        PRINTBYTE(BYTE DIV 256);
        PRINTBYTE(BYTE MOD 256);
      END
    ELSE
      BEGIN
        IF (BYTE DIV 16) IN [0..9]
          THEN
            WRITE(CHR((BYTE DIV 16) + ORD('0')))
          ELSE
            WRITE(CHR((BYTE DIV 16) - 10 + ORD('A')));
        IF (BYTE MOD 16) IN [0..9]
          THEN
            WRITE(CHR((BYTE MOD 16) + ORD('0')))
          ELSE
            WRITE(CHR((BYTE MOD 16) - 10 + ORD('A')));
      END;
END; (* PRINTBYTE *)

FUNCTION CVI(ASCII:STRING): INTEGER;

(* CONVERT AN INPUT STRING, EITHER DECIMAL OR HEX, TO AN INTEGER *)

VAR 
    BASE,MPY,X,RV: INTEGER;

BEGIN
  BASE := 10;
  IF POS('$',ASCII) <> 0
    THEN
      BASE := 16;
  MPY := 1;
  RV := 0;
  FOR X:=LENGTH(ASCII) DOWNTO 1 DO
    CASE BASE OF
      10 : BEGIN
             IF ASCII[X] IN ['0'..'9']
               THEN
                 BEGIN
                   RV := RV+(MPY*(ORD(ASCII[X])-ORD('0')));
                   MPY := MPY*10;
                 END;
           END;
      16 : BEGIN
             IF ASCII[X] IN ['0'..'9']
               THEN
                 BEGIN
                   RV := RV+(MPY*(ORD(ASCII[X])-ORD('0')));
                   MPY := MPY*16;
                 END;
             IF ASCII[X] IN ['A'..'F']
               THEN
                 BEGIN
                   RV := RV+(MPY*(ORD(ASCII[X])-ORD('A')+10));
                   MPY := MPY*16;
                 END;
             IF ASCII[X] IN ['a'..'f']
               THEN
                 BEGIN
                   RV := RV+(MPY*(ORD(ASCII[X])-ORD('a')+10));
                   MPY := MPY*16;
                 END;
           END;
    END; (* CASE OF *)
  CVI := RV;
END; (* CVI *)

PROCEDURE BASECALC (VAR X,Y,BYTE: INTEGER);

(* CALCULATE THE SCREEN BASE ADDRESS FOR ANY BYTE OF THE BUFFER *)

VAR 
    TEMP: INTEGER;

BEGIN
  Y := (BYTE DIV 32) + 7;
  TEMP := (BYTE MOD 32) DIV 8;
  CASE TEMP OF
    0: X := (BYTE MOD 8) * 2 + 6;
    1: X := (BYTE MOD 8) * 2 + 25;
    2: X := (BYTE MOD 8) * 2 + 44;
    3: X := (BYTE MOD 8) * 2 + 63;
  END; (* CASE OF *)
END; (* BASECALC *)

PROCEDURE DISHEX;

(* DISPLAY THE BUFFER IN HEX *)

VAR 
    X,Y,I: INTEGER;

BEGIN
  I := 0;
  REPEAT
    BASECALC(X,Y,I);
    GOTOXY(X,Y);
    FOR J:=0 TO 7 DO
      PRINTBYTE(BUF[I+J]);
    I := I+8;
  UNTIL I >= 511;
END; (* DISHEX *)

PROCEDURE DISASCII;

(* DISPLAY THE BUFFER IN ASCII - ONLY VALID ASCII CODES ARE DISPLAYED *)

VAR 
    CH: CHAR;
    X,Y,I: INTEGER;

BEGIN
  I := 0;
  REPEAT
    BASECALC(X,Y,I);
    GOTOXY(X,Y);
    FOR J:=0 TO 7 DO
      BEGIN
        CH := CHR(BUF[I+J]);
        IF NOT( CH IN [' '..'}'])
          THEN
            CH := ' ';
        WRITE(CH:2);
      END;
    I := I+8;
  UNTIL I >= 511;
END; (* DISASCII *)

PROCEDURE DISBLOCK;

(* DISPLAY CURRENT BLOCK NUMBER IN DECIMAL AND HEX *)

BEGIN
  GOTOXY(8,STATUS);
  WRITE(BLOCKNUM:3,'  $');
  PRINTBYTE(BLOCKNUM DIV 256);
  PRINTBYTE(BLOCKNUM MOD 256);
END; (* DISBLOCK *)

PROCEDURE DISUNIT;

(* DISPLAY CURRENT UNIT NUMBER IN DECIMAL AND HEX *)

BEGIN
  GOTOXY(71,STATUS);
  WRITE(UNITNUM:2,'  $');
  PRINTBYTE(UNITNUM);
END; (* DISUNIT *)

PROCEDURE DISMODE;

(* DISPLAY CURRENT DISPLAY MODE *)

BEGIN
  GOTOXY(37,STATUS);
  CASE MODE OF
    ASCII: WRITE('ASCII');
    HEX:   WRITE(' HEX ');
  END; (* CASE OF *)
END; (* DISMODE *)

PROCEDURE DISPLAY(I: INTEGER);

(* DISPLAY A BYTE IN THE BUFFER IN THE CURRENT DISPLAY MODE *)

VAR 
    X,Y: INTEGER;

BEGIN
  BASECALC(X,Y,I);
  GOTOXY(X,Y);
  CASE MODE OF
    ASCII: BEGIN
             CH := CHR(BUF[I]);
             IF NOT(CH IN [' '..'}'])
               THEN
                 CH := ' ';
             WRITE(CH:2);
           END;
    HEX  : PRINTBYTE(BUF[I]);
  END; (* CASE OF *)
END; (* DISPLAY *)

PROCEDURE CHANGE;

(* CHANGE VALUE OF A BYTE IN THE BUFFER - INPUT HEX OR DECIMAL *)

VAR 
    DONE: BOOLEAN;

BEGIN
  WRITE('ADDRESS: ');
  READLN(ST);
  I := CVI(ST);
  DONE := FALSE;
  REPEAT
    GOTOXY(0,PROMPT);
    CRT(ERASEOL);
    WRITE('(');
    PRINTBYTE(I);
    WRITE(') = ');
    PRINTBYTE(BUF[I]);
    WRITE(': ');
    READLN(ST);
    IF LENGTH(ST) = 0
      THEN
        DONE := TRUE
      ELSE
        BEGIN
          K := CVI(ST) MOD 256;
          BUF[I] := K;
          DISPLAY(I);
        END;
    I := I+1;
    IF I > 511
      THEN
        DONE := TRUE;
  UNTIL DONE;
END; (* CHANGE *)

PROCEDURE STRINGCHANGE;

(* CHANGE BYTES IN THE BUFFER - INPUT ASCII STRING *)

BEGIN
  WRITE('ADDRESS: ');
  READLN(ST);
  I := CVI(ST) MOD 512;
  GOTOXY(0,PROMPT);
  CRT(ERASEOL);
  WRITE('(');
  PRINTBYTE(I);
  WRITE('): ');
  READLN(ST);
  IF LENGTH(ST) <> 0
    THEN
      FOR J:=0 TO LENGTH(ST)-1 DO
        BEGIN
          K := I+J;
          BUF[K] := ORD(ST[J+1]);
          DISPLAY(K);
        END;
END; (* STRINGCHANGE *)

PROCEDURE MEMORYUPDATE;

(* CHANGE A BLOCK OF VALUES IN THE BUFFER - INPUT HEX OR DECIMAL *)

VAR 
    VALUE: INTEGER;

BEGIN
  WRITE('STARTING ADDRESS: ');
  READLN(ST);
  I := CVI(ST) MOD 512;
  GOTOXY(0,PROMPT);
  CRT(ERASEOL);
  WRITE('ENDING ADDRESS: ');
  READLN(ST);
  J := CVI(ST) MOD 512;
  IF I > J
    THEN
      EXIT(MEMORYUPDATE);
  GOTOXY(0,PROMPT);
  CRT(ERASEOL);
  WRITE('BYTE: ');
  READLN(ST);
  VALUE := CVI(ST) MOD 256;
  FOR K:=I TO J DO
    BEGIN
      BUF[K] := VALUE;
      DISPLAY(K);
    END;
END; (* MEMORYUPDATE *)

PROCEDURE INIT;

(* INITIALIZE THE SCREEN, THIS NEED NO BE DONE AGAIN! *)

BEGIN
  BELL := CHR(7);
  BLOCKNUM := 0;
  UNITNUM := 4;
  MODE := HEX;
  GOTOXY(0,0);
  CRT(ERASEOS);
  WRITELN('Roger L. Soles Disk Block Read/Write/Modify':61);
  GOTOXY(0,STATUS);
  WRITE('BLOCK:');
  GOTOXY(64,STATUS);
  WRITE('UNIT:');
  GOTOXY( 5,5);
  WRITE('00');
  GOTOXY(21,5);
  WRITE('07');
  GOTOXY(24,5);
  WRITE('08');
  GOTOXY(40,5);
  WRITE('0F');
  GOTOXY(43,5);
  WRITE('10');
  GOTOXY(59,5);
  WRITE('17');
  GOTOXY(62,5);
  WRITE('18');
  GOTOXY(78,5);
  WRITE('1F');
  GOTOXY(5,6);
  FOR I:=5 TO 80 DO
    WRITE('_');
  FOR I:=0 TO 15 DO
    BEGIN
      GOTOXY(0,I+7);
      PRINTBYTE(I*2);
      WRITE('0 |');
    END;
  DISBLOCK;
  DISUNIT;
  DISMODE;
  FOR I:=0 TO 511 DO
    BUF[I] := 0;
END; (* INIT *)

PROCEDURE COMMAND;

(* GET AND PROCESS A COMMAND - ADD MORE HERE *)

VAR 
    DONE: BOOLEAN;

BEGIN

  DONE := FALSE;

  REPEAT

    GOTOXY(0,PROMPT);
    CRT(ERASEOL);
    READ(CH);
    CRT(LEFT);
    CASE CH OF
      'A','a' :  BEGIN (* DISPLAY BUFFER IN ASCII *)
                   IF MODE <> ASCII
                     THEN
                       BEGIN
                         MODE := ASCII;
                         DISMODE;
                         DISASCII;
                       END;
                END;
      'H','h' :  BEGIN (* DISPLAY BUFFER IN HEX *)
                   IF MODE <> HEX
                     THEN
                       BEGIN
                         MODE := HEX;
                         DISMODE;
                         DISHEX;
                       END;
                END;
      'R','r' :  BEGIN (* READ CURRENT UNIT/BLOCK *)
                   UNITREAD(UNITNUM,BUF,512,BLOCKNUM);
                   IF IORESULT = 0
                     THEN
                       BEGIN
                         CASE MODE OF
                           ASCII: DISASCII; (* DISPLAY ASCII *)
                           HEX:   DISHEX; (* DISPLAY HEX *)
                         END; (* CASE OF *)
                       END
                     ELSE
                       BEGIN
                         GOTOXY(0,PROMPT);
                         CRT(ERASEOL);
                         WRITE(BELL,'I/O ERROR: Please check unit status');
                         READLN;
                       END;
                END;
      'W','w' :  BEGIN (* WRITE CURRENT UNIT/BLOCK *)
                   WRITE('Update disk block ? ');
                   READ(CH);
                   IF CH IN ['Y','y']
                     THEN
                       BEGIN
                         UNITWRITE(UNITNUM,BUF,512,BLOCKNUM);
                         IF IORESULT <> 0
                           THEN
                             BEGIN
                               GOTOXY(0,PROMPT);
                               CRT(ERASEOL);
                               WRITE(BELL,'I/O ERROR: Please check unit status'
                               );
                               READLN;
                             END;
                       END;
                END;
      ';','+' :  BEGIN (* INCREASE BLOCK *)
                   BLOCKNUM := BLOCKNUM + 1;
                   IF BLOCKNUM > MAXBLOCKS
                     THEN
                       BLOCKNUM := 0;
                   DISBLOCK;
                END;
      '=','-' :  BEGIN (* DECREASE BLOCK *)
                   BLOCKNUM := BLOCKNUM - 1;
                   IF BLOCKNUM < 0
                     THEN
                       BLOCKNUM := MAXBLOCKS;
                   DISBLOCK;
                END;
      'B','b' :  BEGIN (* SET BLOCK NUMBER *)
                   WRITE('BLOCK: ');
                   READLN(ST);
                   BLOCKNUM := CVI(ST);
                   IF BLOCKNUM > MAXBLOCKS
                     THEN
                       BLOCKNUM := MAXBLOCKS;
                   IF BLOCKNUM < 0
                     THEN
                       BLOCKNUM := 0;
                   DISBLOCK;
                END;
      'U','u' :  BEGIN (* SET UNIT NUMBER *)
                   WRITE('UNIT: ');
                   READLN(ST);
                   UNITNUM := CVI(ST);
                   IF NOT(UNITNUM IN [4,5,9..12])
                     THEN
                       UNITNUM := 4;
                   DISUNIT;
                END;
      'C','c' :  CHANGE; (* BLOCK CHANGE *)
      'S','s' :  STRINGCHANGE; (* STRING CHANGE *)
      'M','m' :  MEMORYUPDATE; (* MEMORY UPDATE *)
      'Q','q' :  BEGIN (* QUIT PROGRAM *)
                   GOTOXY(0,0);
                   CRT(ERASEOS);
                   DONE := TRUE;
                END;
    END; (* CASE OF *)

  UNTIL DONE;

END; (* COMMAND *)

BEGIN (* MAIN PROGRAM *)

  GETCRTINFO;
  INIT;
  COMMAND;

END.

========================================================================================
DOCUMENT :usus Folder:VOL05:fmt.1.5.code
========================================================================================

< binary file -- not listed >
                                                                                                                      O  ^                                                                                                                                                                                                                                                                                                                                                                                                 
========================================================================================
DOCUMENT :usus Folder:VOL05:fmt.2.0.code
========================================================================================

< binary file -- not listed >
  
========================================================================================
DOCUMENT :usus Folder:VOL05:fmt.examp.text
========================================================================================

.lpt
.sp+ 25
.tl Disk Block Read/Write/Modify
.sp+ 2
.tl by
.sp+ 2
.tl Roger L. Soles
.sp+ 2
.tl Georgia Institute of Technology
.tl Box 36177
.tl Atlanta, GA  30332
.pg
.pn 1
.he 'Diskread'  '  ^ '
.fo ' ' - # - ' '
.pp
Disk Block Read/Write/Modify (afterwards referred to
as "DISKREAD") is a system utility program designed to allow
the knowledgable user a means through which he can read
information from disk, modify that information, and place
it back onto the disk.  It's primary design purpose is to
allow the user to make quick disk patches, either in his
system files, or any other file. (Basically, a very smart 
DUMP facility with dynamic disk and RAM  updating capability! - F. Monaco).
.sp+ 2
.tl WARNING!  
.pp
This program can totaly obliterate the information on
the disk (and RAM), and therefore it must be considered as dangerous
to the unfamiliar user - please acquaint yourself with
it's operation before proceeding to utilize it.
.pp
The screen consists of several distinct fields:
.pp
1)  The upper part of the screen will have a field 
indicating the current block number and the current unit 
(or volume) number in both decimal and hex, as a rule 
quantities that "DISKREAD" displays will always be in hex.
Between these is an indicator, either HEX or ASCII, this 
refers to the mode in which the data from the disk block is 
to be displayed.
.pp
2)  A command prompt line:  all commands 
and user input quantities will be entered here. When the cursor 
is here, "DISKREAD" is waiting for a user input.
.pp
3)  The disk block buffer area.  This area is bounded 
by a row and a column of numbers, the actual address of any 
byte in the buffer is the logical sum of the two 
quantities, and thus a little knowledge about hexidecimal 
addition is needed to utilize the displayed information 
efficiently.  The contents of the buffer are displayed in 
the current mode. In ASCII mode, only legal ASCII 
characters are displayed; that is ' '..'}'; all other ASCII 
codes are displayed as blanks.
.pp
The commands of "DISKREAD" are:
.sp+ 2
.tl 1) Set ASCII display mode : 'a'
.pp
This command will immediately display the contents of 
the disk block buffer in ASCII and set the mode indicator 
to show this.
.sp+ 2
.tl 2)  Set HEXIDECIMAL display mode : 'h'
.pp
This command will immediately display the contents of 
the disk block buffer in hex and set the mode indicator to 
show this.
.sp+ 2
.tl  3)  READ a disk block : 'r'
.pp
This command will cause "DISKREAD" to read in the disk 
block specified by the current blocknumber from the volume 
specified in the current unitnumber.  If the I/O process is 
not complete, "DISKREAD" alerts the user and displays an 
error message, hit RETURN to continue.
.sp+ 2
.tl 4)  WRITE the buffer to disk : 'w'
.pp
This command will cause "DISKREAD" to write out the 
contents of the buffer to the block specified by the 
current block number on the volume specified by the current 
unit number.  Before the process is completed, verification 
from the user is requested, typing anything except 'y' or 
'Y' will abort the process.
.sp+ 2
.tl WARNING!  
.pp
This is the only dangerous command in "DISKREAD", once
a buffer has been written to disk, the information that
was prevously in the block on the disk is lost!
.pp
If the I/O process is not complete, "DISKREAD" alerts 
the user and displays an error message, hit RETURN to 
continue.
.sp+ 2
.tl 5) INCREMENT disk block number : '+'
.pp
This command will increment the current blocknumber by 
one each time it is pressed.  If the blocknumber exceeds 
the MAXBLOCKS on the disk, the number wraps around to zero. 
For convenience the ';' may also be used so that the user 
does not have to hit the shift key.
.sp+ 2
.tl 6) DECREMENT disk block number : '-'
.pp
This command will decrement the current blocknumber by 
one each time it is pressed. If the blocknumber goes below 
zero, then number wraps around to the MAXBLOCKS.  For 
convenience, if the keyboard is shift locked, the '=' may 
also be used.
.sp+ 2
.tl 7) Set the BLOCK NUMBER : 'b'
.pp
This command allows the user to enter the absolute 
block address directly in either hexidecimal or decimal, 
default is decimal, but a '$' anywhere in the input field 
will cause the number to be processed as a hex number (this 
is true of all numeric input). Special Note: users with 
mini-floppies or hard disks will have to change the constant in the 
beginning of "DISKREAD" to reflect the correct number of blocks!
.sp+ 2
.tl 8) Set the UNIT NUMBER : 'u'
.pp
This command allows the user to enter the volume 
number on which further operations are to take place, if 
the number entered is not a vailide block device then the 
default value of four is substituted - no error message is 
given!
.sp+ 2
.tl 9) CHANGE buffer byte by byte : 'c'
.pp
This command allows the user to change the buffer 
contents byte by byte.  The user is first ask for a 
starting address at which the changes are to begin, then he 
enter each change.  The displayed numbers are the current 
address, and the value of the buffer at that address.  To 
terminate the change mode, simply type return with no other 
entry.
.sp+ 2
.tl 10) STRING CHANGES : 's'
.pp
This command allows the user to chage the buffer 
contents to values which are equivalent to an input string.
The user is ask to supply a starting address for the string 
and the string, the change takes up as many bytes as are 
needed for the string, trailing blanks are significant!
.sp+ 2
.tl 11) MEMORY UPDATE : 'm'
.pp
This command allows the user to change large amounts 
of the buffer with a single command.  The starting address, 
the ending address, and the value to update the buffer to 
must be supplied when requested, if the starting address is 
larger than the ending addres the proccess is aborted.
.sp+ 2
.tl 12) QUIT : 'q'
.pp
This command terminates "DISKREAD", the buffer is not 
saved automatically!
.sp+ 2
.tl Some General Suggestions
.pp
Numeric inputs may 
be either hex or decimal, generally error messages are not 
given, "DISKREAD" assumes the user is very familar with this 
program, and that he simply made a typing error, any 
quantity may be corrected before the return key is hit by 
simply back spacing, and either upper of lower case 
characters can be used for commands and hex digits.
.sp+ 2
.ne 10
.ce Please send comments and suggestions to:
.sp+ 2
.ce Roger L. Soles
.ce Georgia Institute of Technology
.ce Atlanta, GA  30332
.sp+ 2
.sp+ 2
.tl NOTICE:
.sp+ 2
.pp
This program is for free distribution ONLY, and the
copyright notice and author name may not be removed!


 

========================================================================================
DOCUMENT :usus Folder:VOL05:getnumber.text
========================================================================================

UNIT GetNumber;

{Special procedures for controlled CRT input of integers in three flavors.
 
 COPYRIGHT (c) 1980, James Gagne, President
                     DATAMED RESEARCH
                     1433 Roscomare Road
                     Los Angeles, CA 90024
                     213/472-8825
 ALL RIGHTS RESERVED.  These routines may be used for nonprofit, non-
 commercial purposes only, unless written consent of the author is obtained.}
 

INTERFACE

  CONST                 {The first 4 are standard ASCII control characters.}
        bell = 7;
        backspace = 8;
        escape = 27;
        delete = 127;
        ErrorLine = 23   {Standard line on the CRT for error messages};

  PROCEDURE GetInteger 
          (x, y,        {desired x/y displacements for START of integer}
                        {If either x or y is < 0, no X-Y movement done.}
           LowerLimit, UpperLimit: integer; {bounds of WantedNo values }
                        {If LowerLimit > UpperLimit, then LowerLimit is}
                        { taken as the WIDTH of the field, and limits are}
                        { calculated by width alone within the procedure.}
           RJustify: boolean;         {do you want it justified R or L?}
           VAR WantedNo: integer);    {the number returned: unchanged if}
                        {<ESC> typed during entry.                      }
  
  PROCEDURE GetDecimal 
          (x, y,                      {same as GetInteger}
           LowerLimit, UpperLimit,    {same as GetInteger; work on WHOLE no. }
           MaxPlaces: integer;        {boundary for decimal = max # of places}
           VAR WholePart, FractnPart: integer);         {returned values; 
                       the fractional value is NORMALIZED to the no. of places,
                       i.e., it = number of 1/(10 EXP MaxPlaces)}


IMPLEMENTATION

PROCEDURE GoAndClearLine (y: integer);  EXTERNAL;


PROCEDURE QuietRead (VAR ch: char);
{this is implemented separately in case you wish to modify it.}
BEGIN
  Read (keyboard, ch)
END;


FUNCTION LengthOf (int: integer): integer;
VAR i, j:integer;
BEGIN
  j := int;
  IF j < 0
    THEN BEGIN
      i := 1 (*leave room for "-" sign*);
      j := -j
    END
    ELSE i := 0;
  REPEAT 
    i := i + 1;  
    j := j DIV 10;
  UNTIL j = 0;
  LengthOf := i
END;


FUNCTION FigureWidth (x, y: integer): integer;
{returns the number of characters of whichever integer is larger}
VAR i, j: integer;
BEGIN
  i := LengthOf (x);
  j := LengthOf (y);
  IF j > i THEN FigureWidth := j ELSE FigureWidth := i;
END;


PROCEDURE BackUp (distance: integer);
VAR i: integer; bs: char;
BEGIN
  bs := CHR (backspace);
  FOR i := 1 TO distance DO Write (bs, ' ', bs)
END;


PROCEDURE GetSpace (XYEnabled: boolean);
{for getting attention and then cleaning up the error message}
VAR ch: char;
BEGIN
  Write (CHR (Bell), '.  Type <space> to continue...');
  REPEAT Read (ch) UNTIL ch = ' ';
  IF XYEnabled THEN GoAndClearLine (errorline) ELSE Writeln;
END;


FUNCTION IntInProgress (VAR LastCh: char; VAR wanted: integer): boolean;
{This function reads a character quietly, accepting only appropriate ones,
 updates LASTCH (last char typed) and the integer WANTED appropriately, and
 returns an approximate boolean value of whether we're done.  Used by all
 input routines.}
VAR ch: char;
    ValidChar: boolean;
    
BEGIN
  ValidChar := false;
  REPEAT QuietRead (ch)
  UNTIL (ch IN ['0'..'9', ' ', '+', '-', '.', CHR (delete), CHR (backspace),
                CHR (escape)]);
  IF (ch IN ['0'..'9']) AND (ABS (wanted) < MAXINT DIV 10)
    THEN BEGIN
      IF wanted >= 0
        THEN Wanted := wanted * 10 + ORD (ch) - ORD ('0')
        ELSE Wanted := wanted * 10 - ORD (ch) + ORD ('0');
      ValidChar := true;
    END
  ELSE IF ch = CHR (backspace)
    THEN BEGIN
      IF Wanted < 0
        THEN Wanted := -( (-wanted) DIV 10)
        ELSE Wanted := wanted DIV 10;
      ValidChar := true
    END
  ELSE IF ch = CHR (delete)
    THEN BEGIN
      Wanted := 0;
      ValidChar := true
    END
  ELSE IF ch = '+'
    THEN BEGIN
      IF wanted < 0 THEN wanted := - wanted;
      ValidChar := true
    END
  ELSE IF ch = '-'
    THEN BEGIN
      IF wanted > 0 THEN wanted := - wanted;
      ValidChar := true
    END;
  LastCh := ch;
  IntInProgress := ValidChar
END;


PROCEDURE WriteRFlushInteger (int, width: integer; LastChWasMinus: boolean);
VAR i:integer;
BEGIN
  FOR i := LengthOf (int) TO width - 1 DO Write ('.');
  IF int = 0 
    THEN IF LastChWasMinus THEN Write ('-') ELSE Write ('.')
    ELSE Write (int);
END;


PROCEDURE WriteLFlushInteger (int, width: integer; LastChWasMinus: boolean);
VAR i, j, k: integer;
BEGIN
  j := width - LengthOf (int);
  k := j;
  IF int = 0
    THEN IF LastChWasMinus 
      THEN Write ('-')
      ELSE BEGIN
        k := k + 1;
        Write ('.')
      END
    ELSE Write (int);
  FOR i := 1 TO j DO Write ('.');
  FOR i := 1 TO k DO Write (CHR (backspace));
END;


FUNCTION ValidInteger (LowerLimit, UpperLimit, width: integer;
                         RJustify: boolean;
                     VAR LastChTyped: char; VAR Wanted: integer): boolean;

{Get an integer, justifying the number appropriately as you do so.  Quit if 
 escape or carriage return or period or space typed or the number is as large as
 it can get within the limits.  Return a boolean variable attesting to the
 validity of the number.}
                        
VAR PrevLength: integer;
    Done, UnderTopLimit, NumberWasWritten, StillShort, 
      WriteAMinus, NegativeOnly, PositiveOnly: boolean;

BEGIN
  IF (Wanted < LowerLimit) OR (Wanted > UpperLimit) THEN Wanted := 0;
  NumberWasWritten := Wanted <> 0;
  PrevLength := LengthOf (Wanted);
  IF RJustify
    THEN WriteRFlushInteger (Wanted, width, false)
    ELSE WriteLFlushInteger (Wanted, width, false);
  Done := false;
  StillShort := true;
  UnderTopLimit := true;
  WriteAMinus := false;
  NegativeOnly := UpperLimit <= 0;
  PositiveOnly := LowerLimit >= 0;
  WHILE UnderTopLimit AND StillShort AND NOT Done DO
    IF IntInProgress (LastChTyped, Wanted) 
      THEN BEGIN
        IF PositiveOnly AND (Wanted < 0) THEN Wanted := -Wanted;
        IF NegativeOnly AND (Wanted > 0) THEN Wanted := -Wanted;
        UnderTopLimit := Wanted <= UpperLimit;
        IF UnderTopLimit
          THEN BEGIN
            IF RJustify
              THEN BackUp (width)
              ELSE IF NumberWasWritten THEN Backup (PrevLength);
            WriteAMinus := (LastChTyped = '-') AND NOT PositiveOnly;
            IF RJustify 
              THEN WriteRFlushInteger (Wanted, width, WriteAMinus)
              ELSE WriteLFlushInteger (Wanted, width, WriteAMinus);
            NumberWasWritten := (Wanted <> 0) OR WriteAMinus;
            PrevLength := LengthOf (Wanted);
            StillShort := (PrevLength < width) AND (UpperLimit >= Wanted * 10)
          END;
      END
      ELSE Done := true;
  ValidInteger := (LastChTyped IN [' ', '.', '0'..'9']) 
    AND (Wanted >= LowerLimit) AND UnderTopLimit
END;


PROCEDURE GetInteger {(x, y, LowerLimit, UpperLimit: integer;
                      RJustify: boolean; VAR WantedNo: integer)};
{Main procedure that is used; X & y refer to the START of the field.  Field 
 size is inferred from the maximum number of digits in the two limits.  Plus 
 or minus signs typed at any time invert the sign if appropriate.  An escape 
 typed any time before auto-termination (by a number approaching UpperLimit) 
 will restore the original value of WantedNo.  Nice number movement.}
 
VAR TempInt, width, WorkingUpperLimit, WorkingLowerLimit, i, j: integer;
    XYEnabled, OK, Abort: boolean;
    Lastch: char;
    s: string;
BEGIN
  IF LowerLimit > UpperLimit
    THEN BEGIN
      width := LowerLimit MOD 20     {just in case, reasonable limit on width};
      i := 1;
      FOR j := 1 TO width DO i := i * 10;
      WorkingUpperLimit := i - 1;
      WorkingLowerLimit := (i DIV 10) -1;       {room for "-" sign}
    END
    ELSE BEGIN
      WorkingUpperLimit := UpperLimit;
      WorkingLowerLimit := LowerLimit;
      width := FigureWidth (UpperLimit, LowerLimit)
    END;
  XYEnabled := (X>=0) AND (Y>=0);
  REPEAT
    IF XYEnabled THEN Gotoxy (x,y);
    OK := ValidInteger 
    (WorkingLowerLimit, WorkingUpperLimit, width, RJustify, Lastch, TempInt);
    IF OK
      THEN WantedNo := TempInt
      ELSE IF Lastch = CHR (escape) THEN Abort := true
      ELSE IF TempInt > WorkingUpperLimit
        THEN BEGIN
          IF XYEnabled THEN Gotoxy (0, errorline) ELSE Writeln;
          Write ('Please type a number less than ', WorkingUpperLimit + 1);
          GetSpace (XYEnabled);
          TempInt := WorkingUpperLimit
        END
      ELSE IF TempInt < WorkingLowerLimit
        THEN BEGIN
          IF XYEnabled THEN Gotoxy (0, errorline) ELSE Writeln;
          Write ('Please type a number greater than ', WorkingLowerLimit - 1);
          GetSpace (XYEnabled);
          TempInt := WorkingLowerLimit
        END
  UNTIL OK OR Abort;
  IF RJustify THEN i := width ELSE i := LengthOf (TempInt);
  IF XYEnabled THEN Gotoxy (x,y) ELSE Backup (i);
  IF RJustify
    THEN Write (WantedNo: width)
    ELSE Write (WantedNo)
END;


PROCEDURE WriteAFraction (fractn, decplaces, maxplaces: integer;
                includedots: boolean);
VAR i, j, LeadingZeros: integer;

BEGIN
  i := LengthOf (fractn);
  IF fractn = 0 THEN i := 0;
  LeadingZeros := DecPlaces - i;
  FOR j := 1 TO LeadingZeros DO Write ('0');
  IF fractn > 0 THEN Write (fractn);
  IF IncludeDots
    THEN BEGIN
      i := maxplaces - decplaces;
      FOR j := 1 TO i DO Write ('.');
      FOR j := 1 TO i DO Write (CHR(backspace));
    END;
END;
  
  
FUNCTION GetValidFraction (Wholepart, MaxPlaces: integer; 
         VAR LastChTyped: char; VAR fractn: integer): boolean;
{Workhorse decimal fraction-getter; difficult because leading zeros are much
 more significant than trailing ones, which I allowed anyway because people
 like to type them.}
 
VAR dummy, DumpFractn: boolean; 
    i, j, DecPlaces: integer;

BEGIN
  IF fractn < 0 THEN fractn := - fractn;
  DecPlaces := MaxPlaces;
  IF fractn = 0 
    THEN DecPlaces := 0
    ELSE WHILE (fractn MOD 10 = 0) DO
      BEGIN
        fractn := fractn DIV 10;
        DecPlaces := DecPlaces - 1
      END;
  IF LengthOf (fractn) > MaxPlaces
    THEN BEGIN
      fractn := 0;
      DecPlaces := 0;
    END;
  WriteAFraction (fractn, DecPlaces, MaxPlaces, true);
  REPEAT
    dummy := IntInProgress (LastChTyped, fractn);
    IF fractn < 0 THEN fractn := -fractn;
    DumpFractn := (LastChTyped IN [CHR (delete), CHR (escape)]) 
        OR ((LastChTyped = '+') AND (WholePart < 0))
        OR ((LastChTyped = '-') AND (WholePart > 0));
    Backup (DecPlaces);
    IF (LastChTyped = CHR (backspace)) AND (DecPlaces > 0)
      THEN DecPlaces := DecPlaces -1;
    IF (DecPlaces >= MaxPlaces) AND (fractn = 0) 
      THEN DecPlaces := DecPlaces - 1;
    IF LengthOf (fractn) > MaxPlaces THEN fractn := fractn DIV 10;
    IF (LastChTyped IN ['0'..'9']) AND (DecPlaces < MaxPlaces)
      THEN DecPlaces := DecPlaces + 1;
    WriteAFraction (fractn, DecPlaces, MaxPlaces, true);
  UNTIL DumpFraction OR (LastChTyped = ' ') OR (DecPlaces >= MaxPlaces);
  FOR i := DecPlaces TO MaxPlaces - 1 DO fractn := fractn * 10;
  GetValidFraction := NOT DumpFraction;
END;


PROCEDURE GetDecimal {(x, y, LowerLimit, UpperLimit, MaxPlaces: integer;
                      VAR WholePart, FractnPart: integer)};
{  Main decimal-getting procedure; returns two INTEGERS representing the whole
 and the fractional parts.  The later number is <normalized> by the maximum
 number of decimal places allowed (MaxPlaces), so that if you allow 4 decimal
 places, FractnPart represents integral 1/10,000th's; 2 decimal places returns 
 hundredths.  This procedure is the least well debugged of the sequence.
   I'm going to have to live with the features I provided here to see if I like 
 them:  1)  You work on the two parts of the number separately.  If you finish 
 the whole number with a period, you can work on the fractional part.  If you 
 finish the integral portion with a carriage return or space, the routine exits 
 and the fractional portion is unaltered.  Typing an <escape> at any time 
 before termination aborts the procedure and returns the original values.  
  2) During the actual number entry, if the the original values of the integral 
 and fractional portions are within the range set by the user, they are 
 presented for the user's perusal and optional change; otherwise, they are set 
 to zero.
  3) It was simply too complicated to allow for omitting x & y parameters; I
 couldn't keep track of where I was without a GOTOXY.}

VAR  OK, Abort: boolean;
     LastCh: char;
     TempWhole, TempFrac, width, i, j, WorkingLowerLimit, WorkingUpperLimit:
       integer;
     
BEGIN
  IF LowerLimit > UpperLimit
    THEN BEGIN
      width := LowerLimit MOD 20     {just in case, reasonable limit on width};
      i := 1;
      FOR j := 1 TO width DO i := i * 10;
      WorkingUpperLimit := i - 1;
      WorkingLowerLimit := (i DIV 10) -1;       {room for "-" sign}
    END
    ELSE BEGIN
      WorkingUpperLimit := UpperLimit;
      WorkingLowerLimit := LowerLimit;
      width := FigureWidth (UpperLimit, LowerLimit)
    END;
  TempWhole := WholePart;
  TempFrac := FractnPart;
  Abort := false;
  REPEAT
    Gotoxy (x,y);
    OK := ValidInteger 
      (WorkingLowerLimit, WorkingUpperLimit, width, true, Lastch, TempWhole);
    IF NOT OK 
      THEN IF Lastch = CHR (escape)
        THEN Abort := true
      ELSE IF TempWhole > WorkingUpperLimit
        THEN BEGIN
          Gotoxy (0, ErrorLine);
          Write ('Please type a number less than ', WorkingUpperLimit + 1);
          GetSpace (true);
          TempWhole := WorkingUpperLimit
        END
      ELSE IF TempWhole < WorkingLowerLimit
        THEN BEGIN
          Gotoxy (0, ErrorLine);
          Write ('Please type a number greater than ', WorkingLowerLimit - 1);
          GetSpace (true);
          TempWhole := WorkingLowerLimit
        END
      ELSE Write ('whoops! Forgot About This Error!')
    ELSE IF Lastch IN ['.', '0'..'9'] 
      THEN BEGIN
        Write ('.');
        OK := GetValidFraction (TempWhole, MaxPlaces, Lastch, TempFrac);
        IF NOT OK
          THEN IF LastCh = CHR (escape)
              THEN Abort := true
            ELSE IF LastCh IN ['-', '+'] THEN TempWhole := - TempWhole
            ELSE IF LastCh = CHR (delete)
              THEN BEGIN
                TempWhole := 0;
                TempFrac := 0
              END
            ELSE Write ('whoops!  Unforeseen fraction error.')
      END
  UNTIL Abort OR OK;
  IF OK
    THEN BEGIN
      WholePart := TempWhole;
      FractnPart := TempFrac;
    END;
  Gotoxy (x,y);
  Write (WholePart: width, '.');
  WriteAFraction (FractnPart, MaxPlaces, MaxPlaces, false)
END;
  

END.


========================================================================================
DOCUMENT :usus Folder:VOL05:getsort.text
========================================================================================


PROGRAM GETSORTEDCOPY; (* uses #5;keyno.text, #5:address.text, to build 
                          #5:printf.text, a sorted printable version of the 
                          entire address file *)

CONST 
      MAXNUMKEYS = 1000;

TYPE 
     STRUCTURE = RECORD
                   NAME: STRING;
                   STREET: STRING;
                   CITYSTATEZIP: STRING;
                   PHONE: STRING;
                   KEY : STRING
                 END;
     KEYREC = RECORD
                KEY : STRING;
                RECNUM : 0 .. MAXNUMKEYS
              END;
     PREC = ^REC;
     REC = RECORD
             LEFT, RIGHT : PREC;
             THEKEY : KEYREC
           END;

VAR 
    FIN : FILE OF STRUCTURE;
    FOUT, KEYF : TEXT;
    KEYS : KEYREC;
    NEXT, BASE, TREE : PREC;
    MAXKEYS : 0 .. MAXNUMKEYS;
    ANSWER : CHAR;

PROCEDURE PUTONTREE ( VAR PT, PN : PREC );
BEGIN
  IF PT = NIL
    THEN
      PT := PN
    ELSE
      IF PN^.THEKEY.KEY < PT^.THEKEY.KEY
        THEN
          PUTONTREE ( PT^.LEFT, PN )
        ELSE
          PUTONTREE ( PT^.RIGHT, PN );

  TREE := PT;
  WRITE ( '.');
END;

PROCEDURE PRINTTREE ( PNT : PREC );
BEGIN
  IF PNT <> NIL
    THEN
      BEGIN
        PRINTTREE ( PNT^.LEFT );
        WRITELN (KEYF, PNT^.THEKEY.KEY);
        WRITELN (KEYF, PNT^.THEKEY.RECNUM);
        WRITE ( '.');
        PRINTTREE (PNT^.RIGHT);
      END;
END;

PROCEDURE BUILDKEYFILE;

VAR 
    THISRECNO : 0 .. MAXNUMKEYS;
BEGIN
  RESET ( KEYF, '#5:KEYS.TEXT');
  READLN ( KEYF, MAXKEYS );
  MAXKEYS := PRED ( MAXKEYS );
  CLOSE ( KEYF, NORMAL );
  WRITELN('... Building the key file...' );
  RESET ( FIN, '#5:ADDRESS.TEXT');
  REWRITE ( KEYF, '#4:SORTK.TEXT');
  THISRECNO := 0;
  WHILE  ( (NOT EOF ( FIN ) ) AND  (THISRECNO <= MAXKEYS)) DO
    BEGIN
      SEEK ( FIN, THISRECNO );
      GET ( FIN );
      WRITELN ( KEYF, FIN^.KEY );
      WRITELN ( 'GOT ', FIN^.KEY);
      WRITELN ( KEYF, THISRECNO );
      WRITELN ( '     ',THISRECNO:2);
      SEEK (FIN, THISRECNO);
      PUT ( FIN );
      THISRECNO := SUCC ( THISRECNO );
    END;
  CLOSE ( KEYF, LOCK );
END;

PROCEDURE SORTKEYS;
BEGIN
  RESET ( KEYF,'#4:SORTK.TEXT');
  BASE := NIL;
  TREE := NIL;
  WRITELN ( '... Sorting keys ...');
  WHILE NOT EOF ( KEYF ) DO
    BEGIN
      NEW ( NEXT );
      READLN (KEYF, NEXT^.THEKEY.KEY);
      READLN (KEYF, NEXT^.THEKEY.RECNUM);
      NEXT^.LEFT := NIL;
      NEXT^.RIGHT := NIL;
      PUTONTREE ( BASE, NEXT );
    END;
  CLOSE ( KEYF, PURGE );
  REWRITE ( KEYF, '#5:SORTK.TEXT');
  WRITELN;
  WRITELN ('... Traversing the tree ... ');
  PRINTTREE ( TREE );
  CLOSE ( KEYF, LOCK );
END;

PROCEDURE BUILDSORTEDFILE;

VAR 
    I, BUF1 : INTEGER;
BEGIN
  WRITELN;
  WRITELN ('... Writing the sorted file ...');
  I := 0;
  CLOSE ( FIN, NORMAL );
  RESET ( KEYF, '#5:SORTK.TEXT');
  RESET ( FIN, '#5:ADDRESS.TEXT');
  REWRITE ( FOUT, '#5:PRINTF.TEXT');
  WHILE  ( (NOT EOF ( FIN ) ) AND ( I <= MAXKEYS ) )  DO
    BEGIN
      READLN ( KEYF);
      READLN ( KEYF, BUF1);
      SEEK ( FIN, BUF1);
      GET ( FIN );
      WRITELN (FIN^.NAME);
      WRITELN (FIN^.STREET);
      WRITELN (FIN^.CITYSTATEZIP);
      WRITELN (FIN^.PHONE);
      WRITELN ('``````````````````````````````````````````````> ', FIN^.KEY);
      WRITELN ( FOUT );
      WRITELN ( FOUT, FIN^.NAME);
      WRITELN ( FOUT, FIN^.STREET);
      WRITELN ( FOUT, FIN^.CITYSTATEZIP);
      WRITELN ( FOUT, FIN^.PHONE);
      WRITELN ( FOUT );
      SEEK ( FIN, BUF1);
      PUT ( FIN );
      I := SUCC ( I );
    END;
  CLOSE (FOUT, LOCK);
  WRITELN;
  WRITELN ('  ...Your sorted file, #5:PRINTF.TEXT, is ready ...');
  CLOSE (KEYF, PURGE);
END;

PROCEDURE PRINTSORTEDCOPY;
VAR
  F, LP : TEXT;
  BUFFER : STRING;
  LINENO, I : INTEGER;
  FF, CH : CHAR;

BEGIN
  
  FF := CHR ( 12 );
  
  WRITELN;
  
  WRITE(' Do You want a Hard Copy now? Y/N: ');
  
  READLN ( CH );
  WRITELN;
  
  IF CH IN [ 'Y', 'y' ]
     THEN
       BEGIN
         RESET ( F, '#5:PRINTF.TEXT');
         REWRITE ( LP, 'PRINTER:');
         WHILE NOT EOF ( F ) DO
            BEGIN
              CH := FF;
              WRITE ( LP, CH );
              LINENO := 0;
              WHILE (LINENO < 60 ) AND (NOT (EOF (F) )) DO
                BEGIN
                  LINENO := SUCC ( LINENO );
                  READLN ( F, BUFFER );
                  WRITELN ( LP, BUFFER );
                  WRITELN ( BUFFER );
                END;
            END;
       END;
END;

BEGIN
   WRITE (' Do You want to rebuild the print file? Y/N: ');
   READLN ( ANSWER );
   IF ANSWER IN [ 'Y', 'y']
     THEN
       BEGIN
         BUILDKEYFILE;
         SORTKEYS;
         BUILDSORTEDFILE;
       END;
   PRINTSORTEDCOPY;
END.

========================================================================================
DOCUMENT :usus Folder:VOL05:hexdecoct.text
========================================================================================


{This program does number base conversion between hexidecimal,
decimal, octal and binary numbers.  Author is unknown}

PROGRAM CONVERSION;
TYPE OREC =
     PACKED RECORD
         
         E0:PACKED ARRAY[0..4] OF 0..7
     END;
     
    HREC =
    PACKED RECORD
        
        H0:PACKED ARRAY[0..3] OF 0..15
     END;
    
    BREC =
    PACKED RECORD
      
        B0:PACKED ARRAY[0..15] OF 0..1
    END;
    
    LETSET = SET OF '0'..'F';
     
VAR 
    R: RECORD
         CASE INTEGER OF
            1:(INT:INTEGER);
            2:(OCTREC:OREC);
            3:(HEXREC:HREC);
            4:(BINREC:BREC)
          END;
    CH:CHAR;
    OCTLET,BINLET,DECLET,HEXLET,TESTSET:LETSET;
    K,I,J:INTEGER;
    BOOLCHAR,VALID,BOOL:BOOLEAN;
    
PROCEDURE DECTO;
VAR NUM:STRING[6];
    MINUS:BOOLEAN;
BEGIN
  WITH R.HEXREC DO BEGIN
  WITH R.OCTREC DO BEGIN
  WITH R.BINREC DO BEGIN
  WRITE(' TO ');
  TESTSET:=['H','B','O'];
  BOOL:=FALSE;
  BOOLCHAR:=TRUE;
  REPEAT
    FOR I:=0 TO 3 DO
     H0[I]:=0;
    IF BOOL THEN  WRITE('CONVERT DECIMAL TO ');
    IF BOOL THEN READLN(CH);
    IF BOOLCHAR THEN READ(CH);
    IF CH IN TESTSET THEN
      BEGIN
        BOOLCHAR:=TRUE;
        WRITELN;
        WRITE('DECIMAL NUMBER = ');
        READ(NUM);
        MINUS:=FALSE;
        IF NUM[1] = '-' THEN 
          BEGIN
            MINUS:=TRUE;
            I:=2;
          END
        ELSE
          I:=1;
        VALID:=TRUE;
        R.INT:=0;
        WHILE (I<=LENGTH(NUM)) AND VALID DO
          BEGIN
            IF NUM[I] IN DECLET THEN
              R.INT:=(R.INT*10)+ORD(NUM[I])-ORD('0')
            ELSE
              VALID:=FALSE;
            I:=I+1;
          END;
        IF MINUS THEN R.INT:=R.INT*(-1);
        IF NOT VALID THEN WRITELN('INVALID DECIMAL NUMBER')
        ELSE
          BEGIN
            IF CH = 'H' THEN
              BEGIN
                  WRITE('HEXADECIMAL NUMBER = ');
                   FOR I:=3 DOWNTO 0 DO
                   BEGIN
                     IF H0[I] < 10 THEN WRITE(H0[I])
                     ELSE WRITE(CHR(H0[I]-10+ORD('A')));
                   END;
              END
            ELSE
              IF CH = 'O' THEN
                BEGIN
                  WRITE('OCTAL INTEGER =');
                  WRITE(B0[15],E0[4],E0[3],E0[2],E0[1],E0[0]);
                END
              ELSE
                IF CH = 'B' THEN
                  BEGIN
                    WRITE('BINARY INTEGER =');
                    FOR I:=15 DOWNTO 0 DO 
                      WRITE(B0[I]);
                  END;
          END; (*VALID*)
        END (*TESTSET*)
      ELSE
        IF CH <> 'S' THEN
          BEGIN
            WRITELN(' WRONG CHARACTER COMMAND.');
            WRITELN('Press Return After Entering Correct Command.');
            BOOLCHAR:=FALSE;
          END;
    WRITELN;
    BOOL:=TRUE;
  UNTIL CH = 'S';
  END;  (*BEGIN'S*)
  END;
  END;
END; (*DECTO*)
     
PROCEDURE HEXTO;
VAR NUM:STRING[4];
BEGIN
  WITH R.HEXREC DO BEGIN
  WITH R.OCTREC DO BEGIN
  WITH R.BINREC DO BEGIN
    WRITE(' TO ');
    TESTSET:=['B','D','O'];
    BOOL:=FALSE;
    BOOLCHAR:=TRUE;
    REPEAT
      FOR I:=0 TO 3 DO
       H0[I]:=0;
      IF BOOL THEN WRITE('CONVERT HEXADECIMAL TO ');
      IF BOOL THEN READLN(CH);
      IF BOOLCHAR THEN READ (CH);
      IF CH IN TESTSET THEN 
      BEGIN
        BOOLCHAR:=TRUE;
        WRITELN;
        WRITE('HEXADECIMAL INTEGER =');
        READ (NUM);
        I:=0;
        VALID:=TRUE;
        J:=LENGTH(NUM); 
        WHILE (J>=1) AND VALID DO
          BEGIN
            IF NUM[J] IN HEXLET THEN
              H0[I]:=ORD(NUM[J])-ORD('A')+10
            ELSE
              IF NUM[J] IN DECLET THEN 
                H0[I]:=ORD(NUM[J])-ORD('0')
              ELSE
                VALID:=FALSE;
            J:=J-1;
            I:=I+1;
          END;
        IF NOT VALID THEN WRITELN('INVALID HEXADECIMAL NUMBER')
        ELSE
          BEGIN
            IF CH = 'D' THEN
              WRITE('DECIMAL INTEGER = ',R.INT)
            ELSE 
              IF CH = 'O' THEN
                WRITE('OCTAL INTEGER = ',B0[15],E0[4],E0[3],E0[2],E0[1],E0[0])
              ELSE
                IF CH = 'B' THEN
                  BEGIN
                    WRITE('BINARY INTEGER =');
                    FOR I:=15 DOWNTO 0 DO
                      WRITE(B0[I]);
                  END;
          END; (*VALID*)
        END (*TESTSET*)
      ELSE
        IF CH <> 'S' THEN
          BEGIN
            WRITELN(' WRONG CHARACTER COMMAND.');
            WRITELN('Press Return After Entering Correct Command.');
            BOOLCHAR:=FALSE;
          END;
      WRITELN;
      BOOL:=TRUE
    UNTIL CH = 'S';
  END;  (*BEGIN'S*)
  END;
  END;
END; (*HEXTO*)

PROCEDURE OCTTO;
VAR NUM:STRING[6];
BEGIN
  WITH R.HEXREC DO BEGIN
  WITH R.OCTREC DO BEGIN
  WITH R.BINREC DO BEGIN
    WRITE(' TO ');
    TESTSET:=['B','D','H'];
    BOOL:=FALSE;
    BOOLCHAR:=TRUE;
    REPEAT
      FOR I:=0 TO 3 DO
        H0[I]:=0;
      IF BOOL THEN WRITE('CONVERT OCTAL TO ');
      IF BOOL THEN READLN(CH);
      IF BOOLCHAR THEN READ(CH);
      IF CH IN TESTSET THEN
        BEGIN
          BOOLCHAR:=TRUE;
          WRITELN;
          WRITE('OCTAL INTEGER = ');
          READ(NUM);
          I:=1;
          VALID:=TRUE;
          R.INT:=0;
          WHILE (I<= LENGTH(NUM)) AND VALID DO
            BEGIN
              IF NUM[I] IN OCTLET THEN
                R.INT:=(R.INT*8)+ORD(NUM[I])-ORD('0')
              ELSE
                VALID:=FALSE;
              I:=I+1;
            END;
          IF NOT VALID THEN WRITELN('INVALID OCTAL NUMBER')
          ELSE
            BEGIN
              IF CH = 'D' THEN
                WRITE('DECIMAL INTEGER =',R.INT)
              ELSE
                IF CH = 'H' THEN
                  BEGIN
                    WRITE('HEXADECIMAL NUMBER = ');
                    FOR I:=3 DOWNTO 0 DO
                      BEGIN
                        IF H0[I] < 10 THEN WRITE(H0[I])
                        ELSE WRITE(CHR(H0[I]-10+ORD('A')));
                      END;
                  END
                ELSE
                  IF CH = 'B' THEN
                    BEGIN
                      WRITE('BINARY INTEGER =');
                      FOR I:=15 DOWNTO 0 DO
                        WRITE(B0[I]);
                    END;
            END;  (*VALID*)
        END  (*TESTSET*)
      ELSE
        IF CH <> 'S' THEN
          BEGIN
            WRITELN(' WRONG CHARACTER COMMAND.');
            WRITELN('Press Return After Entering Correct Command.');
            BOOLCHAR:=FALSE;
          END;
    WRITELN;
    BOOL:=TRUE;
  UNTIL CH = 'S';
  END;  (*BEGIN'S*)
  END;
  END;
END; (*OCTTO*)
  
PROCEDURE BINTO;
VAR NUM:STRING[16];
BEGIN
  WITH R.HEXREC DO BEGIN
  WITH R.OCTREC DO BEGIN
  WITH R.BINREC DO BEGIN
    WRITE(' TO ');
    TESTSET:=['D','H','O'];
    BOOL:=FALSE;
    BOOLCHAR:=TRUE;
    REPEAT
      FOR I:=0 TO 3 DO
        H0[I]:=0;
      IF BOOL THEN WRITE('CONVERT BINARY TO ');
      IF BOOL THEN READLN(CH);
      IF BOOLCHAR THEN READ(CH);
      IF CH IN TESTSET THEN
        BEGIN
          BOOLCHAR:=TRUE;
          WRITELN;
          WRITE('BINARY NUMBER = ');
          READ(NUM);
          I:=LENGTH(NUM);
          VALID:=TRUE; 
          J:=0;
          WHILE (I>=1) AND VALID DO
            BEGIN
              IF NUM[I] IN BINLET THEN
                B0[J]:=ORD(NUM[I])-ORD('0')
              ELSE 
                VALID:=FALSE;
              I:=I-1;
              J:=J+1;
            END;
          IF NOT VALID THEN WRITELN('INVALID BINARY NUMBER')
          ELSE
            BEGIN
              IF CH = 'D' THEN
                WRITE('DECIMAL INTEGER =',R.INT)
              ELSE
                IF CH = 'H' THEN
                  BEGIN
                    WRITE('HEXADECIMAL INTEGER = ');
                    FOR I:=3 DOWNTO 0 DO
                      BEGIN
                        IF H0[I] < 10 THEN WRITE(H0[I])
                        ELSE WRITE(CHR(ORD(H0[I])-10+ORD('A')));
                      END;
                  END
                ELSE
                  IF  CH = 'O' THEN 
                    BEGIN
                      WRITE('OCTAL INTEGER = ');
                      WRITE(B0[15],E0[4],E0[3],E0[2],E0[1],E0[0]);
                    END;
            END; (*VALID*)
        END  (*TESTSET*)
      ELSE
        IF CH <> 'S' THEN
          BEGIN
            WRITELN(' WRONG CHARACTER COMMAND.');
            WRITELN('Press Return After Entering Correct Command.');
            BOOLCHAR:=FALSE;
          END;
    WRITELN;
    BOOL:=TRUE;
  UNTIL CH = 'S';
  END;  (*BEGIN'S*)
  END;
  END;
END; (*BINTO*)

PROCEDURE COMMENTS;
BEGIN 
  WRITELN('THIS PROGRAM CONVERTS BETWEEN DECIMAL, OCTAL, AND ');
  WRITELN('HEXADECIMAL INTEGERS.');
  WRITELN('THE LARGEST INTEGERS THIS PROGRAM WILL USE IS:');
  WRITELN('   HEXADECIMAL:  7FFF      FFFF');
  WRITELN('   DECIMAL    :  65535     -65535 ');
  WRITELN('   OCTAL      :  077777    177777');
  WRITELN('   BINARY     :  16 BITS');
  WRITELN;
  WRITELN('HEXADECIMAL,BINARY AND OCTAL INTEGERS ARE IN 16 BIT TWO''S');
  WRITELN('COMPLEMENT REPRESENTATION.  IF AN ENTERED DECIMAL INTEGER');
  WRITELN('IS OUTSIDE THE RANGE 32767<= X <=-32768 THEN THE HEX, OCTAL'); 
  WRITELN('AND BINARY NUMBERS WILL HAVE AN "UNDERSTOOD" SIGN BIT.  WHEN ');
  WRITELN('HEX, OCTAL OR BINARY INTEGER IS ENTERED THE I6TH BIT (IF THERE ');
  WRITELN('IS ONE) WILL BE TAKEN AS A SIGN BIT');
  WRITELN;
  WRITELN('FOR USE IN THIS PROGRAM TYPE:');
  WRITELN('  ''H'' FOR HEXADECIMAL');
  WRITELN('  ''D'' FOR DECIMAL');
  WRITELN('  ''B'' FOR BINARY');
  WRITELN('  ''O'' FOR OCTAL');
  WRITELN('  ''C'' FOR GETTING THESE COMMENTS');
  WRITELN('  ''S'' FOR STOPPING A PROCEDURE');
  WRITE('  ''Q'' FOR QUITTING THE PROGRAM');
END; (*COMMENTS*)
    
BEGIN (*MAIN PROGRAM*)
  COMMENTS;
  HEXLET:=['A'..'F'];
  DECLET:=['0'..'9'];
  OCTLET:=['0'..'7'];
  BINLET:=['0'..'1'];
  CH:='E';
  REPEAT
    CASE CH OF 
      'H': HEXTO;
      'O': OCTTO;
      'B': BINTO;
      'C': COMMENTS;
      'D': DECTO
    END;
    WRITELN;
    WRITE('I WOULD LIKE TO CONVERT INTEGERS IN ');
    REPEAT
      READ (CH);
    UNTIL CH  IN ['C','B','H','O','D','Q'];
  UNTIL CH = 'Q';
  WRITELN('GOODBYE');
END.


========================================================================================
DOCUMENT :usus Folder:VOL05:id2id.text
========================================================================================

(*$S+, Modified by F. J. Monaco for UCSD PASCAL *)
PROGRAM ID2D (INFILE,OUTFILE, IDPAIRS, SCREEN );
USES GOODSTUFF;

CONST 
      MAXLENGTH = 25;
      BLANKS = '                         ';

TYPE 
     CHARS =  'A' .. 'z';
     CHARSET = SET OF CHARS;
     IDLENGTH = 1 .. MAXLENGTH;
     IDTYPE = RECORD
                NAME : PACKED ARRAY [ IDLENGTH ] OF CHAR;
                LENGTH : IDLENGTH
              END;
     BALANCE = (HIGHERLEFT, EVEN, HIGHERRIGHT);
     NODEPTR = ^NODE;
     NODE = RECORD
              ID : IDTYPE;
              LEFT, RIGHT : NODEPTR;
              BAL : BALANCE;
              IDISNEW : BOOLEAN;
              CASE IDISOLD: BOOLEAN OF
                TRUE: (NEWPTR : NODEPTR);
                FALSE: (SEENININFILE : BOOLEAN)
            END;

VAR 
    IDTABLE : NODEPTR;
    INFILE, OUTFILE, IDPAIRS, SCREEN: TEXT;
    LETTERS, DIGITS, LETTERANDDIGITS : CHARSET;

PROCEDURE INITIALIZE;
VAR
  THISNAME : STRING[30];
BEGIN
  REWRITE(SCREEN, 'CONSOLE:');
  GETCRTINFO;
  getdate ( thisname );
  GOTOXY ( 0, 0 );
  CRT ( ERASEOS );
  writeln (' UCSD PASCAL version of PUG''s ID2D ... ',thisname, ' ...');
  writeln ('  modified by Frank Monaco  ');
  writeln;
  WRITELN ( 'This Program replaces OLD IDENTIFIERS with NEW IDENTIFIERS ');
  WRITELN ('  ...... in a PASCAL Program ... ');
  writeln;
  writeln (' You will be prompted for two INPUT files: ');
  writeln ('     1)  The file containing "oldids, newids"  ');
  writeln ('     2)  The file containing the program to be changed ');
  writeln (' You will be next prompted for the new OUTPUT program file ');
  gotoxy ( 25, 12 );
  write (' ... First, the IDPAIRS file .... ');
  getfile (idpairs, true );
  GOTOXY ( 0, 0);
  CRT (ERASEOS );
  gotoxy ( 25, 12 );
  write (' ... Next, the PROGRAM file to be changed ...');
  GETFILE (INFILE, TRUE );
  gotoxy ( 0, 0);
  CRT (ERASEOS);
  gotoxy ( 25, 12 );
  write (' ... Next, the NEW PROGRAM File name ...');
  GETFILE (OUTFILE, FALSE);
  gotoxy ( 0, 0 );
  crt ( eraseos );
  LETTERS := [ 'A', 'B','C','D','E','F','G','H','I','J','K','L','M',
             'N', 'O','P','Q','R','S','T','U','V','W','X','Y','Z',
             'a', 'b', 'c', 'd', 'e','f','g','h','i','j','k','l','m',
             'n','o','p','q','r','s','t','u','v','w','x','y','z'];
  DIGITS := [ '0' .. '9' ];
  LETTERANDDIGITS := LETTERS + DIGITS;
END;

PROCEDURE READID(VAR INFILE : TEXT; VAR IDENT : IDTYPE);

VAR 
    CHCOUNT : 0 .. MAXLENGTH;
BEGIN
  IDENT.NAME := BLANKS;
  CHCOUNT := 0;
  REPEAT
    CHCOUNT := SUCC (CHCOUNT);
    IDENT.NAME [ CHCOUNT ] := INFILE^;
    GET(INFILE)
  UNTIL NOT (INFILE^ IN LETTERANDDIGITS) OR (CHCOUNT = MAXLENGTH);
  IDENT.LENGTH := CHCOUNT
END;

PROCEDURE READIDPAIRSANDCREATESYMBOLTABLE;

TYPE 
     IDKIND = (OLDKIND, NEWKIND);

VAR 
    OLDID, NEWID: IDTYPE;
    LINK: NODEPTR;
    LINENUM: INTEGER;
    INCRHGT : BOOLEAN;

PROCEDURE ERROR;
BEGIN
  WRITELN(SCREEN,' ON LINE NUMBER ':29,LINENUM: 1, ' OF THE "IDPAIRS" FILE');
END;

PROCEDURE ENTER (VAR IDENTIFIER: IDTYPE; KIND: IDKIND; VAR P :
                 NODEPTR; VAR INCREASEDHEIGHT : BOOLEAN);

VAR 
    P1, P2 : NODEPTR;
BEGIN
  IF P = NIL
    THEN
      BEGIN
        NEW(P);
        INCREASEDHEIGHT := TRUE;
        WITH P^ DO
          BEGIN
            ID := IDENTIFIER;
            IDISNEW := KIND = NEWKIND;
            IDISOLD := KIND = OLDKIND;
            LEFT := NIL;
            RIGHT := NIL;
            BAL := EVEN;
            IF IDISNEW
              THEN
                BEGIN
                  LINK := P;
                  SEENININFILE := FALSE;
                END
              ELSE
                NEWPTR := LINK
          END
      END
    ELSE
      IF IDENTIFIER.NAME < P^.ID.NAME
        THEN
          BEGIN
            ENTER (IDENTIFIER, KIND, P^.LEFT, INCREASEDHEIGHT);
            IF INCREASEDHEIGHT
              THEN
                CASE P^.BAL OF
                  HIGHERRIGHT : BEGIN
                                  P^.BAL := EVEN;
                                  INCREASEDHEIGHT := FALSE
                                END;
                  EVEN: P^.BAL := HIGHERLEFT;
                  HIGHERLEFT: BEGIN
                                P1 := P^.LEFT;
                                IF P1^.BAL = HIGHERLEFT
                                  THEN
                                    BEGIN
                                      P^.LEFT := P1^.RIGHT;
                                      P1^.RIGHT := P;
                                      P^.BAL := EVEN;
                                      P := P1
                                    END
                                  ELSE
                                    BEGIN
                                      P2 := P1^.RIGHT;
                                      P1^.RIGHT := P2^.LEFT;
                                      P2^.LEFT := P1;
                                      P^.LEFT := P2^.RIGHT;
                                      P2^.RIGHT := P;
                                      IF P2^.BAL = HIGHERLEFT
                                        THEN
                                          P^.BAL := HIGHERRIGHT
                                        ELSE
                                          P^.BAL := EVEN;
                                      IF P2^.BAL = HIGHERRIGHT
                                        THEN
                                          P^.BAL := HIGHERLEFT
                                        ELSE
                                          P1^.BAL := EVEN;
                                      P := P2;
                                    END;
                                P^.BAL := EVEN;
                                INCREASEDHEIGHT := FALSE;
                              END;
                END
          END
        ELSE
          IF IDENTIFIER.NAME > P^.ID.NAME
            THEN
              BEGIN
                ENTER(IDENTIFIER, KIND, P^.RIGHT, INCREASEDHEIGHT);
                IF INCREASEDHEIGHT
                  THEN
                    CASE P^.BAL OF
                      HIGHERLEFT: BEGIN
                                    P^.BAL := EVEN;
                                    INCREASEDHEIGHT := FALSE;
                                  END;
                      EVEN: 
                            P^.BAL := HIGHERRIGHT;
                      HIGHERRIGHT: BEGIN
                                     P1 := P^.RIGHT;
                                     IF P1^.BAL = HIGHERRIGHT
                                       THEN
                                         BEGIN
                                           P^.RIGHT := P1^.LEFT;
                                           P1^.LEFT := P;
                                           P^.BAL := EVEN;
                                           P := P1
                                         END
                                       ELSE
                                         BEGIN
                                           P2 := P1^.LEFT;
                                           P1^.LEFT := P2^.RIGHT;
                                           P2^.RIGHT := P1;
                                           P^.RIGHT := P2^.LEFT;
                                           P2^.LEFT := P;
                                           IF P2^.BAL = HIGHERRIGHT
                                             THEN
                                               P^.BAL := HIGHERLEFT
                                             ELSE
                                               P^.BAL := EVEN;
                                           IF P2^.BAL = HIGHERLEFT
                                             THEN
                                               P1^.BAL := HIGHERRIGHT
                                             ELSE
                                               P1^.BAL := EVEN;
                                           P := P2;
                                         END;
                                     P^.BAL := EVEN;
                                     INCREASEDHEIGHT := FALSE;
                                   END;
                    END
              END
            ELSE
              BEGIN
                INCREASEDHEIGHT := FALSE;
                WITH P^ DO
                  BEGIN
                    IF IDISOLD
                      THEN
                        IF KIND = OLDKIND
                          THEN
                            BEGIN
                              WRITELN(SCREEN,
                                      '***DUPLICATE OLD IDS ENCOUNTERED: ',
                                      IDENTIFIER.NAME);
                              ERROR;
                              EXIT ( PROGRAM )
                            END
                          ELSE
                            BEGIN
                              IDISNEW := TRUE;
                              LINK := P
                            END
                      ELSE
                        IF KIND = NEWKIND
                          THEN
                            BEGIN
                              WRITELN(SCREEN, '---WARNING:  ', IDENTIFIER.NAME,
                                      ' HAS ALSO APPEARED AS ANOTHER NEWID');
                              ERROR;
                              LINK := P
                            END
                          ELSE
                            BEGIN
                              IDISOLD := TRUE;
                              NEWPTR := LINK
                            END
                  END
              END
END;

PROCEDURE TRUNCATION ( VAR IDENT: IDTYPE);
BEGIN
  WRITELN(SCREEN, '---WARNING: TRUNCATION FOR IDENTIFIER: ',
          IDENT.NAME);
  WRITELN(SCREEN, '---EXTRA CHARACTERS IGNORED ': 39);
  ERROR;
  REPEAT
    GET (IDPAIRS)
  UNTIL NOT (IDPAIRS^ IN LETTERANDDIGITS);
END;
BEGIN
  IDTABLE := NIL;
  RESET (IDPAIRS);
  LINENUM := 1;
  INCRHGT := FALSE;
  WHILE NOT EOF(IDPAIRS) DO
    BEGIN
      WHILE (IDPAIRS^ = ' ') AND NOT EOLN(IDPAIRS) DO
        GET(IDPAIRS);
      IF IDPAIRS^ IN LETTERS
        THEN
          BEGIN
            READID(IDPAIRS,OLDID);
            IF IDPAIRS^ IN LETTERANDDIGITS
              THEN
                TRUNCATION(OLDID);
            WHILE (IDPAIRS^ IN [' ',',']) AND NOT  EOLN(IDPAIRS) DO
              GET (IDPAIRS);
            IF IDPAIRS^ IN LETTERS
              THEN
                BEGIN
                  READID(IDPAIRS,NEWID);
                  IF IDPAIRS^ IN LETTERANDDIGITS
                    THEN
                      TRUNCATION(NEWID);
                  ENTER(NEWID,NEWKIND, IDTABLE,INCRHGT);
                  ENTER(OLDID, OLDKIND, IDTABLE, INCRHGT);
                END
              ELSE
                BEGIN
                  WRITELN(SCREEN, '---WARNING: MALFORMED IDPAIR');
                  ERROR;
                END
          END
        ELSE
          BEGIN
            WRITELN(SCREEN, '---WARNING: MALFORMED IDPAIR');
            ERROR;
          END;
      READLN(IDPAIRS);
      LINENUM := SUCC ( LINENUM);
    END;
END;

PROCEDURE EDITINFILETOOUTFILE;

VAR 
    INFILEID: IDTYPE;
    DIGITSE, IMPORTANTCHARS: CHARSET;

PROCEDURE SUBSTITUTE (VAR IDENTIFIER: IDTYPE; P : NODEPTR);

PROCEDURE WRITEINFILEID;
BEGIN
  WITH INFILEID DO
    WRITE(OUTFILE, NAME: LENGTH);
  WHILE INFILE^ IN LETTERANDDIGITS DO
    BEGIN
      WRITE(OUTFILE, INFILE^);
      GET(INFILE);
    END
END;
BEGIN
  IF P = NIL
    THEN
      WRITEINFILEID
    ELSE
      IF IDENTIFIER.NAME < P^.ID.NAME
        THEN
          SUBSTITUTE(IDENTIFIER, P^.LEFT)
        ELSE
          IF IDENTIFIER.NAME > P^.ID.NAME
            THEN
              SUBSTITUTE(IDENTIFIER, P^.RIGHT)
            ELSE
              WITH P^ DO
                IF IDISOLD
                  THEN
                    BEGIN
                      WITH NEWPTR^.ID DO
                        WRITE(OUTFILE, NAME: LENGTH);
                      WHILE INFILE^ IN LETTERANDDIGITS DO
                        GET(INFILE)
                    END
                  ELSE
                    BEGIN
                      SEENININFILE := TRUE;
                      WRITEINFILEID
                    END
END;
BEGIN
  IMPORTANTCHARS := LETTERANDDIGITS + ['(', '_', ''''];
  DIGITSE := DIGITS + ['E', 'e'];
  WHILE NOT EOF(INFILE) 
    DO
    BEGIN
      WHILE NOT EOLN(INFILE) DO
        IF INFILE^ IN IMPORTANTCHARS
          THEN
            CASE INFILE^ OF
              'A','B','C','D','E','F','G','H','I','J','K','L','M','N',
              'O','P','Q','R','S','T','U','V','W','X','Y','Z',
              'a','b','c','d','e','f','g','h','i','j','k','l','m','n','o',
              'p','q','r','s','t','u','v','w','x','y','z': 
                                                               BEGIN
                                                                 READID(INFILE,
                                                                        INFILEID
                                                                 );
                                                                 SUBSTITUTE(
                                                                        INFILEID
                                                                            ,
                                                                        IDTABLE
                                                                 );
                                                               END;
              '0','1','2','3','4','5','6','7','8','9': 
                                                       REPEAT
                                                         WRITE(OUTFILE, INFILE^)
                                                         ;
                                                         GET(INFILE)
                                                       UNTIL NOT (INFILE^ IN
                                                             DIGITS);
              '''': 
                    BEGIN
                      REPEAT
                        WRITE(OUTFILE, INFILE^);
                        GET(INFILE);
                      UNTIL ( INFILE^ = '''') OR EOLN(INFILE);
                      IF EOLN(INFILE)
                        THEN
                          WRITELN(SCREEN, 'UNCLOSED STRING FOUND');
                      WRITE(OUTFILE, INFILE^);
                      GET(INFILE);
                    END;
              '(' : 
                    BEGIN
                      WRITE (OUTFILE, INFILE^);
                      GET(INFILE);
                      IF INFILE^ = '*'
                        THEN
                          BEGIN
                            REPEAT
                              WRITE(OUTFILE, INFILE^);
                              GET(INFILE);
                              WHILE INFILE^ <> '*' 
                                DO
                                BEGIN
                                  IF EOLN (INFILE)
                                    THEN
                                      WRITELN (OUTFILE)
                                    ELSE
                                      WRITE(OUTFILE, INFILE^);
                                  GET(INFILE);
                                END;
                              WRITE(OUTFILE,INFILE^);
                              GET(INFILE)
                            UNTIL INFILE^ = ')';
                            WRITE(OUTFILE, INFILE^);
                            GET(INFILE);
                          END;
                    END;
            END
          ELSE
            BEGIN
              WRITE(OUTFILE,INFILE^);
              GET(INFILE);
            END;
      READLN(INFILE);
      WRITELN(OUTFILE);
    END
END;

PROCEDURE CHECKSEENININFILE(P: NODEPTR);
BEGIN
  IF P <> NIL
    THEN
      BEGIN
        CHECKSEENININFILE(P^.LEFT);
        WITH P^ DO
          IF IDISNEW AND NOT IDISOLD
            THEN
              IF SEENININFILE
                THEN
                  BEGIN
                    WRITELN(SCREEN,'---WARNING: ', ID.NAME: ID.LENGTH,
                            ' WAS SPECIFIED AS A NEW IDENTIFIER ');
                    WRITELN(SCREEN,'---AND WAS ALSO SEEN IN THE INFILE ': 46,
                            ' PROGRAM UNCHANGED ');
                  END;
        CHECKSEENININFILE(P^.RIGHT)
      END
END;
BEGIN 
  INITIALIZE;
  READIDPAIRSANDCREATESYMBOLTABLE; 
  EDITINFILETOOUTFILE; 
  CHECKSEENININFILE(IDTABLE); 
  CLOSE ( OUTFILE, LOCK ); 
END.


========================================================================================
DOCUMENT :usus Folder:VOL05:makemasks.text
========================================================================================

PROGRAM MakeCRTMasks;
USES CRTInput, GetNumber;

CONST
       MaxX = 79;
       MaxY = 23;
       MaxData = 50;
       DefaultMark = '^';
       LengthChar = '*';
       TESTING = FALSE;

TYPE
       YLimits = 0..MaxY;
       XLimits = 0..MaxX;
       DataLimits = 1..MaxData;
       CRTLineArray = PACKED ARRAY [XLimits] OF char;
       DataRec = PACKED RECORD
                   X: XLimits;
                   Y: YLimits;
                   Lngth, Decimal: XLimits;
                 END;
       MaskRec = RECORD
                   Line: ARRAY [YLimits] OF CRTLineArray;
                   Data: ARRAY [DataLimits] OF DataRec;
                 END;
       
VAR
     i, j, ThisRecordNo, NoOfDataRecords: integer;
     ch, Datamark: char;
     NumberSet: SET OF DataLimits;
     InfileName, DFileName: string[30];
     TextBuf: ARRAY [YLimits] OF string;
     Mask: MaskRec;
     Infile, List: text;
     DataFile: FILE OF MaskRec;
 
 
 PROCEDURE ClearScreen; EXTERNAL;
 
 
 FUNCTION Yes (prompt: string) : boolean; EXTERNAL;
 
 
 PROCEDURE OpenDataFile;
 VAR  Newfile: boolean;
 
 BEGIN
   REPEAT
     NoOfDataRecords := 0;
     NewFile := false;
     Write ('What is the name of the CRT mask data file?  ');
     DFileName := '';
     GetString (23, DFileName);
     Writeln;
     IF (DFileName = '') OR  (DFileName = ' ') 
       THEN IF Yes ('Do you want to quit') THEN EXIT (program);
     {$I-}
     Allcaps (DFileName);
     Reset (DataFile, DFileName);
     IF IORESULT > 0 THEN Reset (Datafile, CONCAT ('#5:', DFileName));
     {$I+}
     i := IORESULT;
     IF i = 10
       THEN BEGIN
         IF Yes ('NEW FILE.  Correct')
           THEN BEGIN
             Newfile := true;
             {$I-}
             Rewrite (DataFile, DFileName);
             {$I+}
             i := IORESULT;
           END
       END;
  UNTIL i = 0;
  IF NOT Newfile
    THEN BEGIN
      REPEAT
        Get (DataFile);
        NoOfDataRecords := NoOfDataRecords + 1;
      UNTIL eof (DataFile);
      Reset (DataFile)
    END;
END;


PROCEDURE TranslateCRTData (LineNo: YLimits);
VAR L, FieldStart, FieldEnd, DataNumber: integer;
    DataDec, DataLength, TextLength: XLimits;
    HasData: boolean;
    
    
PROCEDURE ScanField;
VAR Done, HasDecimal: boolean;
    ChL: char;
    Dec: integer;
BEGIN
  L := FieldStart;
  HasDecimal := false;
  Dec := 0;
  
IF TESTING THEN BEGIN WRITE ('X = ', FIELDSTART:3, '; Y = ', I:3);
IF DATANUMBER MOD 4 = 0 THEN WRITELN ELSE WRITE ('   ') END;
  
  REPEAT
    L := L + 1;
    Done := (L > TextLength) OR (L > MaxX);
    IF NOT Done
      THEN BEGIN
        ChL := Mask.Line [LineNo,L];
        Done := NOT (ChL IN ['0'..'9', '.', LengthChar])
      END;
    IF NOT Done AND (ChL = '.') THEN IF HasDecimal
      THEN BEGIN                  {second period marks end of field.      }
        Done := true;
        IF (Mask.Line [LineNo, L-1] = '.') {i.e., are we really at the start of}
          THEN BEGIN              { a dotted line?  Then dump ALL periods.}
            HasDecimal := false;
            Dec := 0;
            L := L-1;
          END
      END
      ELSE BEGIN
        HasDecimal := true;
        Dec := L
      END;
  UNTIL Done;
  DataLength := L - FieldStart;
  IF Dec = 0 THEN DataDec := 0 ELSE DataDec := L - (Dec +1);
  FieldEnd := L;
END;
  

PROCEDURE GetFieldNumber;


PROCEDURE FigureOutNumber;
VAR i: integer;
BEGIN
  i := 0;
  REPEAT i := i + 1 UNTIL NOT (i IN NumberSet);
  IF i > MaxData
    THEN BEGIN
      Writeln (CHR (7), '** ERROR **':40);
      Writeln ('There is no room in the table for the data field starting at ', 
FieldStart, ', ', LineNo, '.'); 
      i := 0;
    END;
  DataNumber := i
END;
      
      
BEGIN
  DataNumber := 0;
  L := FieldStart + 1;
  REPEAT
    IF Mask.Line [LineNo,L] IN ['0'..'9']
      THEN DataNumber := DataNumber * 10 
           + ORD (Mask.Line [LineNo,L]) - ORD ('0');
    L := L + 1;
  UNTIL L >= FieldEnd;
  IF (DataNumber > MaxData) OR (DataNumber = 0) OR (DataNumber IN Numberset)
    THEN FigureOutNumber;
END;


BEGIN
  TextLength := Length (TextBuf [LineNo]);
  FieldStart := -1;
  REPEAT
    REPEAT
      FieldStart := FieldStart + 1;
      HasData := Mask.Line [LineNo, FieldStart] = Datamark
    UNTIL HasData OR (FieldStart > TextLength) OR (FieldStart = MaxX);
    IF HasData
      THEN BEGIN
        ScanField;
        GetFieldNumber;
        IF DataNumber > 0 THEN WITH Mask.Data[DataNumber] DO
          BEGIN
            X := FieldStart;
            Y := LineNo;
            Lngth := DataLength;
            Decimal := DataDec
          END;
        FOR L := FieldStart TO FieldEnd - 1 DO Mask.Line [LineNo,L] := ' ';
        NumberSet := NumberSet + [DataNumber];
      END
  UNTIL NOT HasData;
END;


FUNCTION GotInstructions: boolean;
BEGIN
  ClearScreen;
  Writeln (
'The current marker of the start of a CRT data field is a "', DataMark, '".');
  IF Yes ('Do you wish to change this character')
    THEN BEGIN
      Write ('Please type the new field start character:  ');
      Read (DataMark);
    END;
  IF NOT OpenTextFile 
     ('What is the name of the file containing the desired mask?', InfileName, 
       GetOld, 0, Infile)
    THEN GotInstructions := false
    ELSE BEGIN
      GotInstructions := true;
      Gotoxy (0,6);
      Writeln (
    'The file ', DFileName, ' now contains ', NoOfDataRecords, ' records.');
      ch := '0';    {dummy character}
      IF NoOfDataRecords > 0
        THEN BEGIN
          Writeln ('Where would you like to write this mask?');
          Writeln ('     N)ext new record in file.');
          Writeln ('     C)orrect previously existing record.');
          REPEAT Read (ch) UNTIL (ch IN ['C', 'c', 'N', 'n']);
          Writeln;
        END;
      ThisRecordNo := NoOfDataRecords;  {record no's start at 0, remember}
      IF (ch IN ['N', 'n']) OR (NoOfDataRecords = 0)
        THEN NoOfDataRecords := NoOfDataRecords + 1
        ELSE BEGIN
          IF NoOfDataRecords = 1 
            THEN ThisRecordNo := 0
            ELSE BEGIN
              Write ('Then what record number would you like ',
                     'to replace (0 TO ', NoOfDataRecords-1, ')?   ');
              GetInteger (-1, -1, 0, NoOfDataRecords-1, true, ThisRecordNo);
              Writeln;
            END
        END;
    END
END;
    

PROCEDURE PrintMask;
BEGIN
  Writeln (List, '      C R T   M A S K   G E N E R A T O R   U T I L I T Y',
'   (c) 1980 by DATAMED RESEARCH.');
  Writeln (List, 'Source Textfile = ', InFileName,
'    Mask File = ', DFileName, '    Mask Number = ', ThisRecordNo);
  Writeln (List);
  Writeln (List,
'   Y  X:0....5...10....5...20....5...30....5...40....5...50....5...60',
'....5...70....5..79');
  FOR i := 0 TO MaxY DO
    BEGIN
      Write (List, i:4, '   !', Mask.Line [i,0]);
      FOR j := 1 TO MaxX DO 
        IF (Mask.Line [i,j] = ' ') AND (j MOD 10 = 0) 
            AND (Mask.Line [i,j-1] = ' ') 
          THEN Write (List, '!') 
          ELSE Write (List, Mask.Line [i,j]);
      Writeln (List, '!');
    END;
  Writeln (List, 
'       !:....,....:....,....:....,....:....,....:....,....:....,....:',
'....,....:....,....!');
  Writeln (List);
  Writeln (List, 'FIELD NUMBER  ', 'X COORDINATE   ':13, 'Y COORDINATE   ':16,
         'FIELD END':10, 'LENGTH':9, 'DECIMAL PLACES':20);
  FOR i := 1 TO MaxData DO WITH Mask.Data [i] DO IF Lngth > 0 THEN
    Writeln (List, i:6, X:16, Y:16, (X + Lngth -1):12, Lngth:10, Decimal:16);
  Page (List);
END;
           

PROCEDURE ProcessAMask;
BEGIN
IF TESTING THEN WRITELN ('CURRENT RECORD NO. = ', THISRECORDNO);
  Seek (DataFile, ThisRecordNo);
  NumberSet := [];
  FOR i := 0 TO MaxY DO FOR j := 0 TO MaxX DO Mask.Line [i,j] := ' ';
  FOR i := 1 TO MaxData DO WITH Mask.Data [i] DO
    BEGIN
      X := 0;
      Y := 0;
      Lngth := 0;
      Decimal := 0;
    END;
  i := 0;
  WHILE NOT eof (Infile) AND (i <= MaxY) DO 
    BEGIN
      Readln (Infile, TextBuf[i]);
      FOR j := 1 TO Length (TextBuf [i]) DO Mask.Line [i,j-1] := TextBuf [i,j];
      TranslateCRTData (i);
      i := i + 1;
    END;
  DataFile^ := Mask;
  Put (DataFile);
  IF Yes ('Would you like to print this mask <if so, have printer ready..>')
    THEN PrintMask;
  CLOSE (Infile);
  Write ('Process complete.  ');
END;


BEGIN
  OpenDataFile;
  Rewrite (List, 'PRINTER:');
  DataMark := DefaultMark;
  REPEAT IF GotInstructions THEN ProcessAMask
  UNTIL NOT Yes ('More masks to do');
  CLOSE (DataFile, Lock);
END.
  

========================================================================================
DOCUMENT :usus Folder:VOL05:monaco.doc.text
========================================================================================


                       Monaco's Fmt  and Other Gems...


                                  edited by


                              Francis J. Monaco




                         Introduction to this Volume

     Hopefully, this volume contains something for everyone in the wonderful
world of UCSD PASCAL! From an interactive textformatter to a really fine disk-
memory-patch and dump routine, an attempt to include a wide variety of really
useful stuff has been made. The source code is included in all cases except
for the textformatter; interested personnel should contact the author for
information on obtaining the source to "FMT"... 


                   
                            Small Database System
                   

     "ADDRS.DOC" contains instructions on how to use STRUCT, UPDATE, and
GETSORT; basically, these programs allow ISAM updates, sorts, etc. on a large
user defined "database". Because update uses the foreground and background
intensity levels of display capabilities of the Hazeltine 1510 terminal, the
user should get into the variable definitions at the start of the main program
and redefine some values (all well documented). Other than a dual floppy
system and a printer on line (the printer code can be easily removed), these
programs require little else except compilation. 


                                                       
                        Monaco's Interactive Formatter
                                                       



     The file "READ.FMT" is a printable user manual for using the the code
files "FMT.1.5.CODE" and "FMT.20.CODE". The user should look at "SP.TEXT" in
the editor, and modify it to work with his/her printer; then try SP on
"READ.FMT" (since it contains FORTRAN carriage controls which must be con-
verted to ASCII: an extremely simple task). Once you have a copy of the
READ.FMT in hand, print the input files "USER.IN2" and "USER.A2" and study the
input to "FMT" along-side the output from "FMT".  The author would appreciate
feedback from users of "FMT", as it might one day become a saleable product.
By the way, "FMT.EXAMP" is another example input file to "FMT". 


                     
                         Fantastic Disk Patch Utility
                     



     See "READ.DISKR" for instructions on this fine bit of programming. The
compiliable version is "DISKREAD" and will work on any system, including
knowledge of terminal control features (it reads SYSTEM.MISCINFO!). 


                                      
                Change Crummy Identifiers to Nice Identifiers
                                      



     The file "ID2D" is a terminal-independent version of PUG's ID2D, a very
clean balanced AVL tree implementation of a program to change all PASCAL
identifiers in one program into new identifiers in a new program.  Self
prompting. Requires a file containing the old identifiers, new identifiers as:



                                 
                              oldid1, newid1
                              oldid2, newid2
                              oldid3, newid3
                                 


                                 

     as well as a file containing the program to be changed. Errors go to the
screen. Very clean... 


                                       
                           Miscellaneous Good Stuff
                                                      



     "DIR" reads a directory from the command level of the UCSD PASCAL system;
"FAST.PG" solves the problem of an extremely fast program perusal using
blockreads and unitwrites to the console; "UNIT.GOOD.TEXT" is a unit that con-
tains very good stuff like: a procedure to get the system date; a procedure to
read in a string without bombing; a procedure to open a file for reading or
writing that will provide you with a directory if you forget the file name
(under program control) and give you unlimited chances; and best of all, a set
of two procedures that will read in "SYSTEM.MISCINFO" and allow the user to
use procedure calls like: 


      
                               crt ( eraseol ) 
                               crt ( eraseos )
                                 crt ( left )
                                crt ( right )
      


      

     etc. anywhere in the program. This is not dependent on anything except
the data in SYSTEM.MISCINFO; therefore, all terminals will respond correctly
to these "crt" calls (as long as "getcrtinfo" has been invoked!) This unit was
named "goodstuff" and when you see it, you'll know why! Added goodie for LSI-
11 interps: change the line "ALOCK:.BYTE0" to "ALOCK:.BYTE-1" in IOTRAP and
rebuild the interpreter to preclude having to type control-r to get lower
case! 


                                                     
                   Please send comments and suggestions to:

                                Francis J. Monaco
                                   Cpt, US ARMY
                   Department of Geography and Computer Science
                        The United States Military Academy
                            West Point, New York 10996
                                                 
                                                     

========================================================================================
DOCUMENT :usus Folder:VOL05:peek.poke.text
========================================================================================

{This program demonstrates how to bend the Pascal language
into doing the BASIC equivalent of 'PEEK' and 'POKE' on a
PDP-11.  Program permits direct inspection and alteration of
memory locations}

PROGRAM PEEKANDPOKE;
CONST BS=8;
VAR P: RECORD CASE INTEGER OF
         1: (I: INTEGER);
         2: (P: ^INTEGER) 
         END;
    A,V: INTEGER;
    I: INTERACTIVE;
    

 PROCEDURE READO(VAR N: INTEGER);
 VAR K: INTEGER;
     C: CHAR;
 BEGIN (* READO *)
  K := 0;
  N := 0;
  WHILE I^ IN ['0'..'7',CHR(BS)] DO
   BEGIN C := I^; 
    IF C = CHR(BS) THEN
     BEGIN
      IF K > 0 THEN
       BEGIN WRITE(CHR(BS)); K := K - 1; N := N DIV 8 END
     END
    ELSE
     BEGIN WRITE(C); K := K + 1; N := N * 8 + ORD(C) - ORD('0') END;
    GET(I)
   END
 END (* READO *);
 
 
 PROCEDURE READB(VAR N: INTEGER);
 VAR K: INTEGER;
     C: CHAR;
 BEGIN (* READB *)
  K := 0;
  N := 0;
  WHILE I^ IN ['0'..'1',CHR(BS)] DO
   BEGIN C := I^; 
    IF C = CHR(BS) THEN
     BEGIN
      IF K > 0 THEN
       BEGIN WRITE(CHR(BS)); K := K - 1; N := N DIV 2 END
     END
    ELSE
     BEGIN WRITE(C); K := K + 1; N := N * 2 + ORD(C) - ORD('0') END;
    GET(I)
   END
 END (* READB *);
     

 PROCEDURE WRITEO(N: INTEGER);
 VAR I: INTEGER;
     C: CHAR;
 BEGIN (* WRITEO *)
  IF N < 0 THEN
   BEGIN WRITE('1'); N := N + 32767 + 1 END
  ELSE WRITE('0');
  I := 4096;
  REPEAT WRITE(CHR(N DIV I MOD 8 + ORD('0')));
   I := I DIV 8
  UNTIL I = 0
 END (* WRITEO *);
 
 
 PROCEDURE WRITEB(N: INTEGER);
 VAR I: INTEGER;
 BEGIN (* WRITEB *)
  IF N < 0 THEN
   BEGIN WRITE('1'); N := N + 32767 + 1 END
  ELSE WRITE('0');
  I := 16384;
  REPEAT WRITE(CHR(N DIV I MOD 2 + ORD('0')));
   I := I DIV 2
  UNTIL I = 0
 END (* WRITEB *);


BEGIN (* PEEK AND POKE *)
 RESET(I,'SYSTERM:');
 P.I := 0; WRITEO(0);
 WHILE NOT EOF(I) DO
  BEGIN WRITE('='); WRITEB(P.P^);
   GET(I);
   IF I^ IN [' ','/','0','1','2','3','4','5','6','7','^'] THEN
    CASE I^ OF
     ' ': BEGIN IF EOLN(I) THEN WRITELN ELSE WRITE(' ');
           P.I := P.I + 1;
           WRITEO(P.I)
          END;
     '/': BEGIN WRITE('/'); GET(I); READB(V);
           IF I^ = ' ' THEN
            BEGIN P.P^ := V; 
             IF EOLN(I) THEN WRITELN ELSE WRITE(' ');
             P.I := P.I + 1;
             WRITEO(P.I)
            END
           ELSE
            BEGIN WRITELN; WRITEO(P.I) END
          END;
     '0','1','2','3','4','5','6','7':
          BEGIN WRITE(' '); READO(A);
           IF I^ = ' ' THEN
            BEGIN P.I := A;
             IF EOLN(I) THEN
              BEGIN WRITELN; WRITEO(P.I) END
            END
           ELSE
            BEGIN WRITELN; WRITEO(P.I) END
          END;
     '^': BEGIN P.I := P.P^;
           WRITELN;
           WRITEO(P.I)
          END
     END
    ELSE
     BEGIN WRITELN; WRITEO(P.I) END
  END
END (* PEEK AND POKE *).
    
    

========================================================================================
DOCUMENT :usus Folder:VOL05:quicksort.text
========================================================================================


{Benchmark program using the Quicksort algorithm.  Does nothing useful
here except chew up CPU cycles, but the algorithm is useful in lots of
sorting applications.}

(*$R+*)
PROGRAM QUICKSORT;
  CONST N = 10000;
  VAR I,Z: INTEGER;
      A: ARRAY [1..N] OF INTEGER;
  PROCEDURE SORT( L,R: INTEGER );
    VAR I,J,X,W: INTEGER;
  BEGIN
  I := L; J := R; X := A[(I+J) DIV 2];
  REPEAT
    WHILE A[I] < X DO I := I+1;
    WHILE A[J] > X DO J := J-1;
    IF I <= J THEN 
      BEGIN W := A[I]; A[I] := A[J]; A[J] := W;
      I := I+1; J := J-1
      END
    UNTIL I > J;
  IF L < J THEN SORT( L, J );
  IF I < R THEN SORT( I, R )
  END (* SORT *) ;

BEGIN (* MAIN *)
Z := 113;
FOR I := 1 TO N DO
  BEGIN
  Z := (131*Z+1) MOD 221; A[I] := Z
  END;
WRITE('TYPE <CR> TO SORT...'); READLN;
SORT( 1, N );
WRITELN( CHR(7), 'ALL DONE AGAIN.' )
END.

========================================================================================
DOCUMENT :usus Folder:VOL05:read.diskr.text
========================================================================================






         
























                         Disk Block Read/Write/Modify


                                      by


                                Roger L. Soles


                       Georgia Institute of Technology
                                  Box 36177
                              Atlanta, GA  30332





















1






              Disk Block Read/Write/Modify (afterwards referred to as
         "DISKREAD") is a system utility program  designed  to  allow
         the knowledgable user a means through which he can read  in-
         formation  from disk, modify that information, and place  it
         back onto the disk. It's primary design purpose is to  allow
         the user to make quick disk patches, either  in  his  system
         files, or any other file.  (Basically,  a  very  smart  DUMP
         facility with dynamic disk and RAM updating capability! - F.
         Monaco). 


         
                                  WARNING!  
         

              This program can totaly obliterate the  information  on
         the disk (and RAM), and therefore it must be  considered  as
         dangerous to the unfamiliar user - please acquaint  yourself
         with it's operation before proceeding to utilize it. 

              The screen consists of several distinct fields: 

              1) The upper part of the screen will have a  field  in-
         dicating  the current block number and the current unit  (or
         volume) number in both decimal and hex, as a rule quantities
         that "DISKREAD" displays will  always  be  in  hex.  Between
         these is an indicator, either HEX or ASCII, this  refers  to
         the mode in which the data from the  disk  block  is  to  be
         displayed. 

              2) A command prompt line: all commands and  user  input
         quantities will be entered here. When the  cursor  is  here,
         "DISKREAD" is waiting for a user input. 

              3) The disk block buffer area. This area is bounded  by
         a row and a column of numbers, the  actual  address  of  any
         byte in the buffer is the logical sum of the two quantities,
         and thus a little knowledge about  hexidecimal  addition  is
         needed to utilize the displayed information efficiently. The
         contents of the buffer are displayed in the current mode. In
         ASCII mode, only legal ASCII characters are displayed;  that
         is ' '..'}'; all other ASCII codes are displayed as blanks. 

              The commands of "DISKREAD" are: 


                                     
                       1) Set ASCII display mode : 'a'
                                     

              This command will immediately display the  contents  of
         the disk block buffer in ASCII and set the mode indicator to
         show this. 



                                    - 1 -                              
1

         Diskread                                         30 Apr 1980 



           
                    2)  Set HEXIDECIMAL display mode : 'h'
           

              This command will immediately display the  contents  of
         the disk block buffer in hex and set the mode  indicator  to
         show this. 


           
                          3)  READ a disk block : 'r'
           

              This command will cause "DISKREAD" to read in the  disk
         block specified by the current blocknumber from  the  volume
         specified in the current unitnumber. If the I/O  process  is
         not complete, "DISKREAD" alerts the  user  and  displays  an
         error message, hit RETURN to continue. 


                                       
                      4)  WRITE the buffer to disk : 'w'
                                       

              This command will cause "DISKREAD"  to  write  out  the
         contents of the buffer to the block specified by the current
         block number on the volume specified  by  the  current  unit
         number. Before the process is completed,  verification  from
         the user is requested, typing anything  except  'y'  or  'Y'
         will abort the process. 


                        
                                  WARNING!  
                        

              This is the only dangerous command in "DISKREAD",  once
         a buffer has been written to disk, the information that  was
         prevously in the block on the disk is lost! 

              If the I/O process is not complete,  "DISKREAD"  alerts
         the user and  displays  an  error  message,  hit  RETURN  to
         continue. 


          
                     5) INCREMENT disk block number : '+'
          

              This command will increment the current blocknumber  by
         one each time it is pressed. If the blocknumber exceeds  the
         MAXBLOCKS on the disk, the number wraps around to zero.  For
         convenience the ';' may also be used so that the  user  does
         not have to hit the shift key. 



                                    - 2 -                              
1

         Diskread                                         30 Apr 1980 



                               
                     6) DECREMENT disk block number : '-'
                               

              This command will decrement the current blocknumber  by
         one each time it is pressed. If the blocknumber  goes  below
         zero,  then  number  wraps  around  to  the  MAXBLOCKS.  For
         convenience, if the keyboard is shift locked,  the  '='  may
         also be used. 


              
                        7) Set the BLOCK NUMBER : 'b'
              

              This command allows the  user  to  enter  the  absolute
         block address directly in  either  hexidecimal  or  decimal,
         default is decimal, but a '$' anywhere in  the  input  field
         will cause the number to be processed as a hex number  (this
         is true of all numeric  input).  Special  Note:  users  with
         mini-floppies or hard disks will have to change the constant
         in the beginning of "DISKREAD" to reflect the correct number
         of blocks! 


           
                         8) Set the UNIT NUMBER : 'u'
           

              This command allows the user to enter the volume number
         on which further operations are to take place, if the number
         entered is not a vailide block device then the default value
         of four is substituted - no error message is given! 


                                                    
                     9) CHANGE buffer byte by byte : 'c'
                                                    

              This command allows the user to change the buffer  con-
         tents  byte by byte. The user is first ask  for  a  starting
         address at which the changes are to  begin,  then  he  enter
         each change. The displayed numbers are the current  address,
         and the value of the buffer at that  address.  To  terminate
         the change mode, simply type return with no other entry. 


                                                         
                           10) STRING CHANGES : 's'
                                                         

              This command allows the user to chage the  buffer  con-
         tents  to values which are equivalent to  an  input  string.
         The user is ask to supply a starting address for the  string
         and the string, the change takes up as  many  bytes  as  are


                                    - 3 -                              
1

         Diskread                                         30 Apr 1980 



         needed for the string, trailing blanks are significant! 


                                                        
                           11) MEMORY UPDATE : 'm'
                                                        

              This command allows the user to change large amounts of
         the buffer with a single command. The starting address,  the
         ending address, and the value to update the buffer  to  must
         be supplied when  requested,  if  the  starting  address  is
         larger than the ending addres the proccess is aborted. 


                                                       
                                12) QUIT : 'q'
                                                       

              This command terminates "DISKREAD", the buffer  is  not
         saved automatically! 


                     
                           Some General Suggestions
                     

              Numeric inputs may be either hex or decimal,  generally
         error messages are not given, "DISKREAD" assumes the user is
         very familar with this program, and that he  simply  made  a
         typing error, any  quantity  may  be  corrected  before  the
         return key is hit by simply back spacing, and  either  upper
         of lower case characters can be used for  commands  and  hex
         digits. 


        
                   Please send comments and suggestions to:
        


        
                                Roger L. Soles
        
                       Georgia Institute of Technology
        
                              Atlanta, GA  30332
        


        


        
                                   NOTICE:
        


                                    - 4 -                              
1

         Diskread                                         30 Apr 1980 






              This program is for free  distribution  ONLY,  and  the
         copyright notice and author name may not be removed! 

========================================================================================
DOCUMENT :usus Folder:VOL05:read.fmt.text
========================================================================================






         















                   UCSD PASCAL Textformatter User's Guide
+                  UCSD PASCAL Textformatter User's Guide
+                  UCSD PASCAL Textformatter User's Guide
+                  UCSD PASCAL Textformatter User's Guide




                                    "Fmt"


                                 Version 2.1




                                      by




                              Francis J. Monaco
+                             Francis J. Monaco
+                             Francis J. Monaco
+                             Francis J. Monaco





















                                 24 Apr 1980                           
1







                                Introduction
+                               ____________
+                               ____________
+                               ____________



              "Fmt" is a Pascal Program specifically written for  the
         University of California at  San  Diego's  PASCAL  Operating
         System "USCD PASCAL." "Fmt" is designed  to  facilitate  the
         preparation of neatly formatted documents, letters, reports,
         etc. "Fmt" allows the user to input a text  file  using  the
         UCSD screen editor without concern  of  margins,  centering,
         etc.; by interspersing a  few  "imbedded"  commands  in  the
         input text file, the user is able to tell "fmt"  what  needs
         to be done to the text being processed. By studying the "in-
         put"  to "fmt" alongside the "output" from "fmt",  the  user
         can easily modify the text to look exactly as he wants  with
         a minimum effort. The "output" of "fmt" is  a  ".text"  file
         containing FORTRAN carriage controls;  this  output  can  be
         funneled through a program  like  "sp"  to  convert  FORTRAN
         carriage controls to Line Printer  controls  (more  on  this
         later). 

              "Fmt"  draws   heavily   from   other   textformatters;
         basically, it was designed to include almost  all  the  good
         features found in  other  "word  processing"  systems  while
         simultaneously keeping the program small, easy to  maintain,
         and, above all, easy to modify. "Fmt" provides  many  impor-
+                        easy to modify.                             
+                        easy to modify.                             
+                        easy to modify.                             
         tant  features such  as  automatic  margining,  hyphenation,
         paragraphing,  and  pagination  along  with  "headers"   and
         "footers": basically, everything needed to ease the chore of
         text writing. In addition, "Fmt" enables the user to solicit
         input from multiple files as well  as  from  the  terminal's
         keyboard. 

              The purpose of this guide is to demonstrate the use  of
         "Fmt" to a UCSD PASCAL user. The reader of this  guide  need
         not be familiar with other text formatting  tools;  however,
         it is important that the reader be familiar with UCSD PASCAL
         at least at the novice level. 


                              
                                   Basics
+                                  ______
+                                  ______
+                                  ______
                              

              The file <fmt.code> is the eXecutable file; at the com-
         mand  level of the UCSD PASCAL system, the user should type 


                                                            
                                X for eXecute
+                               X for eXecute
+                               X for eXecute
+                               X for eXecute
                                                            



                                    - 1 -                             
1


         User Guide               Fmt V2.1                 24 Apr 1980





              and when prompted for a file name, the response is 


                                                        
                                 <path>:fmt
+                                <path>:fmt
+                                <path>:fmt
+                                <path>:fmt
                                                        

              where <path> is the UCSD PASCAL unit number  containing
         the file <fmt.code>. If all goes well, "Fmt" will respond: 


                                                           
                Enter title of text file to be formatted --> 
+               Enter title of text file to be formatted --> 
+               Enter title of text file to be formatted --> 
+               Enter title of text file to be formatted --> 
                                                           

              to which the user should respond with  the  name  of  a
         text  file  containing   imbedded   "Fmt"   commands   like:
         <#5:user.in2>. Note that the ".text" must not be  typed.  If
+                                                  not               
+                                                  not               
+                                                  not               
         the file <#5:user.in2.text> exists, "Fmt" will next  respond
         with: 


      
         Enter the title of the formatted text or CR <for CRT> --> 
+        Enter the title of the formatted text or CR <for CRT> --> 
+        Enter the title of the formatted text or CR <for CRT> --> 
+        Enter the title of the formatted text or CR <for CRT> --> 
      

              to which the user must specify a disk file name <to  be
         REWRITTEN>  like:  <#5:user.out2>;  again,  note  that   the
         ".text" is omitted. Typing a carriage return will default to
         sending  output  to  the  CRT  (this  is  good  for  initial
         viewing). Note: do not specify PRINTER: as the output file. 

              Next, "Fmt" will respond with: 


                                    
               ...Monaco's Fmt inititializing... <THEDATE>...
+              ...Monaco's Fmt inititializing... <THEDATE>...
+              ...Monaco's Fmt inititializing... <THEDATE>...
+              ...Monaco's Fmt inititializing... <THEDATE>...
                                    

              where <THEDATE> is the date last  typed  in  the  Filer
         using the D(ate command. "Fmt" spends a few seconds with its
         segemented  procedure  initializations,  and   then   begins
         reading the input file for commands and text, simultaneously
         writing to the output file or CRT. 

              "Fmt" does not incorporate IO checking using  the  UCSD
         Function "IORESULT" and the Compiler  option  (*$I-*).  Such
         code could be added  in  a  later  release;  however,  "Fmt"
         presently gives the user no second  chances  at  interactive
         input. In addition, some of the commands described later  in



                                    - 2 -                             
1


         User Guide               Fmt V2.1                 24 Apr 1980




         this guide  require  TYPED  (in  the  strict  PASCAL  sense)
         arguments; failure to include required command arguments  of
         the correct type will currently result in run-time errors. 


                                                           
                              Commands and Text
+                             _________________
+                             _________________
+                             _________________
                                                           

              "Fmt" defines a "word" as the  contiguous  grouping  of
         characters between blanks or between  end-of-line  character
         and a blank. Thus "." is a word, as  is  "word",  where  the
         double quotes represent blanks. The basic unit  returned  by
         "Fmt's" input routine is a word. Words can  be  either  com-
+                                                                com-
+                                                                com-
+                                                                com-
         mands  or text; Commands always  begin  with  a  period  "."
+        mands  or text;                                             
+        mands  or text;                                             
+        mands  or text;                                             
         usually at the beginning of a line in the input  text  file;
         note that any word beginning with a period found anywhere in
         the input file will be treated as a  command;  thus  "...  "
         cannot be used! An example of a command follows: 


                                                 
                               .tl @Some Title
+                              .tl @Some Title
+                              .tl @Some Title
+                              .tl @Some Title
                                                 

              where "tl" is the 'Command Name', "@Some Title" is  the
         'Command Argument', in this case, a string of characters  of
         'Argument Type' STRING. Note that nothing else  may  legally
         appear on the command line; "Fmt" does not require that com-
         mands  be the first word on a line; however, it  is  a  good
         idea to put commands  on  separate  lines  from  surrounding
         text. Note also that some commands may 'bracket' text  lines
         as: 

                                     .bo 
                              This is text to be
                                  boldfaced.
                                     .bo

              where the command "bo" means boldface  the  text  until
         the next occurence of the command. 

              Some commands have 'defaults', either default values if
         a numeric argument is required, or  default  switches  if  a
         boolean value is appropriate. 

              "Fmt" attempts, in its normal mode, to 'fill'  as  many
         text words between its left and right margins  as  possible.
         Some commands cause the current  'unfilled'  line  preceding
         the command to be forced to the output file; this is  called
         'breaking'. 



                                    - 3 -                             
1


         User Guide               Fmt V2.1                 24 Apr 1980






            
                             Command Description
+                            ___________________
+                            ___________________
+                            ___________________
            

              The following paragraphs in this  User  Guide  describe
         all available commands in "Fmt" including: 

                              1)  COMMAND NAME
+                             1)  COMMAND NAME
+                             1)  COMMAND NAME
+                             1)  COMMAND NAME
                                2)  ARGUMENTS
+                               2)  ARGUMENTS
+                               2)  ARGUMENTS
+                               2)  ARGUMENTS
                                 3)  DEFAULT
+                                3)  DEFAULT
+                                3)  DEFAULT
+                                3)  DEFAULT
                              4)  BREAK CAUSED
+                             4)  BREAK CAUSED
+                             4)  BREAK CAUSED
+                             4)  BREAK CAUSED
                            5)  ACTION OF COMMAND
+                           5)  ACTION OF COMMAND
+                           5)  ACTION OF COMMAND
+                           5)  ACTION OF COMMAND

              By studying the command syntax along with a copy of the
         file  <user.in2.text>,   <user.a2.text>   and   this   guide
         <user.out.text>,  the  user  should  be   able   to   easily
         capitalize on the available features of "Fmt". 

                               Command #1: .pp
+                              Command #1: .pp
+                              Command #1: .pp
+                              Command #1: .pp
         COMMAND:  Startnewparagraph
         ARGUMENTS: None required
         DEFAULT: N/A
         BREAK: Yes
         ACTION:

              Causes the  current  unfilled  line  to  be  forced  to
         output, skipping LINESPACING line(s), and indenting the next
         line PDENT spaces. 

                               Command #2: .ce
+                              Command #2: .ce
+                              Command #2: .ce
+                              Command #2: .ce
         COMMAND: Centeraline
         ARGUMENTS: STRING
         DEFAULT: N/A
         BREAK: Yes 
         ACTION:

              Centers  the  argument  if  possible;  recognizes   the
         character "@" to mean boldface the argument or "_"  to  mean
         underline the argument if and only if the character  appears
         as the first character in the argument string. The  argument
         may appear on the same line or  the  line  immediately  fol-
         lowing  the command. 

                               Command #3: .br
+                              Command #3: .br
+                              Command #3: .br
+                              Command #3: .br
         COMMAND: Breakcurrentline 
         ARGUMENTS: None
         DEFAULT: N/A
         BREAK: Yes 
         ACTION:



                                    - 4 -                             
1


         User Guide               Fmt V2.1                 24 Apr 1980





              Forces the current unfilled text line to be written  to
         the Output File. Note that a new  line  indentation  is  not
         automatically begun; thus the line after a ".br" will  start
         in column 1 instead of in the leftmargin.  The  user  should
         thus combine this command with another like ".pp". 

                               Command #4: .nf
+                              Command #4: .nf
+                              Command #4: .nf
+                              Command #4: .nf
         COMMAND: Donotfilltext 
         ARGUMENTS: String(s) of lines;
         DEFAULT: N/A
         BREAK: Yes 
         ACTION:

              Causes input to be echoed to output without  fill,  but
         each line starting at the LEFTMARGIN. The user  must  insure
         that text will fit between  the  LEFTMARGIN  and  LINEWIDTH.
         Used for tables, etc. Note that this is  a  BRACKET  command
         that is turned off by another occurence of the same  command
         (MUST begin in Column One). Also,  the  line  following  the
         terminal ".nf" will begin in column one, not the leftmargin,
         unless the user provides an additional command like ".pp". 

                               Command #5: .sp
+                              Command #5: .sp
+                              Command #5: .sp
+                              Command #5: .sp
         COMMAND: Skipline 
         ARGUMENTS: None
         DEFAULT: N/A
         BREAK: Yes 
         ACTION:

              Causes the current unfilled line of text to be  written
         to the output file and the next line to be skipped. Each oc-
         curence  of the command skips one line (See Command #28  for
         multiple skips). 

                               Command #6: .so
+                              Command #6: .so
+                              Command #6: .so
+                              Command #6: .so
         COMMAND: Takeinputfromnewfile 
         ARGUMENTS: STRING { '-',  <filename>}
         DEFAULT: N/A
         BREAK: Yes 
         ACTION:

              This command temporarily alters  the  input  stream  of
         "Fmt". It has two options: A) Interactive  Input:  when  the
         argument string contains the character '-', "Fmt" will  stop
         taking input from the original file and begin  taking  input
         from the terminal's keyboard  (until  either  another  ".so"
         command is seen or the user types  ASCII  ETX  (Control  C).
         "Fmt" will discard the last  "word"  typed  before  the  ETX
         before returning to the main input file, so the user  should
         include an extra word like " * " at the end of the last line



                                    - 5 -                             
1


         User Guide               Fmt V2.1                 24 Apr 1980




         of interactive input. In addition, the  user  should  use  a
         ".pr" command to prompt for input at the Console. Note  that
         interactive input makes sense only when writing  to  a  Disk
         File (and using CARRIAGECONTROL). An example of  interactive
         input follows: 
         
         .pr Please type in the name line:
         .so -
         
         { A ? will now appear on the screen. The 
           user should type until finished, 
           adding a "*" at the end, followed by 
           a carriage-return, and last by a 
           CONTROL-C as }
           
          ?  This is the name line *
          { Control- C}
          { "Fmt" now returns to the original input file }
          
               

              B) Input from a New Disk File: when the string argument
         doesn't contain '-' , "Fmt" interprets the String as a  Disk
         Text file (without the ".text") as: #5:new.input. "Fmt" then
         RESETS the new file and begins taking input from it,  remem-
         bering  how to return to the original input  file  when  EOF
         occurs in the new file. 

                               Command #7: .lm
+                              Command #7: .lm
+                              Command #7: .lm
+                              Command #7: .lm
         COMMAND: Setleftmargin 
         ARGUMENTS: INTEGER in the range 1..40
         DEFAULT: 9
         BREAK: No 
         ACTION:

              Alters the value of LEFTMARGIN. 

                               Command #8: .rm
+                              Command #8: .rm
+                              Command #8: .rm
+                              Command #8: .rm
         COMMAND: Setrightmargin 
         ARGUMENTS: INTEGER in the range 40..80
         DEFAULT: 69
         BREAK: No 
         ACTION:

              Alters the value of LINEWIDTH (the  number  of  columns
         between the LEFTMARGIN and RIGHTMARGIN.  For  all  practical
         purposes, LINEWIDTH is the  RIGHTMARGIN  in  the  typewriter
         sense. 

                              Command #9: .hy+
+                             Command #9: .hy+
+                             Command #9: .hy+
+                             Command #9: .hy+
         COMMAND: Onhyphen 



                                    - 6 -                             
1


         User Guide               Fmt V2.1                 24 Apr 1980




         ARGUMENTS: None
         DEFAULT: True
         BREAK: No 
         ACTION:

              Turns on automatic hyphenation (HYNATE := TRUE). 

                              Command #10: .hy-
+                             Command #10: .hy-
+                             Command #10: .hy-
+                             Command #10: .hy-
         COMMAND: Offhyphen 
         ARGUMENTS: None
         DEFAULT: False
         BREAK: No
         ACTION:

              Turns off automatic hyphenation (HYNATE := FALSE). 

                              Command #11: .lpt
+                             Command #11: .lpt
+                             Command #11: .lpt
+                             Command #11: .lpt
         COMMAND: Lineprinter 
         ARGUMENTS: None
         DEFAULT: False
         BREAK: No 
         ACTION:

              Turns on generation of Fortran  Carriage  Controls  '1'
         for ASCII FF, and '+' for CR without LF (CARRIAGECONTROL  :=
         TRUE). Note that the ".lpt"  command  must  be  selected  in
         order to generate BOLDFACE or UNDERLINE. 

                              Command #12: .crt
+                             Command #12: .crt
+                             Command #12: .crt
+                             Command #12: .crt
         COMMAND: Crt 
         ARGUMENTS: None
         DEFAULT: True
         BREAK: No 
         ACTION:

              Turns  off  generation  of  Fortran  Carriage  Controls
         (CARRIAGECONTROL  :=  FALSE).  Also   stops   BOLDFACE   and
         UNDERLINE. 

                              Command #13: .tl
+                             Command #13: .tl
+                             Command #13: .tl
+                             Command #13: .tl
         COMMAND:  Title
         ARGUMENTS: {@STRING} , {_STRING}, {STRING}
         DEFAULT: N/A
         BREAK: Yes: one before and one after Title 
         ACTION:

              Generates a blank line following by  a  centered  title
         followed by a blank line. The characters  "@"  and  "_"  can
         only be used as the first character of the STRING  argument,
         with  "@"  meaning  BOLDFACE  the  STRING  and  "_"  meaning
         UNDERLINE the STRING (as well as center). 



                                    - 7 -                             
1


         User Guide               Fmt V2.1                 24 Apr 1980





                              Command #14: .he
+                             Command #14: .he
+                             Command #14: .he
+                             Command #14: .he
         COMMAND:  Header
         ARGUMENTS: {' S1 '}, {' S1 ' S2 '}, {' S1 ' S2 ' S3 '}
         DEFAULT: N/A
         BREAK: No
         ACTION:

              The next time the HEADER line  is  encountered  in  the
         output file, this command will generate a one, two, or three
         part header. Do not use the Single Quotes (')  for  anything
         but delimiters of the STRING(s). If the  characters  "#"  or
         "^" appear in S1, S2, or S3, they have special meaning:  "#"
         denotes the CURRPAGE; "^" denotes THEDATE. 

              The Header line appears M1 lines from the  Top  of  the
         Page. There are M2 lines between the  Header  line  and  the
         first text line. 

              If more than four single quotes appear in the argument,
         the header will be  blank.  Also,  Headers  can  be  changed
         anywhere in the text. 

                              Command #15: .fo
+                             Command #15: .fo
+                             Command #15: .fo
+                             Command #15: .fo
         COMMAND: Footer 
         ARGUMENTS: See Header, #14.
         DEFAULT:       "
         BREAK:         " 
         ACTION:        

              Same as Header, #14, except that the  Footer  line  ap-
         pears  M3 lines after the last text line on a page of output
         text. There are M4 lines after every Footer until the Top of
         next Page. 
         
                              Command #16: .m1
+                             Command #16: .m1
+                             Command #16: .m1
+                             Command #16: .m1
         COMMAND: Setm1 
         ARGUMENTS: INTEGER in the range 1..5
         DEFAULT: 1
         BREAK: No 
         ACTION:

              Sets the M1 margin (the number of lines between the Top
         of Page and the Header Line). 

                              Command #17: .m2
+                             Command #17: .m2
+                             Command #17: .m2
+                             Command #17: .m2
         COMMAND: Setm2 
         ARGUMENTS: INTEGER in the range 1..10
         DEFAULT: 2
         BREAK: No 
         ACTION:



                                    - 8 -                             
1


         User Guide               Fmt V2.1                 24 Apr 1980





              Sets the M2 margin (the number  of  lines  between  the
         Header and the first line of text). 

                              Command #18: .m3
+                             Command #18: .m3
+                             Command #18: .m3
+                             Command #18: .m3
         COMMAND: Setm3 
         ARGUMENTS: INTEGER in the range 1..10
         DEFAULT: 2
         BREAK: No 
         ACTION:

              Sets the M3 margin (the number  of  lines  between  the
         last text line and the Footer). 

                              Command #19: .m4
+                             Command #19: .m4
+                             Command #19: .m4
+                             Command #19: .m4
         COMMAND: Setm4 
         ARGUMENTS: INTEGER in the range 1..5
         DEFAULT: 1
         BREAK: No 
         ACTION:

              Sets the M4 margin (the number  of  lines  between  the
         Fotter and the Top of the Next Page). 

                              Command #20: .pn
+                             Command #20: .pn
+                             Command #20: .pn
+                             Command #20: .pn
         COMMAND: Setpagenum 
         ARGUMENTS: INTEGER
         DEFAULT: N/A (However, first output page is CURRPAGE := 1).
         BREAK: No 
         ACTION:

              Sets the  value  of  CURRPAGE.  Useful  when  preparing
         documents in many chapters. 

                              Command #21: .pg
+                             Command #21: .pg
+                             Command #21: .pg
+                             Command #21: .pg
         COMMAND: Startpage 
         ARGUMENTS: None
         DEFAULT: N/A
         BREAK: Yes 
         ACTION:

              Breaks the current unfilled line, vertical tabs to  the
         Footer, outputs the Footer, starts a new page,  and  outputs
         the Header of the new page. 

                              Command #22: .bo
+                             Command #22: .bo
+                             Command #22: .bo
+                             Command #22: .bo
         COMMAND: Boldface 
         ARGUMENTS: STRING(s) (of lines)
         DEFAULT: N/A
         BREAK: No 
         ACTION:



                                    - 9 -                             
1


         User Guide               Fmt V2.1                 24 Apr 1980





              BOLDFACEs the  arguments  bracketed  by  the  commands.
         Terminated by another occurence of the command.  Works  only
         with the ".lpt" option. Do not use in Headers,  Footers,  or
         Titles. 

                              Command #23: .ul
+                             Command #23: .ul
+                             Command #23: .ul
+                             Command #23: .ul
         COMMAND: Underline 
         ARGUMENTS: STRING(s) (of lines)
         DEFAULT: N/A
         BREAK: No 
         ACTION:

              UNDERLINES the arguments  bracketed  by  the  commands.
         Terminated by another occurence of the command.  Works  only
         with the ".lpt" option. Do not use in Headers,  Footers,  or
         Titles. 

                              Command #24: .ls
+                             Command #24: .ls
+                             Command #24: .ls
+                             Command #24: .ls
         COMMAND: Setlinespacing 
         ARGUMENTS: INTEGER in the range 1..3
         DEFAULT: 1
         BREAK: No 
         ACTION:

              Alters the current value of LINESPACING. 

                              Command #25: .ps
+                             Command #25: .ps
+                             Command #25: .ps
+                             Command #25: .ps
         COMMAND: Setpagesize  
         ARGUMENTS: INTEGER in the range 30..63
         DEFAULT: 63
         BREAK: No 
         ACTION:

              Alters the value of PAGESIZE, the number of lines on  a
         page counting M1, M2, M3, M4 and the text between.. 

                              Command #26: .pi
+                             Command #26: .pi
+                             Command #26: .pi
+                             Command #26: .pi
         COMMAND: Pindentation 
         ARGUMENTS: INTEGER in the range 1..20
         DEFAULT: 5
         BREAK: No 
         ACTION:

              Alters the value of PDENT, the  number  of  spaces  in-
         dented  whenever a new paragraph is started (with a ".pp"). 

                              Command #27: .ti
+                             Command #27: .ti
+                             Command #27: .ti
+                             Command #27: .ti
         COMMAND: Tindentation 
         ARGUMENTS: INTEGER in the range 1..20
         DEFAULT: N/A



                                    - 10 -                             
1


         User Guide               Fmt V2.1                 24 Apr 1980




         BREAK: Yes 
         ACTION:
This command causes a break followed by  an  indentation  of
         the next line TDENT spaces, where TDENT is the  argument  of
         the command. 

                              Command #28: .sp+
+                             Command #28: .sp+
+                             Command #28: .sp+
+                             Command #28: .sp+
         COMMAND: Skipplus  
         ARGUMENTS: INTEGER in the range 2..50
         DEFAULT: N/A
         BREAK: Yes 
         ACTION:

              This commands breaks  the  current  unfilled  line  and
         skips THESKIP * LINESPACING lines, where THESKIP is the com-
         mand  argument. Note that after this command executes, it is
         necessary to execute a command like ".pp"  to  start  a  new
         line in the LEFTMARGIN. 

                             Command #29: .noadj
+                            Command #29: .noadj
+                            Command #29: .noadj
+                            Command #29: .noadj
         COMMAND: Donotrightadjusttext 
         ARGUMENTS: None
         DEFAULT: False
         BREAK: No 
         ACTION:

              Toggles the value of NOADJ; text from this command 
         foward (until another occurence of the command) will be word
         justified such that if a word is attempted to be added to a 
         line and cannot fit, the line will be broken and the word 
         will begin the next line. This is useful whenever the user 
         wants to give the rightmargin a ragged, typewriter look. 
         Note that the ".noadj" option has been selected for this 
         paragraph as an example. 

                              Command #30: .ne
+                             Command #30: .ne
+                             Command #30: .ne
+                             Command #30: .ne
         COMMAND: Need 
         ARGUMENTS: INTEGER in the Range 1..50 
         DEFAULT: N/A 
         BREAK: Yes 
         ACTION:

              Checks to see whether  the  argument  number  of  lines
         remain in the text portion of a given page before  the  next
         line of input is processed. If not,  a  new  page  is  begun
         before the the line of input is processed. 

                              Command #31: .pr
+                             Command #31: .pr
+                             Command #31: .pr
+                             Command #31: .pr
         COMMAND: Prompt 
         ARGUMENTS: STRING 
         DEFAULT: N/A 



                                    - 11 -                             
1


         User Guide               Fmt V2.1                 24 Apr 1980




         BREAK: Yes 
         ACTION:

              Used just before the ".so -"  command,  this  writes  a
         prompt to the crt if and only if the  ".lpt"  option  is  in
         effect. The user should use this command only when  building
         output text files on disk, as interspersing prompts and text
         on the crt is very confusing. 

                               Command #32: .#
+                              Command #32: .#
+                              Command #32: .#
+                              Command #32: .#
         COMMAND: Comment 
         ARGUMENTS: STRING 
         DEFAULT: N/A 
         BREAK: No 
         ACTION:

              Allows the user to comment the input text file; no  ac-
         tion  is taken with the comment (it  is  ignored  by  "Fmt";
         however, it must be there!) 


                            
                         Helpful Hints on Using Fmt
+                        __________________________
+                        __________________________
+                        __________________________
                            

              Once the user of "Fmt" has studied the  available  com-
         mands  alongside of the input file(s) and output  files,  it
         is necessary to observe a few factors when using "Fmt". 

              First, keep strings of characters less than  TWENTY-ONE
         characters long; otherwise, you'll find that  "Fmt"  does  a
         COBOL-like job of character truncation of the righthand part
         of long strings! 

              Next, realize that the output file will be on the order
         of 3 times larger than the input file; ensure adequate space
         for it to be built. 

              Once your output file is built with "FORTRAN"  carriage
         controls within (using the ".lpt" option), use  the  program
         "SP" to spool your output to your printer. You may  have  to
         tinker with "SP" and your printer to turn off automatic Line
         Feeds at the end of a line (since the "+"  carriage  control
         character, used for  boldfacing  and  underlining,  requires
         only a carriage return). 

              Watch out for  ".nf"  and  ".sp+  <integer>"  commands;
         their behavior is sometimes questionable, and it is best  to
         put a ".pp" after ending a ".nf" or after a ".sp+". 

              Above all, never "nest" any commands  inside  bracketed
+                              "nest"                                
+                              "nest"                                
+                              "nest"                                
         "Fmt" commands (.nf,.bo, etc.). 


                                    - 12 -                             
1


         User Guide               Fmt V2.1                 24 Apr 1980





              Lastly, to learn how to use any textformatter, you must
         study the input alongside the output (that's the third  time
         I've recommended this, please take note!). 




                                           
                            The Future of Fmt...
+                           The Future of Fmt...
+                           The Future of Fmt...
+                           The Future of Fmt...
                                           

              When time permits, the  following  additional  features
         will be added to "Fmt": 1) User defined macros for sequences
         of  "Fmt"  commands.  2)   Tabbing   and   replacement   tab
         characters. 3) IO checking to make it almost  impossible  to
         bomb "Fmt". 4) Character mapping Function  to  enable  upper
         and lower case hyphenation and  commands.  5)  User  defined
         in-line variables. 


                   
                 Where to Send Bug Reports and Suggestions:
+                __________________________________________
+                __________________________________________
+                __________________________________________
                   

                         Address until 14 June 1980:

                              Francis J. Monaco
                               Captain, US ARMY
                               679 Lowell Drive
                           Marietta, Georgia 30060
                                 404-424-1460


                         Address after 14 June 1980:

                              Francis J. Monaco
                               Captain, US ARMY
                 Department of Geography and Computer Science
                      The United States Military Academy
                          West Point, New York 10996
                                 914-938-2063

========================================================================================
DOCUMENT :usus Folder:VOL05:screencntl.text
========================================================================================

SEPARATE UNIT SCREENCONTROL;

  INTERFACE

    PROCEDURE ClearScreen;
    PROCEDURE EraseEOL;
    PROCEDURE GoAndClearLine (y: integer);
    PROCEDURE EraseEOS;

    FUNCTION Yes (Prompt: string) : boolean;


  IMPLEMENTATION

PROCEDURE ClearScreen;
BEGIN
  Page (Output)
END;


PROCEDURE EraseEOL;
VAR ch: PACKED ARRAY [0..1] OF integer;
BEGIN
  ch [0] := 21;
  Unitwrite (1,ch,1)
END;


PROCEDURE GoAndClearLine;
BEGIN
  Gotoxy (0,y);
  EraseEOL
END;


PROCEDURE EraseEOS;
VAR ch: PACKED ARRAY [0..1] OF integer;
BEGIN
  ch [0] := 22;
  Unitwrite (1,ch,1)
END;


FUNCTION Yes { (Prompt: string) : boolean };
VAR ch: char;
BEGIN
  Write (Prompt, ' (Y/N)?  ');
  REPEAT Read (keyboard, ch) UNTIL (ch IN ['Y', 'y', 'N', 'n']);
  CASE ch OF
    'Y', 'y': BEGIN
                Writeln ('Yes');
                Yes := true
              END;
    'N', 'n': BEGIN
                Writeln ('No');
                Yes := false
              END
   END {case}
END;


END. (*end of unit*)


========================================================================================
DOCUMENT :usus Folder:VOL05:sp.text
========================================================================================


PROGRAM SP (*  converts Fortran Carriage Controls inserted by selecting
               the ".lpt" option in "Fmt" to ascii printer controls *);


(*
*******************************************************
*     FORTRAN CARRIAGE CONTROL                        *
*        1....sends    FF                             *
*        +....sends    CR                             *
*******************************************************
*)



VAR 
    FIRSTPART, FILENAME                       : STRING;
    F                                         : TEXT;
    FIRSTPOS, BOLDFACE, FORTRANCONTROLS       : BOOLEAN;
    I                                         : INTEGER;
    CH, LASTCH                                : CHAR;


PROCEDURE PUTP;
EXTERNAL;
(*  ASSEMBLY ROUTINE THAT PUTS ONE CHARACTER 
INTO THE H14'S SERIAL BOARD AT 177514. 
ALSO CHECKS BIT 15 (RTS)  OF 177510 TO
VERIFY STATUS OF FIFO BUFFER.
; THIS PROCEDURE MUST BE ASSEMBLED AND THE ".CODE"
; FILE MUST BE PLACED IN '*SYSTEM.LIBRARY'
;
;
; TESTS H14 INTERFACE SIO AND SENDS ONE 
; CHARACTER TO PRINTER WHEN BOTH TRANSMIT
; STATUS AND RTS (BUFFER) ARE READY
; THIS ALLOWS OPERATION AT 4800 BAUD 
; (MAXIMUM) WITH FULL HANDSHAKING
; 
;
; THIS CODE IS WRITTEN IN UCSD PASCAL 
; ASSEMBLER FOR THE LSI11/2 (HEATHKIT H11A)
; AND MUST BE RE-WRITTEN FOR THE PARTICULAR
; PROCESSOR THE UCSD PASCAL OPERATING SYSTEM
; IS RUNNING UNDER.
;
;
.PROC        PUTP                               ; EXTERNAL PROCEDURE TO PASCAL 
                                                ; HOST
            .PUBLIC        CH                   ; GLOBAL VARIABLE BETWEEN 
                                                ; PASCAL HOST AND "PUTP"               
PRS         .EQU           177510               ; PRINTER RECEIVE STATUS
PXS         .EQU           177514               ; PRINTER TRANSMIT STATUS
PXB         .EQU           177516               ; PRINTER TRANSMIT BUFFER
L1:         TSTB           @#PXS                ; TRANSMIT READY?
            BPL            L1                   ; NO - WAIT
L2:         BIT            #100000,@#PRS        ; RTS READY (FIFO BUFFER)?
            BNE            L2                   ; NO - WAIT
            MOVB           @#CH,@#PXB           ; EVERYTHING READY: PRINT CH
            MOV            (SP)+,R0             ; SET UP RETURN TO PASCAL HOST
            JMP            @R0                  ; AND RETURN
           .END                                 ; END EXTERNAL PROCEDURE



    
                      NOTE!!!  IF YOUR PRINTER DRIVER IS 
                   BOUND IN TO YOUR PASCAL SYSTEM, SUBSTITUTE
                        THE FOLLOWING IN LINE FOR PUTP:
                        
                      SPECIAL NOTE:  IN ORDER FOR THIS TO 
                    WORK, YOUR PRINTER DRIVER MUST BE ABLE 
                     TO UNDERSTAND THE DIFFERENCE BETWEEN 
                      A CARRIAGE RETURN AND A LINE FEED!!!
                       OTHERWISE, REWRITE "PUTP" FOR YOUR
                                   PRINTER!!!

                    PROCEDURE PUTP;
                    VAR
                      CHBUF : PACKED ARRAY [ 0 .. 1 ] OF CHAR;
                    BEGIN
                      CHBUF [ 0 ] := CH;
                      UNITWRITE ( 6, CHBUF, 1 )
                    END;
                                        
                                        
                                       *)




PROCEDURE FORTRAN; (* USES THE CHARACTER IN COLUMN ONE FOR CARRIAGE CONTROL *)

BEGIN
  BOLDFACE := FALSE;
  WHILE NOT EOF(F) DO
    BEGIN
      FIRSTPOS := TRUE;
      WHILE NOT EOLN (F) DO
        BEGIN
          IF FIRSTPOS
            THEN
              BEGIN
                READ(F,CH);
                CASE CH OF
                  '1' : BEGIN    (* TOP OF FORM CASE *)
                          CH := CHR(12);  (*  ASCII FF *)
                          PUTP;
                          FIRSTPOS := FALSE
                        END;
                  '+' : BEGIN    (* OVERSTRIKE CASE *)
                          BOLDFACE := TRUE;
                          FIRSTPOS := FALSE
                        END
                END; (*CASE*)
                IF FIRSTPOS
                  THEN
                    BEGIN
                      LASTCH := CH;
                      CH := CHR(10); (* ASCII LF *)
                      PUTP;
                      CH := LASTCH;
                      PUTP;
                      WRITE(CH);
                      FIRSTPOS := FALSE
                    END;
              END
            ELSE
              BEGIN
                IF BOLDFACE
                  THEN   (* COMPENSATE FOR '+' IN COLUMN ONE *)
                    BEGIN
                      BOLDFACE := FALSE;
                      CH := ' ';
                      PUTP
                    END
                  ELSE
                    BEGIN
                      READ(F,CH);
                      PUTP;
                      WRITE(CH)
                    END
              END
        END;
      READLN(F);
      IF FIRSTPOS 
        THEN
          CH := CHR ( 10 )   (*  ASCII LF *)
        ELSE
          CH := CHR(13);     (*  ASCII CR *)
      PUTP;
      WRITELN;
    END;
END; (* PROCEDURE FORTRAN *)




PROCEDURE GETFILE; (* SOLICIT FILE NAME TO BE PRINTED FROM USER *)

BEGIN
  WRITE('Please enter text file name--> ');
  READLN(INPUT,FIRSTPART);
  FILENAME := CONCAT(FIRSTPART,'.text');
  RESET(F,FILENAME); 
END;

PROCEDURE ASKFORMORE; (* MORE FILES TO PRINT? *)

BEGIN
  WRITE('Do you want to print any more files? ');
  READLN(KEYBOARD,CH);
  CLOSE ( F , NORMAL )
END; (*ASKFORMORE*)



BEGIN (* SP *)


  REPEAT
    GETFILE;
    FORTRAN;
    ASKFORMORE
  UNTIL CH IN ['n','N'];


END. (* SP *)

========================================================================================
DOCUMENT :usus Folder:VOL05:struct.text
========================================================================================


PROGRAM STRUCT; (* BUILDS A STRUCTURED FILE "#5:ADDRESS.TEXT"
                            FROM AN UNSTRUCTURED TEXT FILE "#5:ADDS.TEXT"*)

CONST 
      BLANK = ' ';


 (*    ***********************************************************
      THE FILE "#5:ADDS.TEXT" SHOULD BE BUILT USING THE EDITOR AND
      SHOULD LOOK LIKE THIS:
                              NAMELINE
                              STREETLINE
                              CITYSTATEZIPLINE
                              PHONELINE
                              KEYLINE
                              NEXTNAMELINE 
                                ETC...
      ************************************************************* *)

  TYPE 
       STRUCTURE = RECORD
                     NAME : STRING;
                     STREET : STRING;
                     CITYSTATEZIP : STRING;
                     PHONE : STRING;
                     KEY  : STRING
                   END;

  VAR 
      RECNUM   : INTEGER;
      FID  : FILE OF STRUCTURE;
      S    : STRING;
      FIN  : TEXT;

  PROCEDURE ZEROREC (VAR REC : STRUCTURE);

  BEGIN (* ZEROREC *)

     WITH REC DO
        BEGIN
           NAME := BLANK;
           STREET := BLANK;
           CITYSTATEZIP := BLANK;
           PHONE := BLANK;
           KEY := BLANK
        END;
  END;  (* ZEROREC *)


  BEGIN (* BUILDADDRESS.TEXT *)

     REWRITE(FID,'#5:address.text');

     (*$I+*)
     
     WRITELN ('... Building the structured file ...');
     WRITELN ('... Transferring these records: ');
     WRITELN;

     RECNUM := 0;

     RESET(FIN,'#5:adds.text');

     WHILE NOT EOF(FIN) DO
        BEGIN
           SEEK(FID,RECNUM);
           GET(FID);
           ZEROREC(FID^);
           READLN(FIN,S);
           FID^.NAME := S;

           READLN(FIN,S);
           FID^.STREET := S;

           READLN(FIN,S);
           FID^.CITYSTATEZIP := S;

           READLN(FIN,S);
           FID^.PHONE := S;

           READLN(FIN,S);
           WRITELN(S);
           FID^.KEY := S;
           
           WRITELN;

           SEEK(FID,RECNUM);
           PUT(FID);

           RECNUM := SUCC (RECNUM)
       END;

    CLOSE(FID,LOCK);
    CLOSE(FIN,LOCK);
    
    REWRITE (FIN,'#5:KEYNO.TEXT');
    WRITELN (FIN, RECNUM );
    CLOSE ( FIN, LOCK );
    
    WRITELN; 
    WRITELN (' ... Finished ...');
END. (* PROGRAM BUILDADDRESS.TEXT *)

========================================================================================
DOCUMENT :usus Folder:VOL05:unit.good.text
========================================================================================

(*$S+*)
UNIT GOODSTUFF;


INTERFACE


{ I call these routines GOOD STUFF: they really ease the 
  chore of programming in UCSD PASCAL; I recommend that you 
  try them... you won't be sorry }
  
{ Global stuff.... }
TYPE  (* THIS MUST BE A GLOBAL TYPE!!!!!! *) 
     CRTCOMMAND = (ERASEOS,ERASEOL,UP,DOWN,RIGHT,LEFT,LEADIN);
     FILET = FILE;
     
     DATEREC = PACKED RECORD
                        MONTH: 0..12;
                        DAY: 0..31;
                        YEAR: 0..100
               END;

     DIRRANGE = 0..77;

     VID = STRING[7];
     TID = STRING[15];
     FILEKIND = (UNTYPED,XDISK,CODE,TEXT,
                 INFO,DATA,GRAF,FOTO,SECUREDIR);

     DIRENTRY = RECORD
                  DFIRSTBLK: INTEGER;
                  DLASTBLK: INTEGER;
                  CASE DFKIND:FILEKIND OF
                    SECUREDIR,UNTYPED: 
                                       (DVID:VID;
                                        DEOVBLK,
                                        DLOADTIME,
                                        DBLOCKS:INTEGER;
                                        DLASTBOOT:DATEREC);
                    XDISK,CODE,TEXT,INFO,DATA,
                    GRAF,FOTO: 
                               (DTID:TID;
                                DLASTBYTE:1..512;
                                DACCESS:DATEREC)
                END;

     DIRP = ^DIRECTORY;
     DIRECTORY = ARRAY[DIRRANGE] OF DIRENTRY;


VAR   (* THESE MUST BE GLOBAL VARIABLES !!!!! *) 
    CRTINFO:   PACKED ARRAY[CRTCOMMAND] OF CHAR;
    PREFIXED:  ARRAY[CRTCOMMAND] OF BOOLEAN;
    F : FILE;
    
    DIRX: DIRECTORY;

PROCEDURE GETCRTINFO;
PROCEDURE CRT ( C : CRTCOMMAND );
PROCEDURE DIR;
PROCEDURE GETSTRING ( VAR TYPED: STRING; X, Y, MAXLENGTH : INTEGER);
PROCEDURE GETFILE ( VAR THEFILE : FILET; ISINPUTFILE : BOOLEAN ); 
PROCEDURE GETDATE ( VAR THEDATE : STRING );

IMPLEMENTATION



PROCEDURE GETCRTINFO; (* BY ROGER SOLES, GEORGIA TECH *)
(*  CALL THIS ROUTINE AT THE BEGINNING OF EVERY PROGRAM BEFORE USING "CRT"*)
(*  READ SYSTEM.MISCINFO AND GET CRT CONTROL CHARACTER INFO     *)

VAR 
    BUFFER: PACKED ARRAY[0..511] OF CHAR;
    I, BYTE: INTEGER;
    (* F: FILE; *)

BEGIN
  RESET(F,'*SYSTEM.MISCINFO');
  I := BLOCKREAD(F,BUFFER,1);
  CLOSE(F);
  BYTE := ORD(BUFFER[72]); (* PREFIX INFORMATION BYTE *)
  CRTINFO[LEADIN] := BUFFER[62];
  PREFIXED[LEADIN] := FALSE;
  CRTINFO[ERASEOS] := BUFFER[64];
  PREFIXED[ERASEOS] := ODD(BYTE DIV 8);
  CRTINFO[ERASEOL] := BUFFER[65];
  PREFIXED[ERASEOL] := ODD(BYTE DIV 4);
  CRTINFO[RIGHT] := BUFFER[66];
  PREFIXED[RIGHT] := ODD(BYTE DIV 2);
  CRTINFO[UP] := BUFFER[67];
  PREFIXED[UP] := ODD(BYTE);
  CRTINFO[LEFT] := BUFFER[68];
  PREFIXED[LEFT] := ODD(BYTE DIV 32);
  CRTINFO[DOWN] := CHR(10);
  PREFIXED[DOWN] := FALSE;
END;


PROCEDURE CRT(*C: CRTCOMMAND *); (* BY ROGER SOLES, GEORGIA TECH *)

(*  CRT COMMANDS ARE: ERASEOS,ERASEOL,UP,DOWN,RIGHT,LEFT; CALL
    THIS ROUTINE WITH ONE OF THESE PARAMETERS ANYWHERE AFTER 
    INITIALLY CALLING "GETCRTINFO".        *)

BEGIN
  IF PREFIXED[C]
    THEN
      UNITWRITE(1,CRTINFO[LEADIN],1,0,12);
  UNITWRITE(1,CRTINFO[C],1,0,12);
END;
 
PROCEDURE DIR;

VAR 

    UNITNUM,I: INTEGER;
    BUFR: PACKED ARRAY[0..2048] OF CHAR;
    CHBUF : char;

BEGIN
  repeat
    WRITELN;
    WRITE('Enter unit number for required directory --> ');
    READLN(UNITNUM);
    WRITELN
  until unitnum in [ 4 .. 5 ];
 (*$I-*)
  UNITCLEAR ( UNITNUM );
  UNITREAD(UNITNUM,DIRX[0],2048,2);
  UNITCLEAR ( UNITNUM );
  IF IORESULT <> 0
    THEN
      BEGIN
        WRITELN('Unit not online');
        (*$I+*)
        EXIT(DIR);
      END;
  WITH DIRX[0] DO
    WRITELN('VOL = ',DVID,':');
  FOR I:=1 TO DIRX[0].DLOADTIME DO
    BEGIN
      WITH DIRX[I] DO
        BEGIN
          IF LENGTH(DTID)>0
            THEN
              BEGIN
                WRITE(DTID,' ':16-LENGTH(DTID),DLASTBLK-DFIRSTBLK: 4,'  ');
                WITH DACCESS DO
                  BEGIN
                    WRITE(DAY:3,'-');
                    CASE MONTH OF
                      1: WRITE('Jan');
                      2: WRITE('Feb');
                      3: WRITE('Mar');
                      4: WRITE('Apr');
                      5: WRITE('May');
                      6: WRITE('Jun');
                      7: WRITE('Jul');
                      8: WRITE('Aug');
                      9: WRITE('Sep');
                      10: WRITE('Oct');
                      11: WRITE('Nov');
                      12: WRITE('Dec');
                    END;
                    WRITE('-',YEAR:2,' ':3);
                  END;
                CASE DFKIND OF
                  XDISK: WRITE('Bad block');
                  CODE:  WRITE('Code file');
                  TEXT:  WRITE('Text file');
                  INFO:  WRITE('Info file');
                  DATA:  WRITE('Data file');
                  GRAF:  WRITE('Graf file');
                  FOTO:  WRITE('Foto file');
                END; (* CASE OF *)
                WRITELN;
              END;
        END;
     if i mod 21 = 0
       then
         begin
           writeln;
           write (' tap <space bar> to continue ');
           repeat
             read ( chbuf )
           until chbuf = ' ';
           writeln;
         end;
           
    END;
  WRITELN;
  WRITE (' tap <space bar> to continue ');
  repeat
    read ( chbuf )
  until chbuf = ' ';
  writeln;
END; (*$I+*)

PROCEDURE GETSTRING (*VAR TYPED: STRING; X,Y, MAXLENGTH: INTEGER
                    ( "TYPED" IS THE NEW STRING NAME (DEFINED GLOBALLY
                    OR IN THE CALLING PROCEDURE); X, Y DEFINE THE SCREEN
                    COORDINATES OF THE INPUT POINT; MAXLENGTH DEFINES THE 
                    LENGTH OF THE STRING <MAX YOU WANT> *);
   (* procedure by Jim Gagne, modified <generalized> by Frank Monaco *)
VAR 
    J, K: INTEGER;
    GOTSTRING: BOOLEAN;
    BELL: CHAR;
BEGIN
  BELL := CHR (7);
  GOTSTRING := FALSE;
  REPEAT
    GOTOXY (X,Y);
    FOR J := 1 TO MAXLENGTH DO
      WRITE ('.');
    GOTOXY (X,Y);
    READLN (TYPED);
    K := LENGTH (TYPED);
    IF K > MAXLENGTH
      THEN
        BEGIN
          GOTOXY (X,Y);
          WRITE (' ':K);
          GOTOXY (0,23);
          WRITE (BELL, 'You have entered too many characters in this line.  ',
                        'Please try again.')
        END
      ELSE
        GOTSTRING := TRUE
  UNTIL GOTSTRING;
  GOTOXY ((X+K),Y);
  WRITE (' ':(MAXLENGTH - K));
  GOTOXY (2,22);
  WRITE (' ':70);
  GOTOXY (0,73);
  WRITE (' ':70)
END (*GETSTRING*);


PROCEDURE GETFILE (* VAR  THEFILE  : FILE; ISINPUTFILE: BOOLEAN
                    ( THEFILE IS THE INPUT OR OUTPUT FILE YOU 
                    HAVE GLOBALLY DEFINED (OR DEFINED IN THE CALLING
                    PROCEDURE); ISINPUTFILE IS "TRUE" OR "FALSE" TO
                    TOGGLE RESET/REWRITE...*) ;
(* procedure by Jim Gagne, modified <generalized> by Frank Monaco *)
VAR 
    GOTFN: BOOLEAN;
    BELL, RESPONSE: CHAR;
    FILENAME, FILETYPE, TYPED : STRING;
    
   
   
  BEGIN  (* GETFILE *)
    getcrtinfo;
    BELL := CHR (7);
    REPEAT
     GOTOXY ( 0, 0 );
     CRT ( ERASEOS );
     IF ISINPUTFILE
        THEN
           FILETYPE := 'input'
        ELSE
           FILETYPE := 'output';
    GOTOXY (11,20);
    WRITE ('Please type the name of the desired ', FILETYPE, ' file ');
    GOTOXY (15,21);
    WRITE ('-->      ');
    GOTOXY (11,22);
    WRITE ('  (Or just press the <return> key if you wish to quit.)');
    TYPED := '';
    GETSTRING ( TYPED, 20,21, 23);
    IF LENGTH (TYPED) = 0
      THEN
        BEGIN
          GOTOXY (11,23);
          WRITE ('Would you prefer to quit this program (Y/N)?     ');
          READ (KEYBOARD, RESPONSE);
          GOTOXY (11,23);
          WRITE (' ':47);
          IF (RESPONSE = 'Y') OR (RESPONSE = 'y')
            THEN
              EXIT (PROGRAM)
        END
      ELSE
        BEGIN
          FILENAME := TYPED;
   (*$I-*)
          IF ISINPUTFILE
            THEN
              RESET (THEFILE, FILENAME)
            ELSE
              REWRITE ( THEFILE, FILENAME);
          IF IORESULT > 0
            THEN
               IF ISINPUTFILE
                 THEN
                    RESET (THEFILE, CONCAT (FILENAME, '.TEXT'))
                 ELSE
                    REWRITE ( THEFILE, CONCAT ( FILENAME, '.TEXT') );
    (*$I+*)
          GOTFN := IORESULT = 0;
          IF NOT GOTFN
            THEN
              BEGIN
                GOTOXY (0,23);
                WRITE (BELL, '<<**** ERROR ****>>   ',
                     'Wrong volume or file name.  Type <space> for Directory.');
                REPEAT
                  READ (KEYBOARD, RESPONSE)
                UNTIL RESPONSE = ' ';
                GOTOXY ( 0, 0 );
                CRT ( ERASEOS );
                DIR
              END
        END(*ELSE*)
  UNTIL GOTFN;
END (*GETFILE*);



PROCEDURE GETDATE(*VAR ( RETURNING ) THEDATE: STRING
                  ( THEDATE IS A STRING VARIABLE 
                  DEFINED BY THE CALLING ROUTINE 
                  (OR GLOBALLY) AND WILL LOOK LIKE 
                  THIS WHEN RETURNED: "24 Apr 1980"*); (* ALGORITHM 
                                                          BY ROGER SOLES,
                                                          FRANK MONACO, 
                                                          GEORGIA TECH *)

CONST 
      FIRSTBYTE = 21;
      SECONDBYTE = 22;
      START = 1;
      FINISH = 24;

TYPE 
     RANGE = START .. FINISH;
     ARAYTYPE = PACKED ARRAY [ RANGE ] OF CHAR;

VAR 
    DUMMY : ARAYTYPE;
    HIGH, LOW : INTEGER;
    DAY, MONTH, YEAR: INTEGER;
    CMONTH, CDAY, CYEAR  : STRING;
BEGIN
  UNITREAD( 4, DUMMY, 24, 2);
  HIGH := ORD ( DUMMY [ SECONDBYTE ] ); (* GET THE DATE BYTES INTO HIGH
                                           AND LOW *)
  LOW := ORD ( DUMMY [ FIRSTBYTE ] );
  DAY := ( HIGH MOD 2 ) * 16 + LOW DIV 16;
  MONTH := LOW MOD 16; (* EXTRACT NECESSARY INFO *)
  YEAR := HIGH DIV 2;
  STR ( DAY, CDAY ); (* CONVERT INTEGERS TO STRINGS *)
  STR ( YEAR, CYEAR );
  CASE MONTH OF
    1: CMONTH := 'Jan';
    2: CMONTH := 'Feb';
    3: CMONTH := 'Mar';
    4: CMONTH := 'Apr';
    5: CMONTH := 'May';
    6: CMONTH := 'June';
    7: CMONTH := 'July';
    8: CMONTH := 'Aug';
    9: CMONTH := 'Sept';
    10: CMONTH := 'Oct';
    11: CMONTH := 'Nov';
    12: CMONTH := 'Dec'
  END;

  THEDATE := CONCAT ( CDAY, ' ', CMONTH, ' 19', CYEAR );
END; (* PROCEDURE GETDATE *)

END. { UNIT GOODSTUFF }

========================================================================================
DOCUMENT :usus Folder:VOL05:update.text
========================================================================================


PROGRAM UPDATE;  (* UPDATES DISK FILE "#5:ADDRESS.TEXT": CAN ADD
                              DELETE, OR PRINT RECORDS BASED ON KEY     *)
                            (* REQUIRES "#5:KEYS.TEXT" AND "#5:ADDRESS.TEXT"*)

TYPE 
     KEYRANGE = 0..300;  (* CHANGE THIS IF YOU EXPECT > 300 RECORDS *)
     KEYTYPE = PACKED ARRAY [ KEYRANGE ] OF STRING;
     STRUCTURE = RECORD
                   NAME : STRING;
                   STREET : STRING;
                   CITYSTATEZIP : STRING;
                   PHONE : STRING;
                   KEY : STRING
                 END;

VAR 
    RECNUM, MAXKEYS  : INTEGER;
    FID  : FILE OF STRUCTURE;
    FIN, LP, KEYNO  : TEXT;
    PATTERN, BUFFER   : STRING[80];
    KEYS  : KEYTYPE;
    LF, LI, CH, BELL, ESC,  FG, BG, CS  : CHAR;
    PRINTIT, FINISHED, MUSTRUNKEYIT  : BOOLEAN;

PROCEDURE PUTP;
BEGIN
  WRITE ( LP, CH );
END;
              
PROCEDURE KEYIT;(* CREATES "#5:KEYS.TEXT" CONTAINING THE 
                               KEYS FROM "#5:ADDRESS.TEXT" *)


BEGIN (* KEYSFORADDRESSTEXT *)



   WRITELN (' ... Updating the keys ... ');
   WRITELN;
   RESET ( KEYNO, '#5:KEYNO.TEXT');
   READLN( KEYNO, MAXKEYS);
   CLOSE (KEYNO, NORMAL);
   REWRITE(FIN, '#5:keys.text');
   WRITELN(FIN, MAXKEYS);
   RECNUM := 0;

   RESET(FID,'#5:address.text');

   WHILE ((NOT EOF(FID)) AND (RECNUM <= MAXKEYS)) DO
      BEGIN
         SEEK(FID, RECNUM);
         GET(FID);
         BUFFER := FID^.KEY;
         WRITELN(FIN,BUFFER);
         WRITE  ('.');
         SEEK(FID,RECNUM);
         PUT(FID);
         RECNUM := SUCC(RECNUM)
     END;

   CLOSE(FID,LOCK);
   CLOSE(FIN,LOCK);
END;                         

              

PROCEDURE PRINT ( T : STRING );   (* REMOVE IF NO PRINTER *)

VAR 
    I  : INTEGER;

BEGIN
   FOR I := 1 TO LENGTH ( T ) DO
      BEGIN
         CH := T [ I ];
         PUTP
      END;
  CH := LF;
  PUTP;
END;   (* PROCEDURE PRINT *)

PROCEDURE ZEROREC (VAR REC : STRUCTURE );

CONST 
      BLANK = ' ';

BEGIN
   WITH REC DO
      BEGIN
         NAME := BLANK;
         STREET := BLANK;
         CITYSTATEZIP := BLANK;
         PHONE := BLANK;
         KEY := BLANK
      END;
END; (* ZEROREC *)

PROCEDURE SHOWREC(REC : STRUCTURE);

BEGIN

    WRITELN(LI,CS,BELL);

    WITH REC DO
       BEGIN
          WRITELN(LI, FG, 'Name: ', LI, BG, NAME);
          IF PRINTIT
             THEN
               BEGIN
                  CH := LF;
                  PUTP;
                  PUTP;
                  PRINT (NAME);
               END;


          WRITELN(LI, FG, 'Street: ', LI, BG, STREET);
          IF PRINTIT
             THEN
                PRINT(STREET);

          WRITELN(LI, FG, 'City, State, and Zip: ', LI, BG, CITYSTATEZIP);
          IF PRINTIT
             THEN
                BEGIN
                   PRINT (CITYSTATEZIP);
                   CH := LF;
                   PUTP;
                   PRINTIT := FALSE
                END;

          WRITELN(LI, FG, 'Phone: ', LI, BG, PHONE);

          WRITELN(LI, FG, 'Key: ', LI, BG, KEY);

          WRITELN;

       END;
  END; (* SHOWREC *)

PROCEDURE WRITELIMIT ( LEN : INTEGER );

VAR
   BS : CHAR;
   I : INTEGER;
   
BEGIN
   BS := CHR ( 8 );
   WRITE ( ' ': LEN, '| < -- ' );
   FOR I := 1 TO (LEN + 7) DO
      WRITE ( BS );
   WRITE ( LI, BG, BELL );
END;


PROCEDURE GETREC ( VAR REC : STRUCTURE);

VAR 
    S : STRING;

  FUNCTION READIT (VAR T: STRING): BOOLEAN;

  BEGIN (* READIT *)

     READIT := FALSE;
     READLN(S);

     IF LENGTH(S) > 0
        THEN
           IF S [ LENGTH(S) ] = ESC
              THEN
                 READIT := TRUE
              ELSE
                 BEGIN
                    IF ((T = REC.KEY) AND (LENGTH(T) > 2))
                       THEN
                          BEGIN
                             KEYS [ RECNUM ] := S;
                             T := S;
                             MUSTRUNKEYIT := TRUE
                          END
                       ELSE
                          T := S;
                  END
         END;  (* FUNCTION READIT *)

         BEGIN (* GETREC *)
            WRITELN(BELL);
            WRITELN(LI,FG, BELL, 'RETURN skips item with no change');
            WRITELN('ESC and RETURN skips the whole record', LI, BG, BELL);
            WRITELN;

            WITH REC DO
               BEGIN
                  WRITE(LI, FG, 'Name: '); 
                  WRITELIMIT ( 60 );
                  IF (NOT READIT(NAME))
                     THEN
                       BEGIN
                          WRITE(LI,FG,'Street: ');
                          WRITELIMIT ( 60 );
                          IF (NOT READIT(STREET))
                             THEN
                                BEGIN
                                   WRITE(LI,FG,'CityStateZip: ');
                                   WRITELIMIT ( 60 );
                                   IF (NOT READIT(CITYSTATEZIP))
                                      THEN
                                         BEGIN
                                            WRITE(LI,FG,'Phone: ');
                                            WRITELIMIT ( 60 );
                                            IF (NOT READIT(PHONE))
                                               THEN
                                                  BEGIN
                                                     WRITE(LI,FG,'Key: ');
                                                     WRITELIMIT ( 60 );
                                                     IF (NOT READIT(KEY))
                                                        THEN
                                                           WRITELN;

                                                  END
                                          END
                                 END
                         END
                  END
            END;   (* PROCEDURE GETREC *)

  PROCEDURE SEARCHFORPATTERN;

  BEGIN

    REPEAT
       RECNUM := SUCC(RECNUM)
    UNTIL ((POS(PATTERN,KEYS[RECNUM]) <> 0) OR (RECNUM > MAXKEYS) OR ( FINISHED
          ));

 END;  (* PROCEDURE SEARCHFORPATTERN *)

 PROCEDURE BUFFERKEYS;

 BEGIN
   RESET(FIN,'#5:keys.text');
   RECNUM := 0;
   WRITELN(LI,CS,LI,FG,BELL,BELL);

   WRITELN(' ...  Transferring Keys to RAM ...');
   WRITELN;

   READLN(FIN,MAXKEYS);

   WHILE NOT EOF(FIN) DO
     BEGIN
       READLN(FIN,KEYS [ RECNUM]);
       WRITE('.');
       RECNUM := SUCC(RECNUM)
     END;

   WRITELN;
   WRITELN(LI,BG,BELL);
   CLOSE(FIN,LOCK);
   MAXKEYS := PRED ( RECNUM );
END; (* BUFFERKEY *)

PROCEDURE CHECKFORKEYS;
BEGIN
  WRITE(' Is this the first time through UPDATE? Y/N: ');
  READLN ( CH );
  IF CH IN ['Y', 'y']
    THEN
      KEYIT;
END;



BEGIN   (* UPDATEADDRESS.TEXT *)
  REWRITE ( LP, 'PRINTER:');
  CHECKFORKEYS;
  MUSTRUNKEYIT := FALSE;
  FINISHED := FALSE;
  PRINTIT := FALSE;
  LF := CHR(10);   (* SET LF..BELL = CHR(0)  (OR NULL) FOR DUMB TERMINAL *)
                   (* LF = LINE FEED, LI = LEAD-IN TO THE SCREEN,
                      BG = BACKGROUND FOLLOWS (SINGLE INTENSITY)
                      FG = FOREGROUND FOLLOWS (DOUBLE INTENSITY)
                      ESC = ESCAPE 
                      CS = CLEAR THE SCREEN 
                      BELL = RING TERMINAL BELL
                      
                      NOTE THAT CS ALSO HOMES CURSOR AND THAT
                      "CHR" REQUIRES A DECIMAL ARGUMENT OF THE ASCII
                      CHARACTER (TERMINAL DEPENDENT)*)
  LI := CHR(27);
  ESC := LI;
  BG := CHR(25);
  FG := CHR(31);
  CS := CHR(28);
  BELL := CHR(7);

  BUFFERKEY;

  RESET(FID, '#5:address.text');
  RECNUM := 0;

  WHILE  (( RECNUM >= 0) AND (NOT FINISHED)) DO
    BEGIN
       WRITE(LI,CS,BELL);

       WRITE(BELL,' Enter Key --> ');
       READLN(PATTERN);
       WRITELN;

       IF ((PATTERN = 'STOP') OR (PATTERN = 'stop'))
          THEN
             FINISHED := TRUE;

       IF ((PATTERN = 'PRINT') OR (PATTERN = 'print'))
          THEN
             BEGIN
               PRINTIT := TRUE;
               WRITE(LI,CS,BELL);
               WRITE(BELL, ' Enter Key of Record to be Printed --> ');
               READLN(PATTERN);
               WRITELN
             END;

       RECNUM := -1;

       SEARCHFORPATTERN;

       IF ((RECNUM > MAXKEYS) AND (NOT FINISHED))
          THEN
             BEGIN
                WRITELN(LI,FG,BELL);
                WRITE(BELL, ' Not found. Do you want to 1) Add another record')
               ;
                WRITELN;
                WRITE(BELL,
                      '         **** OR ****             2) Try another key? --> ');
                READLN(BUFFER);
                WRITELN(LI,BG,BELL);

                IF BUFFER = '1'
                   THEN
                      BEGIN
                         WRITELN;
                         MUSTRUNKEYIT := TRUE;
                         MAXKEYS := RECNUM
                      END
              END;
        WRITELN;


       IF ((RECNUM >= 0) AND (RECNUM <= MAXKEYS) AND (NOT FINISHED))
          THEN
             BEGIN
                SEEK(FID,RECNUM);
                GET(FID);
                IF EOF(FID)
                  THEN
                    BEGIN
                      WRITELN(LI,CS,BELL, 'Enter new record...');
                      ZEROREC(FID^)
                    END
                  ELSE
                    BEGIN
                      WRITELN(LI,CS,BELL, 'Old Record...');
                      SHOWREC(FID^);
                      WRITELN;
                      WRITELN(BELL,'Enter Any Changes...')
                    END;
                 GETREC(FID^);
                 SEEK(FID,RECNUM);
                 PUT(FID)
             END
        END; (* WHILE *)
   CLOSE(FID,LOCK);
   WRITELN(LI,CS);
   REWRITE ( KEYNO, '#5:KEYNO.TEXT');
   WRITELN ( KEYNO, MAXKEYS );
   CLOSE ( KEYNO, LOCK );
   IF MUSTRUNKEYIT
     THEN
        KEYIT;
   WRITELN;
   WRITELN (' ... Finished ...');
END.  (* PROGRAM UPDATE *)

========================================================================================
DOCUMENT :usus Folder:VOL06:banner.text
========================================================================================

(*  By David Mundie for Culinary Software Systems.  *)
(*  Types four lines of 32 characters on a hard-copy device.  *)

{   Modified 21 July 1981 by Jim Gagne...Now it 
      a) works on my system,
      b) has meaningful variable & constant names,
      c) fills in more than just a 5x7 matrix, by adding partial dots to fill 
         in diagonals, and 
      d) allows up to 4-size letters just by printing everything up to 4 times.
      
    You'll want to fiddle with this to get it going, as I've changed some 
    things around (eg, adding nulls so as not to overwhelm my printer).
    
    REQUESTS:
      a) increase matrix to a more ample size (at least 7x9)
      b) bring in letter matrix definitions from a file, so we can print block,
         Old English, Roman, etc., letters at a whim.  BEST would be a letter-
         definition program that allowed letter matrices to be entered
         interactively and with character graphics (eg, 7x9 matrix of dots
         on the screen, where a dot would show as "X").
}

PROGRAM banner;
CONST   AbsMaxLine = 5;          {Maximum lines of text - 1}
        MaxChPerLn = 31;         {Max chars per line - 1}
        ColPerCh = 5;            {Columns of dots per character}
        ColPChM1 = 4;            {above -1}
        RowPerCh = 8;            {Rows of dots per character}
        RowPChM1 = 7;            {above -1}
        MaxPixels = 39;          {Dots per character (RowPerCh X ColPerCh -1)}
        HasDiablo = true;        {if so, uses 1/2 linefeeds to fill in char's}

TYPE    pixel = 0..MaxPixels;    {MOD ColPerCh = Column; DIV RowPerCh = Row}
{SO a character grid (upright) looks like:  0  1  2  3  4
...and on its side (the                     5  6  7  8  9
   way it's printed):                      10 11 12 13 14
35 30 25 20 15 10  5  0                    15 16 17 18 19
36 31 26 21 16 11  6  1                    20 21 22 23 24
37 32 27 22 17 12  7  2 (top)              25 26 27 28 29
38 33 28 23 18 13  8  3                    30 31 32 33 34
39 34 29 24 19 14  9  4                    35 36 37 38 39   }

        pixset = set of pixel;

VAR     c: char;
        MaxLine, LinesTyped, n, m: integer;
        SizeFactor: 1..10;
        filename: string;
        message: ARRAY [0..AbsMaxLine,0..MaxChPerLn] OF pixset;
        textin: ARRAY [0..AbsMaxLine] OF string;
        table : ARRAY [' '..'z'] OF pixset;
        list: text;


PROCEDURE initialize;
BEGIN
  table['!'] := [2,7,12,17,32];
  table['A'] := [1..3,5,10,9,14,15..19,20,25,30,24,29,34];
  table['B'] := [0..3,5,10,9,14,15..18,20,25,30,24,29,30..33];
  table['C'] := [1..3,5,10,15,20,25,31..33,29,9];
  table['D'] := [0..2,5,10,15,20,25,30..32,28,24,19,14,8];
  table['E'] := [0..4,5,10,15..19,20,25,30..34];
  table['F'] := [0..4,5,10,15..18,20,25,30];
  table['G'] := [1..4,5,10,15,20,25,31..34,29,24,18..19];
  table['H'] := [0,5,10,15,20,25,30,4,9,14,19,24,34,29,16..18];
  table['I'] := [1..3,7,12,22,17,12,27,31..33];
  table['J'] := [0..4,8,13,18,23,28,31..32,25];
  table['K'] := [0,5,10,15,20,25,30,16,12,8,4,22,28,34];
  table['L'] := [0,5,10,15,20,25,30..34];
  table['M'] := [0,5,10,15,20,25,30,4,9,14,19,24,29,34,6,8,12,17];
  table['N'] := [0,5,10,15,20,25,30,4,9,14,19,24,29,34,11,17,23];
  table['O'] := [1..3,31..33,5,10,15,20,25,9,14,19,24,29];
  table['P'] := [0..3,5,10,15,20,25,30,16..18,14,9];
  table['Q'] := [1..3,5,10,15,20,25,31,32,34,28,22,24,19,14,9,4];
  table['R'] := [0..3,5,9,10,14,19,15..18,20,25,30,22,28,34];
  table['S'] := [1..4,30..33,16..18,5,10,24,29];
  table['T'] := [0..4,7,12,17,22,27,32];
  table['U'] := [0,5,10,15,20,25,31..33,29,24,19,14,9,4];
  table['V'] := [0,5,10,15,20,26,32,28,24,19,14,9,4];
  table['W'] := [0,5,10,15,20,25,31,33,27,22,17,29,24,19,14,9,4];
  table['X'] := [0,5,25,30,4,9,29,34,21,17,13,11,17,23];
  table['Y'] := [0,5,10,16,22,27,32,18,14,9,4];
  table['Z'] := [0..4,30..34,25,21,17,13,9];
  table[' '] :=[];
  
  table['a'] := [11..14,19,21..24,25,29,31..34];
  table['b'] := [0,5,10,20,25,15..18,30..33,24,29];
  table['c'] := [11..13,15,20,25,31..33];
  table['d'] := [4,9,14,15,16..19,31..34,20,25,24,29];
  table['e'] := [11,12,15,18,20..23,25,31,32];
  table['f'] := [2,6,8,11,15..17,21,26,31];
  table['g'] := [11,12,15,18,20,23,26..28,33,36,37];
  table['h'] := [0,5,10,15,20,25,30,16,17,23,28,33];
  table['i'] := [7,16,17,22,27,31..33];
  table['j'] := [8,18,23,28,33,31,37];
  table['k'] := [0,5,10,15,20,25,30,21,17,27,33];
  table['l'] := [1,2,7,12,17,22,27,31..33];
  table['m'] := [11,13,15,17,19,20,22,24,25,29,30,34];
  table['n'] := [11,12,15,18,20,23,25,28,30,33];
  table['o'] := [11,12,15,18,20,23,25,28,31,32];
  table['p'] := [10..12,15,18,20,23,25..27,30,35];
  table['q'] := [11..13,15,18,20,23,26..28,33,38,39];
  table['r'] := [10,12,13,15,16,20,25,30];
  table['s'] := [11..13,15,21..23,29,31..33];
  table['t'] := [6,10..12,16,21,26,32];
  table['u'] := [10,13,15,18,20,23,25,28,31..34];
  table['v'] := [10,14,15,19,20,24,26,28,32];
END;


PROCEDURE Init2;
BEGIN
  table['w'] := [10,14,15,17,19,20,22,24,25,27,29,31,33];
  table['x'] := [10,14,16,18,22,26,28,30,34];
  table['y'] := [10,13,15,18,20,23,26..28,33,36,37];
  table['z'] := [10..14,18,22,26,30..34];
  table['-'] := [16,17,18];
  table['*'] := [7,12,17,22,27,16,18,10,14,20,24];
  table['?'] := [1..3,5,9,13,17,22,32];
  table['.'] := [29,34];
  table[','] := [28,33,37];
  table[':'] := [12,17,27,32];
  table[';'] := table[':'] + [36];
END;


PROCEDURE Show;
VAR     i,CCount,Col,Lines,Row, Size:integer;
        maxlen:integer;


PROCEDURE WriteDot;
VAR     x, y: integer;
BEGIN
  FOR y := 1 TO SizeFactor DO
    BEGIN
      Write(list,'%',CHR(8),'M',CHR(8),'#');
      IF HasDiablo THEN FOR x := 1 TO 8 DO Write(list,CHR(0))
    END
END;


PROCEDURE WriteBlank;
VAR     i: integer;
BEGIN FOR i := 1 TO SizeFactor DO Write(List, ' ') END;


FUNCTION FillLeft: boolean;
VAR     x,              {current pixel}
        y: integer;     {1 pixel to left}
        TCh: pixset;
BEGIN
  IF Row >= RowPChM1 THEN FillLeft := false
  ELSE BEGIN
    TCh := message[Lines,CCount];  x := Row*ColPerCh + Col;  y := x + ColPerCh;
    IF NOT(y IN TCh) THEN FillLeft := false
    ELSE IF Col <= 0 THEN FillLeft := ((x + 1) IN TCh) AND NOT ((y + 1) IN TCh)
    ELSE IF Col >= ColPChM1
      THEN FillLeft := ((x - 1) IN TCh) AND NOT ((y - 1) IN TCh)
    ELSE FillLeft := (((x + 1) IN TCh) AND NOT ((y + 1) IN TCh))
      OR (((x - 1) IN TCh) AND NOT ((y - 1) IN TCh))
  END
END;


FUNCTION FillRight: boolean;
VAR     x,              {current pixel}
        y: integer;     {1 pixel to right}
        TCh: pixset;
BEGIN
  IF Row <= 0 THEN FillRight := false
  ELSE BEGIN
    TCh := message[Lines,CCount];  x := Row*ColPerCh + Col;  y := x - ColPerCh;
    IF NOT(y IN TCh) THEN FillRight := false
    ELSE IF Col <= 0 THEN FillRight := ((x + 1) IN TCh) AND NOT ((y + 1) IN TCh)
    ELSE IF Col >= ColPChM1
      THEN FillRight := ((x - 1) IN TCh) AND NOT ((y - 1) IN TCh)
    ELSE FillRight := (((x + 1) IN TCh) AND NOT ((y + 1) IN TCh))
      OR (((x - 1) IN TCh) AND NOT ((y - 1) IN TCh))
  END
END;

    
BEGIN
  maxlen := 0;
  FOR i := 0 TO LinesTyped-1 DO
    IF length(textin[i]) > maxlen THEN maxlen := length(textin[i]);
  FOR CCount := 1 TO maxlen DO          {write each column of characters}
    BEGIN
      FOR Col := 0 TO 4 DO FOR Size := 1 TO SizeFactor DO {write dot col's}
        BEGIN
          FOR Lines := LinesTyped-1 DOWNTO 0 DO
            BEGIN
              FOR Row := 7 DOWNTO 0 DO
                BEGIN
                  IF Row * ColPerCh + Col IN message[Lines,CCount]
                    THEN FOR i := 1 TO 2 DO WriteDot
                  ELSE IF FillLeft THEN BEGIN WriteDot;  WriteBlank END
                  ELSE IF FillRight THEN BEGIN WriteBlank;  WriteDot END
                  ELSE FOR i := 1 TO 2 DO WriteBlank
                END;
              FOR i := 1 TO 2 DO WriteBlank  {space between lines}
            END;
          IF HasDiablo THEN FOR i := 1 TO 20 DO Write(List,CHR(0));
          Writeln(list)
        END;
      FOR Size := 1 TO SizeFactor DO Writeln(list)
    END;
END;


BEGIN
  FOR n := 0 TO AbsMaxLine DO
    BEGIN
      FOR m := 0 TO 31 DO message[n,m] := [];  textin[n] := ''
    END;
  Initialize;  Init2;  SizeFactor := 1;
  Write(
'By what factor (1 to 4) do you wish to multiply the size of the letters? ');
  Readln(SizeFactor);  MaxLine := AbsMaxLine DIV SizeFactor + 1;
  Writeln(
    'Enter your message (up to ',MaxLine,' lines of up to 32 characters): ');
  n := 0;  
  REPEAT
    Readln(textin[n]);  m := Length(textin[n]);
    IF m > MaxChPerLn THEN DELETE(Textin[n],MaxChPerLn, m - MaxChPerLn + 1);
    n := n + 1
  UNTIL (n > MaxLine) OR (textin[n-1] = ' ') OR (textin[n-1] = '');
  IF (textin[n-1] = ' ') OR (textin[n-1] = '')
    THEN LinesTyped := n-1 ELSE LinesTyped := n;
  Write('Please enter name of output ->  ');  Readln(filename);
{$I-}
  Rewrite(list,filename);
  IF IORESULT > 0 THEN Rewrite(list,concat(filename,'.text'));
{$I-}
  IF IORESULT > 0 THEN Write('Can''t open that file.')
  ELSE BEGIN
    FOR n := 0 TO LinesTyped-1 DO FOR m := 1 TO length(textin[n]) DO
      message[n,m] := table[textin[n,m]];
    Show;
    CLOSE(list,lock);
  END
END.


========================================================================================
DOCUMENT :usus Folder:VOL06:baud.a.text
========================================================================================

        .PROC   BAUD,0
        .PRIVATE OUTC,RETADDR
        .PUBLIC BAUDRATE
TPORT   .EQU    0C0H            ;UART CNTRL 
RPORT   .EQU    TPORT+2         ;RATE GENERATOR TIMER
CPORT   .EQU    TPORT+3         ;MODEM CONTROL

TODTR3  .EQU    07FH            ;NORMAL OP - DTR ON, <300 BAUD
TODTR6  .EQU    05FH            ;NORMAL OP - DTR ON, >300 BAUD
B300    .EQU    52              ;TIMER RATE FOR 300 BAUD
UART    .EQU    5CH             ;8 BITS, NO PARITY, 2 STOP BITS
ANSMODE .EQU    2H              ;RI BIT SETS ANS MODE
ORGMODE .EQU    1H              ;SH BIT SETS ORIG MODE

        POP     HL
        LD      (RETADDR),HL
;  TURN OFF SH AND RI BITS, SET UART MODES
NXT     LD      A,UART
        OUT     (TPORT),A
; SET BAUD RATE
        LD      A,(BAUDRATE)    ; GET RATE
        OUT     (RPORT),A       ;SET NEW RATE
; IF RATE IS ABOVE 300 BAUD CHANGE MODEM RATE BIT
        LD      A,TODTR3        ;FIRST SET IT TO 300 BAUD OR LOWER
        OUT     (CPORT),A
        LD      A,(BAUDRATE)    ;GET RATE
        CP      B300            ;COMPARE TO 300B
        JP      NC,CONT         ;DON'T CHANGE        
        LD      A,TODTR6        ;ABOVE 300
        OUT     (CPORT),A       ; CHANGE RATE BIT
CONT    LD      HL,(RETADDR)
        JP      (HL)
        .END


========================================================================================
DOCUMENT :usus Folder:VOL06:catalog.6.text
========================================================================================

                                VOLUME 6 CATALOG
                             USUS SOFTWARE LIBRARY
                             
                            PTP and FORMAT revisited
   
   Filename     Blocks                          Description
   
PTP.BUSH.TEXT    154      The all-new Pascal Transfer Program, updated by its
                           author, Mark Gang, and edited by Randy Bush.  Baud
                           rate selected by inter-modem dialogue; choice of
                           radix-41 or true binary file transfer; improved al-
                           gorithms speed up data transfer.  PTP has been select-
                           ed as the USUS standard file interchange program.

BAUD.A.TEXT        6      I've added an "A.TEXT" suffix to 8080 assembly-
CTS.A.TEXT         4       language files used by PTP; the function of each
DIALER.A.TEXT      6       routine is described by "PTP-FILES.TEXT".  Note that
DTONEDET.A.TEXT    4       these routines are highly processor- and modem-
DTRON.A.TEXT       4       specific, which is why Bob Peterson is working on a
HANGUP.A.TEXT      4       communications UNIT that will pack all this material
KBSTAT.A.TEXT      4       once and for all into a standardized form.
MODEMINI.A.TEXT    4
MREAD.A.TEXT       4      Rewrite these files for your machine. 
MRECSTAT.A.TEXT    4 
MWRITE.A.TEXT      4 
RI.A.TEXT          4 
RINGING.A.TEXT     4 
SH.A.TEXT          4 

SYSNAME.TEXT       4      User ID (just a few characters) used by PTP.

PTP-FILES.TEXT     8      PTP documentation - which files are which.
PTP-INST.TEXT      6      PTP documentation - how to set it up.
PTP-USE.TEXT      20      PTP documentation - how to use.

FORMAT.TEXT        6      I corrected and greatly updated FORMAT (from USUS Vol.
FORMAT.1.TEXT     16       1), so that now it works reasonably well.  Most bugs
FORMAT.2.TEXT     24       are gone (except the program still has trouble with
FORMAT.3.TEXT     18       extended comments and may terminate prematurely).
FORMAT.4.TEXT     20       Format options are now MENU SELECTED!!  Finally, it
FORMAT.5.TEXT     22       accepts nearly all valid UCSD Pascal syntax.  It is
FORMAT.6.TEXT     24       handy for reformatting Pascal source to fit on CRT
                           screens of different sizes.

FMT.64MASK.DATA    5      Mask for FORMAT menu for 64-column screens.
FMT.64MENU.TEXT    4      Source for above data; needs MAKEMASKS from Vol. 5.
FMT.MASK.DATA      5      This menu mask is for 80-column CRTs and Apples.
FMT.MENU.TEXT      6      Source for the above data; needs MAKEMASKS from Vol 5.
FMT.NEWDOC.TEXT   20      Documentation on my changes to FORMAT.
FORMAT.DOC.TEXT   30      Copy of original FORMAT documentation from Vol. 1.

BANNER.TEXT       20      This program was added 26-Jul-81, and was donated by
                          David Mundie.  Prints a banner vertically on print-
                          out paper, with up to 6 lines or 7-inch letters.

NOTE:  USUS Library material may be used only in accordance with policy outlined
elsewhere.  In particular, these programs may not be given to nonmembers of 
USUS, nor may commercial use be made of them, without the written permission of
the authors.

Although an Apple version of the original PTP is in the works, we will release
the same material for all versions until it works well.  Keep an eye on the USUS
newsletter for corrections and updates.


========================================================================================
DOCUMENT :usus Folder:VOL06:cts.a.text
========================================================================================

        .FUNC   CTS,0
        .PRIVATE RETADDR
STAT    .EQU    0C2H
CARDET  .EQU    4H
        POP     HL
        LD      (RETADDR),HL
        POP     HL              ;CORRECT STACK
        POP     HL
        LD      HL,1            ;TRUE
        IN      A,(STAT)        ;READ STATUS
        CPL
        AND     CARDET          ;CHECK FOR CARRIER
        JP      NZ,DONE          
        LD      HL,0            ;FALSE
DONE    PUSH    HL
        LD      HL,(RETADDR)
        JP      (HL)
        .END


========================================================================================
DOCUMENT :usus Folder:VOL06:dialer.a.text
========================================================================================

        .PROC   DIALER,1
        .PRIVATE DIGIT,RETADDR

TPORT   .EQU    0C0H            ;UART CONTROL/STATUS PORT
RPORT   .EQU    TPORT+2         ;RATE GEN PORT
D10PP   .EQU    250             ;10 PULSES PER SECOND
TRATE   .EQU    250             ;VALUE FOR .1 SECOND DELAY
TMPUL   .EQU    80H             ;TIMER PULSES MASK
MAKEM   .EQU    01H             ;TEL LINE MAKE (OFF HOOK)
BRKM    .EQU    00H             ;TEL LINE ON HOOK
INTER   .EQU    7               ;INTER DIGIT TIME INTERVAL

        POP     HL
        LD      (RETADDR),HL
        POP     HL
        LD      A,L             ; GET DIGIT
        AND     0FH             ;CONVERT TO BINARY
        CP      0H              ; IF 0 CONVERT TO 10
        JP      NZ,DIALS
        LD      A,0AH
DIALS   LD      C,A
; LOAD TIMER WITH DIAL RATE
        LD      A,D10PP
        OUT     (RPORT),A
; WAIT IF TIMER PULSE NOT ZERO
DIALC   IN      A,(RPORT)      ;GET TIMER PULSE
        AND     TMPUL
        JP      NZ,DIALC
;WAIT UNTIL TRANSITION TO 1 TO SYNCHRONIZE DIALER
DIALB   IN      A,(RPORT)
        AND     TMPUL
        JP      Z,DIALB
;
MAKEP   LD      A,MAKEM         ;START WITH A MAKE
        OUT     (TPORT),A
TIMEM   IN      A,(RPORT)
        AND     TMPUL           ;WAIT FOR MAKE INTERVAL
        JP      NZ,TIMEM
;
        LD      A,BRKM
        OUT     (TPORT),A       ;NOW DO A BREAK
;
TIMEB   IN      A,(RPORT)
        AND     TMPUL           ;WAIT FOR BREAK INTERVAL
        JP      Z,TIMEB
;
        DEC     C               ;ANY MORE PULSES IN THIS DIGIT
        JP      NZ,MAKEP        ;IF SO LOOP FOR NEXT PULSE
;
; LAST PULSE WAIT FOR INTERDIGIT TIME
        LD      A,MAKEM
        OUT     (TPORT),A
        LD      B,INTER
; TIMER
TIMER   LD      A,TRATE
        OUT     (RPORT),A
TIMES   IN      A,(RPORT)
        AND     TMPUL
        JP      Z,TIMES
TIMEE   IN      A,(RPORT)
        AND     TMPUL
        JP      NZ,TIMEE
        DEC     B
        JP      NZ,TIMES
DONE    LD      HL,(RETADDR)
        JP      (HL)
        .END


========================================================================================
DOCUMENT :usus Folder:VOL06:dtonedet.a.text
========================================================================================

        .FUNC   DTONEDET,0
        .PRIVATE RETADDR
STAT    .EQU    0C2H
DTONE   .EQU    1H
        POP     HL
        LD      (RETADDR),HL
        POP     HL              ;CORRECT STACK
        POP     HL
        LD      HL,0            ;FALSE
        IN      A,(STAT)        ;READ STATUS
        AND     DTONE           ;CHECK FOR DIAL TONE
        JP      NZ,DONE          
        LD      HL,1            ;TRUE
DONE    PUSH    HL
        LD      HL,(RETADDR)
        JP      (HL)
        .END


========================================================================================
DOCUMENT :usus Folder:VOL06:dtron.a.text
========================================================================================

        .PROC   DTRON,0 
        .PRIVATE RETADDR

TPORT   .EQU    0C0H            ;UART CONTROL PORT
RPORT   .EQU    TPORT+2;        ;TIMER PORT
CPORT   .EQU    TPORT+3         ;MODEM CONTROL
UART    .EQU    5CH             ;8BITS, NO PARITY, 2 STOP BITS
TODTR3  .EQU    07FH            ;NORMAL OP, 300 BAUD
TRATE   .EQU    250             ;TIMER RATE
TMPUL   .EQU    80H             ;TIMER MASK

        POP     HL
        LD      (RETADDR),HL
        LD      A,TODTR3        ;SET DTR ON
        OUT     (CPORT),A
        LD      A,TRATE
        OUT     (RPORT),A
TIMES:  IN      A,(RPORT)       ; DELAY .1 SECONDS
        AND     TMPUL
        JP      Z,TIMES
TIMEE:  IN      A,(RPORT)
        AND     TMPUL
        JP      NZ,TIMEE
        LD      A,UART          ;SET UART TO NORMAL (SH AND RI OFF)
        OUT     (TPORT),A
        LD      HL,(RETADDR)
        JP      (HL)
        .END


========================================================================================
DOCUMENT :usus Folder:VOL06:fmt.64mask.data
========================================================================================

PASCAL TEXT FORMATTER -*- by Mike Condict, modified by Jim Gagne                                                                                                R(ead margins - 1st/last char   A(lign declaratns on column no.                   read: L(eft.     R(ight.        ("0" means no alignment)...                   W(rite margins - output for-    B(unch statements and declaratns                  mat:  L(eft.     R(ight.        together on each line?.....                   S(paces inserted between:       C(ompress program maximally?.                     I(dent's.     S(tatemts.      D(elve into INCLUDE files?...                   I(ndentatn added at new line:   E(nd statement comments?.....                     L(ogical.     O(verflow.      P(rocedure/functn comments?..                   L(ines to skip between proce-   N(umber each line [N(o, place at                  dures/functions.........        R(ight/L(eft margin]?....                                                     #( to start.     J(umping by.                   GLOBALS: 4(0-columns wide; 6(4-columns; 8(0-columns; M(odem Xfer                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                @		==A=A=	;B,=          @       @   @       @                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                         
========================================================================================
DOCUMENT :usus Folder:VOL06:fmt.64menu.text
========================================================================================

PASCAL TEXT FORMATTER -*- by Mike Condict, modified by Jim Gagne
     
R(ead margins - 1st/last char   A(lign declaratns on column no.
  read:^L(eft.^11  R(ight.^12     ("0" means no alignment)...^19  
W(rite margins - output for-    B(unch statements and declaratns
  mat:^ L(eft.^13  R(ight.^14     together on each line?.....^21
S(paces inserted between:^      C(ompress program maximally?.^22
  I(dent's.^15  S(tatemts.^16   D(elve into INCLUDE files?...^28
I(ndentatn added at new line:^  E(nd statement comments?.....^24
  L(ogical.^17  O(verflow.^18   P(rocedure/functn comments?..^23
L(ines to skip between proce-   N(umber each line [N(o, place at
  dures/functions.........^20     R(ight/L(eft margin]?....^25**   
                                #( to start.^26  J(umping by.^27
GLOBALS: 4(0-columns wide; 6(4-columns; 8(0-columns; M(odem Xfer    
^30*************************************************************

 

========================================================================================
DOCUMENT :usus Folder:VOL06:fmt.mask.data
========================================================================================

< binary file -- not listed >

========================================================================================
DOCUMENT :usus Folder:VOL06:fmt.menu.text
========================================================================================

                     PASCAL SOURCE TEXT FORMATTING PROGRAM
                    by Mike Condict...Modified by Jim Gagne

R(ead margins - 1st/last char. read     B(unch statements and declarations
 in a line:^ L(eft..^11   R(ight..^12    together on each line?..........^21
                                        C(ompress program maximally?.....^22
W(rite margins - output formatting:^    D(elve into INCLUDE files?.......^28
 L(eft.........^13    R(ight......^14
                                        comments added automatically at:
S(paces inserted between text items:^    P(rocedure/function BEGIN/END?..^23
 I(dentifiers..^15   S(tatements..^16    E(very compound statement?......^24
 
I(ndentation added at start of line:^   handy commands (affect several params.)
 L(og'l nesting.^17   O(verflow...^18    4(0-column wide    6(4-column wide
                                         8(0-column wide    M(odem transfer
A(lign declarations on column # ("0"
 means no alignment takes place)..^19   N(umber each line [N(o, R(ight margin,
                                         L(eft margin]?..................^25
L(ines to skip between procedures/      #( you wish lines to start with?.^26
 functions........................^20   J(umping in value by what amount.^27
 
^30***************************************************************************

========================================================================================
DOCUMENT :usus Folder:VOL06:fmt.newdoc.text
========================================================================================

             DOCUMENTATION FOR THE REVISED PASCAL SOURCE FORMATTER
       by Michael Condict; published in Pascal News No. 13, December 1978

                Debugged and extensively modified by Jim Gagne 
              Datamed Research, 1433 Roscomare Road, Los Angeles.
                                 28 August 1980

     I've spent a lot of time on FORMAT, and I think that it's safe to say 
that except for the bugs only more extensive use will uncover, it works.  
Programs now will format into compilable textfiles that actually look better
than the original, even if it had been prepared on a good editor.  FORMAT will 
format itself, and the resulting file compiles and executes correctly.

     Briefly, here is what is new.  FORMAT is now menu driven.  It will
reformat programs for any width screen, as well as compressing text for modem
transfer, to be restored by another run at the receiving end.  It will format
correctly nearly all of the variant UCSD features, including UNITs.  At your 
option, it will follow INCLUDE files.  Thus, I hope that it will find maximal
use in transferring textfiles between different systems.  The major remaining
problem with FORMAT is that it is slow; if it becomes popular, someone should
run timing statistics and discover the bottlenecks.

     In more detail, I've modified FORMAT as follows:

     1) The problems with the "range" symbol (".."), due to errors in the
number-processing part of READSYMBOL, have been corrected.

     2) The section of READSYMBOL dealing with comments has been overhauled, 
and it now handles them fairly intellegently.  Both brace- and parenthesis-and-
asterisk-type comment delimiters work properly.  There has been special 
provision made for long comments:  they are reformatted for the proper line 
length, with word boundaries at the ends of lines respected 98% of the time.
Comments are brought to a new line only if they won't fit on the previous one
or if they contain compiler or formatter directives.  Comments at the 
beginning of a program no longer cause FORMAT to die.  Further, since comments
are by no means extraneous to a program, one has the option of retaining them
during maximal program compression by a new command: if both procedure/
function comments and end-symbol comments are enabled, even though they now DO
NOT appear in compressed text, previously typed comments are retained. This
feature was added to aid in the transmission of compressed text by modem,
allowing the correct program to be fully restored by another run of FORMAT.
Finally, no matter what, comments beginning with a compiler directive are
retained in compressed text.

     The only problems I've identified with comments so far are:
        a) if one has a series of long comments within a section that is
normally contained within one line if possible, FORMAT is apt to break this up
into lines beginning with long comments, plus whatever else fits on the line.
Since I usually put comments AFTER the text they refer to, this looks weird.
The problem came up with a lengthy procedure declaration section of a UNIT.
        b) long comments BEFORE a procedure/function declaration are closed up
with the previous section.  Solution: comment your procedures after the
declaration.
        c) many people like to write pretty comments that are themselves 
formatted.  Although the original program preserved the comment structure, it
looked pretty funny when going from a larger to a smaller line size.  Now,
all extraneous ends of lines and spaces are removed, somewhat to the
detriment of such statements as authorship and names and addresses.

     3) Handling of long strings was problematical; they now FORMAT
correctly.  Especially long strings are made flush with the left margin. 
Strings longer than the current maximal line length are broken up into
substrings set off by commas.  Although this will create an error in any but
WRITE statements, it was the most intellegent behavior I could devise.

     4) Assorted typos in my original typed-in version have been corrected.

     5) FORMAT now will handle all the UCSD Pascal variant features, including 
UNITS, SEPARATE UNITS, SEGMENT PROCEDURES/FUNCTIONS, etc., with the exception 
of the INTRINSIC UNITS limited to the Apple version.  This is easily added if 
you wish (at the beginning of the main program).  Of course, standard Pascal 
files also format correctly.

     6) There is one important alteration in procedure WRITEA:  blanks at the 
beginning of new lines are compressed with the UCSD blank-compression code.  
This change occupies one line and is well marked.  It saves oodles of disk 
space.

     7) FORMAT now will incorporate INCLUDE files (i.e., the compiler
directive "I", used in the following format: "{$I<filename>}" or
"(*$I<filename>*)", where "<filename>" refers to any valid UCSD filename,
including if needed volume name or unit number.  Unless a volume is
specified, FORMAT will look on volumes 4 and 5 for the filename if it can't
find it on the default volume.  Comments are printed in the output at the
start and end of an INCLUDED file, and a message noting a new INCLUDE file is 
printed on the console.  

     You may enable or disable FORMAT from acting on INCLUDE directives with
the "D(elve into INCLUDE files" parameter on the menu.  If disabled, INCLUDE 
directives are treated like any other parameter.  Nested INCLUDEs are always
ignored.  If you have enabled INCLUDE files and there is a problem with one,
an error message will be printed on the console, and FORMAT will do as little
damage as possible, restoring the original compiler directive in the output.

     Of course, it is difficult to format an INCLUDE file primarily, since you 
can put virtually anything in an INCLUDE file, so long as the larger program
pieces it together properly.  FORMAT is just as helpless with a fragment of a
program as your compiler is.  If you MUST format an INCLUDE file separately
from its host, you'll have to kludge: the file in question must start out with
either a "PROGRAM" or "UNIT" declaration, then contain some sort of standard
Pascal format.  FORMAT does not check that identifiers have been previously
declared; so only the program structure must be correct.  If your INCLUDE file
does not meet these specifications, you'll have to write a dummy host and
INCLUDE the desired file.

     8) Finally, and by far the most useful feature, is the addition of menu-
selected formatting parameters in a highly user-friendly manner.  Once you've 
read the main FORMAT.DOC documentation, you should find choosing the format 
you desire quite simple.  For those who like single key-stroke parameter 
setting, the global commands 4(0, 6(4, and 8(0-column widths and M(odem 
transfer will select and display a reasonable set of parameters for each of
those situations.

     Several caveats should be observed in using the menu.  First, if FORMAT 
cannot find the file "FMT.MASK.DATA" (a structured binary file that will NOT
look good on your screen or printer) on either units 4 or 5, menu selection
is skipped.  Second, the current FMT.MASK.DATA is designed for 80-column, 24-
line screens, including the standard Apple variant (40 columns with
horizontal scrolling).  There is an alternate file, FMT.64MASK.DATA, designed
for those souls with 16x64 screens, but as the data file is still in 24x80
format (filled in with blanks) you will have to alter the procedure
OPENDATAFILE (part of GETNEWINITVALUES in FORMAT.3.TEXT) to NOT write more
than 64 characters per line nor print more than 15 lines (actually, 13 will
do), or you are apt to have the menu scroll off the screen.  If you then
change the name of FMT.MASK.DATA to something else and rename FMT.64MASK.DATA
as FMT.MASK.DATA, the program should work fine.  Finally, there is no way for
the menu portion to work properly if you do not have a valid GOTOXY bound into
your system.

     If you wish to alter the menu, you will have to use the program MAKEMASKS 
on the UCSD Pascal Users' Library, Volume 5, or write your own.

     
     
     Despite my testing, I'm certain that someone will find problems with 
FORMAT, in view of the extensive changes I've made.  The major remaining area 
I would like to deal with is the aesthetic problem of dangling punctuation, 
caused by a statement that almost but not quite fits on a line; one or two 
characters are apt to hang off the line in a most irritating manner.

     Please let me know if you find bugs and, more importantly, if you can
fix them.  However, make SURE you tell me what the problem is you're fixing
with a bug fix.

     Have fun.

     Sincerely,

                           Jim Gagne, M.D., President
                                Datamed Research
                              1433 Roscomare Road
                             Los Angeles, CA 90024

========================================================================================
DOCUMENT :usus Folder:VOL06:format.1.text
========================================================================================

PROGRAM Format;

CONST  AlfaLeng = 10;
       MinChar = 0;
       MaxChar = 127;   (* minimum/max char values *)
       LastPascSymbol = 31;
       (* if needed, change the values on the following line TOGETHER *)
       BufferSize = 160; BuffSzP1 = 161; BuffSzM1 = 159; BuffSzDiv10 = 16;
       
       MaxReadRightCol = 999;
       MaxWriteRightCon = 72;
       
TYPE  Alfa = PACKED ARRAY [1..AlfaLeng] OF char;
      CharSet = SET OF char;
      StatmntTypes = (ForWithWhileStatement, RepeatStatement,
                      IfStatement, CaseStatement, CompoundStatement,
                      OtherStatement);
      Symbols = (ProgSymbol, UnitSymbol, Comment, BeginSymbol, (* 2 new JLG*)
                 EndSymbol, SemiColon, ConstSymbol, TypeSymbol,
                 RecordSymbol, ColonSymbol, EqualSymbol,
                 PeriodSymbol, Range, CaseSymbol, OtherSymbol,
                 IfSymbol, ThenSymbol, ElseSymbol, DoSymbol,
                 OfSymbol, ForSymbol, WithSymbol, WhileSymbol,
                 RepeatSymbol, UntilSymbol, Identifier,
                 VarSymbol, ProcSymbol, FuncSymbol, SegmntSymbol, 
                 LeftBracket, RightBracket, CommaSymbol,
                 LabelSymbol, LeftParenth, RightParenth, AlphaOperator);
      Width = 0..BufferSize;
      Margins = -100..BufferSize;
      SymbolSet = SET OF Symbols;
      OptionSize = -99..99;
      CommentText = ARRAY [1..BuffSzDiv10] OF Alfa;
      SymbolString = ARRAY [Width] OF char; (*the only UNPACKED char array*)
      
VAR  ChIsEOL, NextChIsEOL: Boolean;
     I, J: Integer (*loop counters *);
     Character: char;
     ReadColumn, ReadRightCol: 0..1000;
     Length, Oldest: Width;
     
     OutputCol, WriteColumn, LeftMargin,
     ActualLeftMargin, ReadLeftCol, WriteLeftCol, WriteRightCol : Margins;
     
     DisplayIsOn, ProcNamesWanted, EndCommentsWanted,
     PackerIsOff, SavedBunch, BunchWanted, NoFormatting: boolean;
     
     LineNumber, Increment: integer;
     
     IndentIndex, LongLineIndent, SymbolGap,
     DeclarAlignment, StatmtSeparation, ProcSeparation: OptionSize;
     
     ThisIsAUnit, SymbolIsNumber, LastProgPartWasBody, LastSymWasRange,  (*JLG*)
       InIncludeFile, ReadIncludeFiles: Boolean;
     LastSymbol, SymbolName: Symbols;
     CharCount: integer;
     AlphaSymbols, EndLabel, EndConst, EndType, EndVar: SymbolSet;
     Symbol: SymbolString;
     Digits, Letters, LettersAndDigits: CharSet;
     Main: CommentText;
     MainNmLength: Width;
     CommentDelimiter: (Brace, ParenAsterisk);                      (*JLG*)
     Blanks, Zeroes: Alfa;
     UnWritten: ARRAY [Width] OF RECORD
                                   Ch: char;
                                   ChIsEndLine: boolean;
                                   IndentAfterEOL: margins
                                 END;
     PascalSymbol: ARRAY [1..LastPascSymbol] OF Alfa;
     PascSymbolName: ARRAY [1..LastPascSymbol] OF Symbols;
     NameOf: ARRAY [Char] OF Symbols;
     StatementTypeOf: ARRAY [Symbols] OF StatmntTypes;
     Infile, IncludeFile, Outfile: text;
     
     
PROCEDURE Const1Init;

BEGIN
  Main [1] := 'MAIN      ';  MainNmLength := 4;
  Blanks := '          ';  Zeroes := '0000000000';
  FOR I := 0 TO BuffSzM1 DO
    WITH UnWritten [I] DO
      BEGIN ch := 'A'; ChIsEndLine := false; IndentAfterEOL := 0
      END;
  FOR Character := Chr (MinChar) TO chr (MaxChar) DO
    NameOf [Character] := OtherSymbol;
  Character := ' '; NameOf ['('] := LeftParenth;
  NameOf [')'] := RightParenth;  NameOf ['='] := EqualSymbol;
  NameOf [','] := CommaSymbol;   NameOf ['.'] := PeriodSymbol;
  NameOf ['['] := LeftBracket;   NameOf [']'] := RightBracket;
  NameOf [':'] := ColonSymbol;   NameOf ['<'] := EqualSymbol;
  NameOf ['>'] := EqualSymbol;   NameOf [';'] := Semicolon;
  PascalSymbol [ 1] := 'PROGRAM   ';  PascalSymbol [ 2] := 'BEGIN     ';
  PascalSymbol [ 3] := 'END       ';  PascalSymbol [ 4] := 'CONST     ';
  PascalSymbol [ 5] := 'TYPE      ';  PascalSymbol [ 6] := 'VAR       ';
  PascalSymbol [ 7] := 'RECORD    ';  PascalSymbol [ 8] := 'CASE      ';
  PascalSymbol [ 9] := 'IF        ';  PascalSymbol [10] := 'THEN      ';
  PascalSymbol [11] := 'ELSE      ';  PascalSymbol [12] := 'DO        ';
  PascalSymbol [13] := 'OF        ';  PascalSymbol [14] := 'FOR       ';
  PascalSymbol [15] := 'WHILE     ';  PascalSymbol [16] := 'WITH      ';
  PascalSymbol [17] := 'REPEAT    ';  PascalSymbol [18] := 'UNTIL     ';
  PascalSymbol [19] := 'PROCEDURE ';  PascalSymbol [20] := 'FUNCTION  ';
  PascalSymbol [21] := 'LABEL     ';  PascalSymbol [22] := 'IN        ';
  PascalSymbol [23] := 'MOD       ';  PascalSymbol [24] := 'DIV       ';
  PascalSymbol [25] := 'AND       ';  PascalSymbol [26] := 'OR        ';
  PascalSymbol [27] := 'NOT       ';  PascalSymbol [28] := 'ARRAY     ';
  PascalSymbol [29] := 'UNIT      ';  PascalSymbol [30] := 'SEGMENT   ';  
  PascalSymbol [31] := 'NOSYMBOL  '; (*JLG*)
END;


PROCEDURE ConstantsInitialization;
BEGIN
  Const1Init;
  PascSymbolName [ 1] :=  ProgSymbol;
  PascSymbolName [ 2] := BeginSymbol;  PascSymbolName [ 3] :=    EndSymbol;
  PascSymbolName [ 4] := ConstSymbol;  PascSymbolName [ 5] :=   TypeSymbol;
  PascSymbolName [ 6] :=   VarSymbol;  PascSymbolName [ 7] := RecordSymbol;
  PascSymbolName [ 8] :=  CaseSymbol;  PascSymbolName [ 9] :=     IfSymbol;
  PascSymbolName [10] :=  ThenSymbol;  PascSymbolName [11] :=   ElseSymbol;
  PascSymbolName [12] :=    DoSymbol;  PascSymbolName [13] :=     OfSymbol;
  PascSymbolName [14] :=   ForSymbol;  PascSymbolName [15] :=  WhileSymbol;
  PascSymbolName [16] :=  WithSymbol;  PascSymbolName [17] := RepeatSymbol;
  PascSymbolName [18] := UntilSymbol;  PascSymbolName [19] :=   ProcSymbol;
  PascSymbolName [20] :=  FuncSymbol;  PascSymbolName [21] :=  LabelSymbol;
  PascSymbolName [29] :=  UnitSymbol;  PascSymbolName [30] := SegmntSymbol;  
  PascSymbolName [31] :=  Identifier;
  FOR I := 22 TO 28 DO PascSymbolName [I] := AlphaOperator;     (*^JLG*)
  FOR SymbolName := ProgSymbol TO AlphaOperator DO
    StatementTypeOf [SymbolName] := OtherStatement;
  StatementTypeOf [ BeginSymbol] :=     CompoundStatement;
  StatementTypeOf [  CaseSymbol] :=         CaseStatement;
  StatementTypeOf [    IfSymbol] :=           IfStatement;
  StatementTypeOf [   ForSymbol] := ForWithWhileStatement;
  StatementTypeOf [ WhileSymbol] := ForWithWhileStatement;
  StatementTypeOf [  WithSymbol] := ForWithWhileStatement;
  StatementTypeOf [RepeatSymbol] :=       RepeatStatement;
END (*ConstantsInitialization*);




========================================================================================
DOCUMENT :usus Folder:VOL06:format.2.text
========================================================================================

PROCEDURE WriteA (Character: char);
VAR  I: Width;
     TestNo: Integer;
BEGIN
  CharCount := CharCount + 1;  Oldest := CharCount MOD BufferSize;
  WITH UnWritten [Oldest] DO
    BEGIN
      IF CharCount > BuffSzP1
        THEN BEGIN
          IF ChIsEndLine
            THEN BEGIN
              IF IndentAfterEOL < 0
                THEN BEGIN
                  Write (Outfile, Blanks: - IndentAfterEOL);
                  OutputCol := OutputCol - IndentAfterEOL;
                END
                ELSE BEGIN
                  IF Increment < 0
                    THEN BEGIN
                      I := WriteRightCol - OutputCol + 1;
                      IF I > 0 THEN Write (Outfile, Blanks: I);
                      TestNo := LineNumber;  I := 0;
                      REPEAT TestNo := TestNo DIV 10;  I := I + 1;
                      UNTIL TestNo = 0;
                      Write (Outfile, Zeroes: (6 - I), LineNumber: I);
                      LineNumber := LineNumber - Increment;
                      IF LineNumber > 9999
                      THEN LineNumber := LineNumber - 10000;
                      Writeln (Outfile);
                    END
                    ELSE BEGIN
                      Writeln (Outfile);
                      IF Increment > 0
                        THEN BEGIN
                          Write (Outfile, LineNumber: 4,' ');
                          LineNumber := LineNumber + Increment;
                        END
                    END;
                  IF IndentAfterEOL > 0
(* ORIGINAL:      THEN Write (Outfile, Blanks: IndentAfterEOL); INSTEAD: -JLG-*)
                  THEN WRITE (OUTFILE, CHR (16), CHR (INDENTAFTEREOL + 32));
                  OutputCol := IndentAfterEOL + 1;
                END;
              ChIsEndLine := false;
            END (*IF ChIsEndLine*)
            ELSE BEGIN Write (Outfile, ch);  OutputCol := OutputCol + 1; END;
        END (*IF CharCount > *);
      Ch := Character;  WriteColumn := WriteColumn + 1;
    END (*with*)
END (*WriteA*);


PROCEDURE FlushUnwrittenBuffer;

BEGIN
  WriteA (' ');
  WITH UnWritten [Oldest] DO
    BEGIN  ChIsEndLine := true;  IndentAfterEOL := 0;  END;
  WriteColumn := 0;  FOR I := 0 TO BuffSzM1 DO WriteA (' ');
END;


PROCEDURE StartNewLineAndIndent;

BEGIN
  IF PackerIsOff AND DisplayIsOn
    THEN BEGIN
      WriteA (' '); LastSymbol := PeriodSymbol;
      WITH UnWritten [Oldest] DO
        BEGIN
          ChIsEndLine := true;
          IndentAfterEOL := WriteLeftCol + LeftMargin - 1;
        END;
      WriteColumn := WriteLeftCol + LeftMargin;
    END
END;


PROCEDURE ReadACharacter;


PROCEDURE WriteIncludeEnd;
TYPE  futz = RECORD
               CASE boolean OF
                 TRUE: (s: string); 
                FALSE: (n: PACKED ARRAY[0..160] OF 0..255)
             END;
VAR  i, SaveMargin: Margins;
     x: futz;
BEGIN
  x.s := '{The INCLUDE file has been completed.}';
  SaveMargin := LeftMargin;
  LeftMargin := 0;
  StartNewLineAndIndent;  StartNewLineAndIndent;
  FOR i := 1 TO x.n[0] DO WriteA (x.s[i]);
  StartNewLineAndIndent;
  LeftMargin := SaveMargin
END;


PROCEDURE DoReadACharacter (VAR f: text);

BEGIN
  IF ReadColumn > ReadRightCol
    THEN BEGIN
      IF ReadRightCol < MaxReadRightCol
        THEN BEGIN NextChIsEOL := true;  Readln (f)  END
        ELSE ReadColumn := 2
    END
    ELSE IF ReadColumn = 1 THEN
      WHILE ReadColumn < ReadLeftCol DO
        BEGIN
          IF EOLN (f) 
            THEN ReadColumn := 1
            ELSE BEGIN ReadColumn := ReadColumn + 1;  Get (f) END
        END;
  IF NextChIsEOL
    THEN BEGIN
      Character := ' ';  NextChIsEOL := false; ChIsEOL := true;
      ReadColumn := 1;
      IF NoFormatting
        THEN BEGIN
          WriteA (' ');
          WITH UnWritten [Oldest] DO
            BEGIN
              ChIsEndLine := true;
              IndentAfterEOL := WriteLeftCol - 1;
            END;
          WriteColumn := WriteLeftCol - 1;
        END;
    END
    ELSE IF NOT eof (f)
      THEN BEGIN
        Character := f^;  ReadColumn := ReadColumn + 1;
        NextChIsEOL := EOLN (f);  Get (f);  ChIsEOL := false;
        IF NoFormatting THEN WriteA (Character)
      END
      ELSE BEGIN FlushUnwrittenBuffer; EXIT (Program) END
END (*DoReadACharacter*);


BEGIN {ReadACharacter - added to allow for INCLUDE files - JLG}
  IF InIncludeFile 
    THEN IF EOF (IncludeFile)
      THEN BEGIN
        WriteIncludeEnd;
        DoReadACharacter (Infile);
        InIncludeFile := false;
        Close (IncludeFile, Lock)
      END
      ELSE DoReadACharacter (IncludeFile)
    ELSE DoReadACharacter (Infile);
END;


PROCEDURE WriteSymbol;

VAR  I: Width;
     NumberBlanksToWrite: OptionSize;


PROCEDURE WriteLongString (StringLength: Width;  VAR LongString: SymbolString);
VAR  SaveMargin: Margins;
     MaxLength, LineLength: Width;
     EndString: SymbolString;
BEGIN
  SaveMargin := LeftMargin;  LeftMargin := 0;  
  StartNewLineAndIndent;  MaxLength := WriteRightCol - WriteLeftCol + 1;
  IF StringLength <= MaxLength
    THEN FOR LineLength := 1 TO StringLength DO WriteA(LongString[LineLength])
    ELSE BEGIN
      LineLength := 0;
      REPEAT  LineLength := LineLength + 1;  WriteA (LongString[LineLength])
      UNTIL (LineLength > MaxLength -3) 
         OR ((LineLength > MaxLength - 9) AND (LongString[LineLength] = ' '));
      WriteA('''');  WriteA(',');  EndString[1] := '''';
      FOR I := 1 TO StringLength - LineLength DO 
        EndString[I+1] := LongString[I+LineLength];
      WriteLongString (StringLength - LineLength + 1, EndString);
    END;
  LeftMargin := SaveMargin;
END;
  
  
BEGIN
  IF DisplayIsOn
    THEN BEGIN
      NumberBlanksToWrite := SymbolGap;
      IF (LastSymbol IN [LeftParenth, LeftBracket, PeriodSymbol]) OR
          (SymbolName IN [Semicolon, RightParenth, RightBracket,
          CommaSymbol, PeriodSymbol, ColonSymbol]) OR (SymbolName IN
          [LeftBracket, LeftParenth]) AND (LastSymbol = Identifier)
        THEN NumberBlanksToWrite := 0
        ELSE IF (SymbolName IN AlphaSymbols) AND (LastSymbol IN AlphaSymbols)
          THEN IF WriteColumn <= WriteRightCol
            THEN BEGIN
              WriteA (' ');  NumberBlanksToWrite := SymbolGap - 1;
            END;
      IF WriteColumn + Length + NumberBlanksToWrite - 1 > WriteRightCol
        THEN BEGIN
          WriteA (' ');
          WITH UnWritten [Oldest] DO
            BEGIN
              ChIsEndLine := true;
              IF PackerIsOff
                THEN BEGIN
                  IndentAfterEOL := WriteLeftCol - 1 + LeftMargin +
                    LongLineIndent;
                  WriteColumn := WriteLeftCol + LeftMargin +
                    LongLineIndent;
                  I := WriteRightCol - LeftMargin - LongLineIndent 
                     - WriteLeftCol + 1;
                  IF I < Length 
                    THEN IF Symbol[1] = ''''
                      THEN BEGIN 
                        ChIsEndLine := false;
                        WriteLongString (Length, Symbol);
                        Length := 0     {suppress writing string AGAIN}
                      END
                      ELSE IF I < 10 THEN Length := 10 ELSE Length := I;
                END
                ELSE BEGIN
                  IF Length > WriteRightCol - WriteLeftCol + 1
                    THEN Length := WriteRightCol - WriteLeftCol + 1;
                  IndentAfterEOL := WriteLeftCol - 1;
                  WriteColumn := WriteLeftCol
                END;
            END (*with*);
        END (*then*)
        ELSE FOR I := 1 TO NumberBlanksToWrite DO WriteA (' ');
      FOR I := 1 TO Length DO WriteA (Symbol [I]);
    END (*IF DisplayIsOn*);
  LastSymbol := SymbolName
END (*WriteSymbol*);


PROCEDURE CopyACharacter;

BEGIN
  IF DisplayIsOn
    THEN BEGIN
      IF (WriteColumn > WriteRightCol) OR 
         ((WriteColumn + 7 > WriteRightCol) AND (Character  = ' '))     (*JLG*)
        THEN BEGIN
          WHILE (Character = ' ') AND NOT ChIsEOL DO
            ReadACharacter;
          IF NOT ChIsEOL THEN StartNewLineAndIndent
        END;
      IF ChIsEOL
        THEN BEGIN
          LeftMargin := 0;  StartNewLineAndIndent;
          LeftMargin := ActualLeftMargin
        END
        ELSE WriteA (Character)
    END;
  ReadACharacter
END (*CopyACharacter*);




PROCEDURE DoFormatterDirectives;

CONST  Invalid = -1;
TYPE  ParamCount = 1..2;
      Params = ARRAY [ParamCount] OF integer;
VAR  Specification: Params;
     FormatOption: char;
     PrevDisplay, PrevNoFormatting: boolean;
     EndDirectiv: CharSet;


PROCEDURE ReadIn (N: ParamCount; VAR Specification: Params);

VAR I: ParamCount;

BEGIN
  FOR I := 1 TO N DO
    BEGIN
      WHILE NOT (Character IN (Digits + EndDirectv)) DO CopyACharacter;
      Specification [I] := 0;
      IF NOT (Character IN EndDirectiv)
        THEN 
          REPEAT
            Specification [I] := 10 * Specification [I] + ORD (Character)
              - ORD ('0');
            CopyACharacter
          UNTIL NOT (Character IN Digits)
        ELSE Specification [I] := Invalid;
    END
END (*ReadIn*);


BEGIN (*DoFormatterDirectives*);
  EndDirective := ['*', ']', '}'];                                 (*JLG*)
  REPEAT IF Character IN ['A'..'G', 'I', 'L', 'N', 'P', 'R', 'S', 'W']
    THEN BEGIN
      FormatOption := Character;
      CASE FormatOption OF
        'A', 'E', 'I', 'G', 'P', 'L', 'S':
          BEGIN
            ReadIn (1, Specification);
            IF (Specification [1] < WriteRightCol - WriteLeftCol - 9)
                OR (FormatOption = 'P')
              THEN CASE FormatOption OF
                'A':  DeclarAlignment := Specification [1];
                'E':  IF Specification [1] < 4
                        THEN BEGIN
                          ProcNamesWanted := Specification [1] > 1;
                          EndCommentsWanted := Odd(Specification [1])
                        END;
                'G':  SymbolGap := Specification [1];
                'I':  IndentIndex := Specification [1];
                'L':  LongLineIndent := Specification [1];
                'P':  ProcSeparation := Specification [1];
                'S':  StatmtSeparation := Specification [1]
              END (*case*)
          END (*1st 7 letters*);
        'W', 'R', 'N':
          BEGIN
            ReadIn (2, Specification);
            IF Specification [2] <> Invalid
              THEN CASE FormatOption OF
                'W':  IF (Specification [1] > 0) AND (Specification [2] <
                          BufferSize - 2) AND (Specification [2] -
                          Specification [1] > 8)
                        THEN BEGIN
                          WriteLeftCol := Specification [1];
                          WriteRightCol := Specification [2]
                        END;
                'R':  IF (Specification [1] > 0) AND (Specification [2] -
                          Specification [1] > 8)
                        THEN BEGIN
                          ReadLeftCol := Specification [1];
                          ReadRightCol := Specification [2]
                        END;
                'N':  BEGIN
                        LineNumber := Specification [1];
                        Increment := Specification [2];
                        WHILE NOT (Character IN (['<'] + EndDirectv))
                            AND (Character <> '>') DO
                          CopyACharacter;
                        IF Character = '>' THEN Increment := - Increment
                      END
              END (*case*);
          END (*Next 2 letters*);
        'B', 'C', 'D', 'F':
          BEGIN
            REPEAT CopyACharacter
            UNTIL Character IN (['+', '-'] + EndDirectv);
            IF Character IN ['+', '-']
              THEN CASE FormatOption OF
                'B':  IF DisplayIsOn THEN BunchWanted := Character = '+';
                'C':  PackerIsOff := Character = '-';
                'D':  BEGIN
                        PrevDisplay := DisplayIsOn;
                        DisplayIsOn := Character = '+';
                        IF PrevDisplay AND NOT DisplayIsOn
                          THEN BEGIN
                            WriteA ('*'); WriteA (')');
                            SavedBunch := BunchWanted;
                            BunchWanted := false
                          END
                          ELSE IF NOT PrevDisplay AND DisplayIsOn
                            THEN BEGIN
                              StartNewLineAndIndent;  WriteA ('(');
                              WriteA ('*');  BunchWanted := SavedBunch
                            END
                      END;
                'F':  BEGIN
                        PrevNoFormatting := NoFormatting;
                        NoFormatting := Character = '-';
                        DisplayIsOn := NOT NoFormatting;
                        IF PrevNoFormatting AND NOT NoFormatting
                          THEN ReadACharacter;
                        IF NOT PrevNoFormatting AND NoFormatting
                          THEN WriteA ('-');
                      END
              END (*case*)
          END (*boolean parameters*)
      END (*main case statement*);
    END (*then*)
    ELSE IF NOT (Character IN EndDirectv) THEN CopyACharacter
  UNTIL Character IN EndDirectv;
  IF Character = ']' THEN CopyACharacter
END (*DoFormatterDirectives*);


========================================================================================
DOCUMENT :usus Folder:VOL06:format.3.text
========================================================================================

PROCEDURE GetNewInitValues;
{The following CONST and TYPE are DERIVED from MAKEMASKS; DO NOT CHANGE!}
CONST  MaxX = 79 {max line length};
       MaxY = 23 {max lines/screen - 1};
       MaxData = 50 {max entries in data field table};
TYPE  XLimits = 0..MaxX;
      YLimits = 0..MaxY;
      FieldNo = 1..MaxData;
      DataRec = PACKED RECORD
                  X: XLimits;
                  Y: YLimits;
                  Lngth, Dec: XLimits
                END;
      DataArry = ARRAY [FieldNo] OF DataRec;
      MaskRec = RECORD
                  Line: ARRAY [YLimits] OF PACKED ARRAY [XLimits] OF char;
                  Data: DataArry
                END;
      Characset = SET OF char;
VAR  i, j: integer;
     c: char;
     Done, NegIncrement: boolean;
     Field: DataArry;
     
     
PROCEDURE OpenDataFile {Implementation Dependent!!!};
CONST  DFileName = 'FMT.MASK.DATA';
VAR i, j: integer;
    Mask: MaskRec;
    DataFile: FILE OF MaskRec;
BEGIN
  {$I-}
  Reset (DataFile, DFileName);
  IF IORESULT > 0 THEN Reset (DataFile, CONCAT ('#4:', DFileName));
  IF IORESULT > 0 THEN Reset (DataFile, CONCAT ('#5:', DFileName));
  {$I+}
  IF IORESULT > 0
    THEN BEGIN
      Write (
      'Cannot open the CRT mask file; we''ll skip this portion of FORMAT.');
      EXIT (GetNewInitValues)
    END;
  Gotoxy (0, 0);
  Mask := DataFile^;
  FOR i := 0 TO MaxY DO
    BEGIN UnitWrite(1,Mask.Line[i],MaxX); IF i < MaxY DO Writeln END;
  FOR i := 1 TO MaxData DO Field[i] := Mask.Data[i];
END;


PROCEDURE GoToFieldNo (f: FieldNo);
BEGIN
  WITH Field[f] DO Gotoxy (X, Y)
END;


PROCEDURE GoAndEraseField (f: FieldNo);
BEGIN
  WITH Field[f] DO Gotoxy (X, Y);
  Write (' ': Field[f].Lngth);
  WITH Field[f] DO Gotoxy (X, Y);
END;


PROCEDURE WritePrompt (prompt: string);
BEGIN
  GoAndEraseField (30);
  Write (prompt)
END;


FUNCTION GetChar (f: integer; prompt: string; charset: characset): char;
VAR ch: char;
BEGIN
  WritePrompt (prompt);
  IF f > 0 THEN GoToFieldNo (f);
  REPEAT 
    Read (keyboard, ch);
    IF (ch IN ['a'..'z']) THEN ch := CHR (ORD(ch) + ORD('A') - ORD('a') );
  UNTIL ch IN charset;
  GetChar := ch;
END;


FUNCTION GetBoolean (f: integer; prompt: string): boolean;
VAR NewPrompt: string;
BEGIN
  NewPrompt := CONCAT ('Do you wish ', prompt, ' (Y/N)?  ');
  IF GetChar (f, NewPrompt, ['Y', 'N']) = 'Y'
    THEN BEGIN
      Write ('Yes');
      GetBoolean := true
    END
    ELSE BEGIN
      Write (' No');
      GetBoolean := false
    END;
END;


PROCEDURE GetInteger (f: FieldNo; VAR Wanted: integer);
CONST UpperLimit = 1000;
VAR i, ilngth: integer;
    ch, backsp, esc: char;
BEGIN
  backsp := CHR (8);
  esc := CHR (27);
  ilngth := Field[f].Lngth;
  i := 0;
  WritePrompt (
'Type desired number, then <return>, or use <esc> to restore original value.');
  REPEAT
    GoToFieldNo (f);
    IF i <> 0 THEN Write (i: ilngth) ELSE Write (' ': ilngth);
    REPEAT Read (keyboard, ch) 
    UNTIL (ch IN ['0'..'9', ' ', backsp, esc]);
    IF ch = backsp
      THEN IF i < 0
        THEN i := -(ABS(i) DIV 10)
        ELSE i := i DIV 10
    ELSE IF ch IN ['0'..'9'] THEN i := i * 10 + ORD(ch) - ORD('0');
  UNTIL (i * 10 > UpperLimit) OR (ch IN [' ', esc]);
  IF ch <> esc THEN Wanted := i;
  GoToFieldNo (f);
  Write (Wanted: Field[f].Lngth);
END;


PROCEDURE WriteValues;
VAR i: integer;


PROCEDURE WriteInt (n: integer);
BEGIN
  WITH Field[i] DO
    BEGIN
      Gotoxy (X,Y);
      Write (n:Lngth)
    END
END;


PROCEDURE WriteBool (b: boolean);
BEGIN
  WITH Field[i] DO Gotoxy (X,Y);
  IF b THEN Write ('Yes') ELSE Write (' No')
END;

  
BEGIN
  FOR i := 11 TO 28 DO
    CASE i OF
      11:  WriteInt (ReadLeftCol);
      12:  WriteInt (ReadRightCol);
      13:  WriteInt (WriteLeftCol);
      14:  WriteInt (WriteRightCol);
      15:  WriteInt (SymbolGap);
      16:  WriteInt (StatmtSeparation);
      17:  WriteInt (IndentIndex);
      18:  WriteInt (LongLineIndent);
      19:  WriteInt (DeclarAlignment);
      20:  WriteInt (ProcSeparation);
      21:  WriteBool (BunchWanted);
      22:  WriteBool (NOT PackerIsOff);
      23:  WriteBool (ProcNamesWanted);
      24:  WriteBool (EndCommentsWanted);
      25:  BEGIN
             GoToFieldNo (25);
             IF Increment = 0 THEN Write ('   No')
             ELSE IF NegIncrement THEN Write ('Right') ELSE Write (' Left')
           END;
      26:  WriteInt (LineNumber);
      27:  WriteInt (Increment);
      28:  WriteBool (ReadIncludeFiles);
    END;
END;

    
PROCEDURE FortyColumnFormat;
BEGIN
  BunchWanted := false;  SymbolGap := 1;  StatmtSeparation := 1;
  IndentIndex := 1;  LongLineIndent := 2;  WriteRightCol := 39;
  WriteLeftCol := 1;  WriteValues;
END;


PROCEDURE SixtyFourColumnFormat;
BEGIN
  SymbolGap := 1;  StatmtSeparation := 2;  IndentIndex := 2;
  LongLineIndent := 2;  WriteRightCol := 63;  WriteLeftCol := 1;
  WriteValues
END;


PROCEDURE EightyColumnFormat;
BEGIN
  StatmtSeparation := 3;  IndentIndex := 3;  LongLineIndent := 4;
  WriteRightCol := 79;  WriteLeftCol := 1;  WriteValues
END;


PROCEDURE ModemFormat;
BEGIN
  PackerIsOff := false;  EndCommentsWanted := true;
  ProcNamesWanted := true;  WriteValues;
END;


BEGIN {GetNewInitValues}
  Done := false;
  OpenDataFile;
  WriteValues;
  REPEAT
    CASE GetChar (-1, 
'Please type letter of option you wish to change; "G" to go on; "Q" to quit.  ',
['A'..'E', 'G', 'I', 'J', 'L'..'N', 'P'..'S', 'W', '4', '6', '8','#']) OF
      'A':  GetInteger (19, DeclarAlignment);
      'B':  BunchWanted := GetBoolean (21, 'to bunch statements');
      'C':  PackerIsOff := NOT GetBoolean (22, 'to krunch your program');
      'D':  ReadIncludeFiles := GetBoolean (28, 'to incorporate INCLUDE files');
      'E':  EndCommentsWanted := GetBoolean (24, 'to comment END statements');
      'G':  Done := GetBoolean (-1, 'to get on with formatting your program');
      'I':  CASE GetChar (4,
'Indent L)ogical nesting or O)verflow (continuation) lines?  ', ['L', 'O']) OF
               'L':  GetInteger (17, IndentIndex);
               'O':  GetInteger (18, LongLineIndent)
             END;
      'J':  GetInteger (27, Increment);
      'L':  GetInteger (20, ProcSeparation);
      'M':  ModemFormat;
      'N':  BEGIN
              CASE GetChar (25, 'Type an "N", "R", or "L":  ',
                  ['N', 'R', 'L']) OF
                'N':  Increment := 0;
                'L':  BEGIN
                        NegIncrement := false; 
                        IF Increment = 0 THEN Increment := 1
                      END;
                'R':  BEGIN
                        NegIncrement := true; 
                        IF Increment = 0 THEN Increment := 1
                      END;
                END;
              WriteValues;
            END;
      'P':  ProcNamesWanted := GetBoolean 
              (23, 'procedure/function name comments');
      'Q':  IF GetBoolean (-1, 'TO *EXIT* THIS PROGRAM') THEN EXIT (Program);
      'R':  CASE GetChar
              (1, 'L)eft or R)ight margins of input file?  ', ['L','R']) OF
              'L':  GetInteger (11, ReadLeftCol);
              'R':  GetInteger (12, ReadRightCol)
            END;
      'S':  CASE GetChar (3,
  'Spacing between I)dentifiers & symbols or S)tatements on the same line?  ',
              ['I', 'S']) OF
              'I':  GetInteger (15, SymbolGap);
              'S':  GetInteger (16, StatmtSeparation)
            END;
      'W':  CASE GetChar 
              (2, 'L)eft or R)ight margins on output page?  ', ['L', 'R']) OF
              'L':  GetInteger (13, WriteLeftCol);
              'R':  GetInteger (14, WriteRightCol)
            END;
      '4':  FortyColumnFormat;
      '6':  SixtyFourColumnFormat;
      '8':  EightyColumnFormat;
      '#':  GetInteger (26, LineNumber)
    END;
  UNTIL Done;
  Writeln;
  IF NegIncrement THEN Increment := -Increment
END;



========================================================================================
DOCUMENT :usus Folder:VOL06:format.4.text
========================================================================================

PROCEDURE ReadSymbol;

CONST  ReadNextCh = true;
       DontReadNextCh = false;
TYPE  CmtDelmtrs = (Brace, PrnAstrsk);
VAR  TestSymbol: Alfa;
     CharNumber, I: Width;
     CmntDelimitr: CmtDelmtrs;


PROCEDURE CompilerDirectives;
VAR  Lngth: Width;
     DoInclude: boolean;
     str: string[25];


PROCEDURE WriteString (st:String);
TYPE  futz = RECORD
               CASE boolean OF
                 TRUE: (s: string); 
                FALSE: (n: PACKED ARRAY[0..160] OF 0..255)
             END;
VAR  i: integer;
     x: futz;
BEGIN x.s := st;  FOR i := 1 TO x.n[0] DO WriteA (x.s[i]) END;


BEGIN
  DoInclude := false;  str := '';  ReadACharacter;
  IF ReadIncludeFiles AND (Character IN ['I', 'i']) {INCLUDE compiler directive}
    THEN BEGIN
      REPEAT ReadACharacter UNTIL Character <> ' ';
      IF Character IN ['+', '-'] {"I" is also I/O-checking directive}
        THEN str := 'I'
        ELSE BEGIN
          IF InIncludeFile
            THEN BEGIN
              str := 'I';
              Writeln 
    ('**ERROR**--INCLUDE directives not allowed within INCLUDED files.')
            END
            ELSE BEGIN
              Lngth := 0;
              REPEAT
                Lngth := Lngth + 1;  INSERT (' ', str, Lngth);
                str [Lngth] := Character;  ReadACharacter
              UNTIL (Character IN [' ', '[', '*', '}']) OR (Lngth >= 23);
              {$I+}
              Reset (IncludeFile, str);
              IF IORESULT > 0 THEN Reset (IncludeFile, CONCAT ('#4:', str));
              IF IORESULT > 0 THEN Reset (IncludeFile, CONCAT ('#5:', str));
              {$I-}
              IF IORESULT = 0
                THEN BEGIN
                  DoInclude := true;  InIncludeFile := true;
                  WriteString (CONCAT ('Now INCLUDING ', str, '.'));
                  Writeln ('Now INCLUDING ', str, '.')
                END
                ELSE Writeln 
          ('*ERROR* - could not open INCLUDE file ', str, '; will skip it.')
            END {else}
        END {else}
    END {if};
  IF NOT DoInclude THEN WriteString (CONCAT ('$', str));
  WHILE NOT (Character IN ['[', '*', '}']) DO CopyACharacter
END;


PROCEDURE DoComment;
VAR I, Length: OptionSize;
    FoundEnd, LoopDone: boolean;
    ComText: PACKED ARRAY [Width] OF char;


FUNCTION LineTooLong (LookingFor: char): boolean;
VAR EndLength, WordEndLength: width;  TooLong: boolean;
BEGIN
  EndLength := WriteRightCol - WriteColumn - 1 {room for comment close};
  IF CmntDelimitr = PrnAstrsk THEN EndLength := EndLength - 1;
  IF EndLength < 7 THEN WordEndLength := 0
                   ELSE WordEndLength := EndLength - 7;
  TooLong := (Length > EndLength) 
      OR ((Character = ' ') AND (Length <= WordEndLength));
  WHILE NOT (TooLong OR (Character = LookingFor))
    DO BEGIN
      ComText [Length] := Character;
      Length := Length + 1;
      ReadACharacter;
      TooLong := (Length > EndLength) OR ChIsEOL
        OR ((Character = ' ') AND (Length > WordEndLength));
    END;
  LineTooLong := TooLong;
END;


PROCEDURE NewCommentLine;
BEGIN
  LeftMargin := 0;  StartNewLineAndIndent;
  LeftMargin := ActualLeftMargin
END;


PROCEDURE CopyCommentChar;
BEGIN
  If DisplayIsOn
    THEN BEGIN
      IF (WriteColumn > WriteRightCol) 
           OR ((Character = ' ') AND (WriteColumn + 7 > WriteRightCol))
        THEN BEGIN
          WHILE Character = ' ' DO ReadACharacter;
          NewCommentLine;
        END;
      IF ChIsEOL  {skip over blanks at beginning of next line}
        THEN WHILE Character = ' ' DO ReadACharacter;
      WriteA(Character);
    END;
  ReadACharacter;
END;

    
BEGIN {DoComment}
  FoundEnd := false;
  IF (LastSymbol = Comment) OR (ReadRightCol < 3) OR (Character IN ['$','['])
    THEN BEGIN
      NewCommentLine;
      WriteSymbol;
      If Character = '$' THEN CompilerDirectives;
      IF Character = '[' THEN DoFormatterDirectives;
    END
    ELSE BEGIN
      Length := 1;
      IF CmntDelimitr = Brace
        THEN IF LineTooLong ('}') THEN NewCommentLine ELSE FoundEnd := true
        ELSE REPEAT IF LineTooLong ('*')
          THEN BEGIN LoopDone := true;  NewCommentLine END
          ELSE BEGIN
            ComText [Length] := Character;
            Length := Length + 1;
            ReadACharacter;
            LoopDone := Character = ')';
            FoundEnd := Character = ')';
          END
        UNTIL LoopDone;
      WriteSymbol;
      FOR I := 1 TO Length - 1 DO WriteA (ComText[I]);
    END;
  IF NOT FoundEnd THEN IF CmntDelimitr = Brace
    THEN WHILE Character <> '}' DO CopyCommentChar
    ELSE REPEAT WHILE Character <> '*' DO CopyCommentChar;  CopyCommentChar
         UNTIL Character = ')';
  CopyCommentChar;  LastSymbol := Comment;  ReadSymbol
END {DoComment};


PROCEDURE SkipComment;
{Now won't dump compiler directives;  handles brace-type comments. JLG}
VAR NeedsClosure: boolean;
BEGIN
  IF Character = '$'
    THEN BEGIN WriteSymbol;  CompilerDirectives;  NeedsClosure := true END
    ELSE NeedsClosure := false;
  IF CmntDelimitr = Brace
    THEN BEGIN
      WHILE Character <> '}' DO ReadACharacter;
      IF NeedsClosure THEN WriteA ('}')
    END
    ELSE BEGIN
      REPEAT WHILE Character <> '*' DO ReadACharacter;  ReadACharacter
         UNTIL Character = ')';
      IF NeedsClosure THEN BEGIN WriteA ('*');  WriteA (')') END
    END;
  ReadACharacter; LastSymbol := comment; ReadSymbol
END;


PROCEDURE CheckFor (SecondChar: char; TwoCharSymbol: Symbols;
  ReadAllowed: Boolean);
BEGIN
  IF ReadAllowed
    THEN BEGIN
      Length := 1;  Symbol[1] := Character;
      SymbolName := NameOf [Character];  ReadACharacter
    END;
  IF Character = SecondChar
    THEN BEGIN
      Symbol [2] := Character;  Length := 2;
      SymbolName := TwoCharSymbol;  ReadACharacter;
      IF (NOT PackerIsOff) AND (SymbolName = Comment) THEN Length := 0
    END
END {CheckFor};


BEGIN {ReadSymbol}
  IF LastSymWasRange   {added - JLG}
    THEN BEGIN
      Symbol[1] := '.';  Symbol[2] := '.';  SymbolName := Range;
      Length := 2;  LastSymWasRange := false
    END
  ELSE IF (Character IN Letters)  {evaluation order revised - JLG}
    THEN BEGIN
      CharNumber := 1;  SymbolIsNumber := false;
      REPEAT
        Symbol [CharNumber] := Character;  ReadACharacter;
        CharNumber := CharNumber + 1
      UNTIL NOT (Character IN LettersAndDigits);
      Length := CharNumber - 1;
      FOR CharNumber := CharNumber TO AlfaLeng DO
        Symbol [CharNumber] := ' ';
        { PACK (Symbol, 1, TestSymbol); } 
        {EQUIVALENT (WITH ADDED UPPER/LOWER CASE TRANSPARENCY):  }
        FOR I := 1 TO AlfaLeng DO
          BEGIN
            TestSymbol [I] := Symbol [I];
            IF (TestSymbol [I] IN ['a'..'z']) {lower --> upper case JLG}
              THEN TestSymbol [I] := CHR (ORD (TestSymbol [I]) + ORD ('A') -
                ORD ('a'))
          END;
      I := 1;
      PascalSymbol [LastPascSymbol] := TestSymbol;
      WHILE PascalSymbol [I] <> TestSymbol DO I := I + 1;
      SymbolName := PascSymbolName [I]
    END {letters}
  ELSE IF (Character IN ['0'..'9', ' ', '(', '{', '.', ':', '''', '<', '>'])
    THEN CASE Character OF
      '{':  BEGIN  {brace added - JLG}
              SymbolName := Comment;  CmntDelimitr := Brace; 
              ReadACharacter;  Length := 1;  Symbol[1] := '{';
              IF PackerIsOff OR (EndCommentsWanted AND ProcNamesWanted)
                 THEN DoComment ELSE SkipComment
            END;
      '(':  BEGIN  {Revised -- JLG}
              CheckFor ('*', Comment, ReadNextCh);
              IF SymbolName = Comment
                THEN BEGIN
                  CmntDelimitr := PrnAstrsk;
                  IF PackerIsOff OR (EndCommentsWanted AND ProcNamesWanted)
                    THEN DoComment ELSE SkipComment
                END
            END;
      '0', '1', '2', '3', '4', '5', '6', '7', '8', '9':
            BEGIN
              SymbolIsNumber := true;  CharNumber := 1;
              REPEAT
                REPEAT
                  Symbol [CharNumber] := Character;  ReadACharacter;
                  CharNumber := CharNumber + 1
                UNTIL NOT (Character IN Digits);
                IF Character = '.'
                  THEN BEGIN
                    Symbol [CharNumber] := Character;  ReadACharacter;
                    CharNumber := CharNumber + 1
                  END
              UNTIL NOT (Character IN Digits);
              IF (Character = '.') AND (Symbol [CharNumber-1] = '.')
                THEN BEGIN  { stmt added - JLG}
                  LastSymWasRange := true;  ReadACharacter;
                  CharNumber := CharNumber - 1
                END;
              IF (Character IN ['B', 'E']) AND NOT LastSymWasRange
                THEN BEGIN
                  Symbol [CharNumber] := Character;  ReadACharacter;
                  CharNumber := CharNumber + 1;
                  IF Character IN Digits + ['+', '-']
                    THEN REPEAT
                      Symbol [CharNumber] := Character;  ReadACharacter;
                      CharNumber := CharNumber + 1
                    UNTIL NOT (Character IN Digits)
                END;
              Length := CharNumber - 1;  SymbolName := Identifier;
            END {numbers};
      ' ':  BEGIN
              REPEAT ReadACharacter UNTIL Character <> ' ';  ReadSymbol
            END;
      '>', ':':
            CheckFor ('=', OtherSymbol, ReadNextCh);
      '<':  BEGIN
              CheckFor ('=', OtherSymbol, ReadNextCh);
              IF SymbolName <> OtherSymbol 
                THEN CheckFor ('>', OtherSymbol, DontReadNextCh)
            END;
      '.':  IF LastSymbol <> EndSymbol
              THEN CheckFor ('.', Range, ReadNextCh)
              ELSE SymbolName := PeriodSymbol;
      '''': BEGIN
              CharNumber := 1;
              REPEAT
                REPEAT
                  Symbol [CharNumber] := Character;
                  CharNumber := CharNumber + 1;  ReadACharacter
                UNTIL Character = '''';
                Symbol [CharNumber] := Character;
                CharNumber := CharNumber + 1;  ReadACharacter
              UNTIL Character <> '''';
              Length := CharNumber - 1;  SymbolName := OtherSymbol;
            END {string}
    END {then case}
    ELSE BEGIN
      Symbol [1] := Character;  SymbolName := NameOf [Character];
      Length := 1;  ReadACharacter
    END
END {ReadSymbol};



========================================================================================
DOCUMENT :usus Folder:VOL06:format.5.text
========================================================================================

PROCEDURE ChangeMarginTo (NewLeftMargin: Margins);

VAR  IndentedLeftMargin: Margins;

BEGIN
  ActualLeftMargin := NewLeftMargin;  LeftMargin := NewLeftMargin;
  IF LeftMargin < 0
    THEN LeftMargin := 0
    ELSE BEGIN
      IndentedLeftMargin := WriteRightCol - 9 - LongLineIndent;
      IF LeftMargin > IndentedLeftMargin THEN LeftMargin := IndentedLeftMargin
    END
END (*ChangeMarginTo*);





PROCEDURE DoDeclarationUntil (EndDeclaration: SymbolSet);




  PROCEDURE DoParentheses;
  
  VAR  SavedLgLnId: OptionSize;
  
  BEGIN
    SavedLgLnId := LongLineIndent;
    IF DeclarAlignment > 0
      THEN BEGIN
        LongLineIndent := WriteColumn + SymbolGap + 1 - LeftMargin -
            WriteLeftCol;
        REPEAT WriteSymbol;  ReadSymbol
        UNTIL SymbolName = RightParenth;
        WriteSymbol;  ReadSymbol
      END
      ELSE BEGIN
        LongLineIndent := 1;
        ChangeMarginTo (ActualLeftMargin + IndentIndex);
        StartNewLineAndIndent;
        REPEAT WriteSymbol;  ReadSymbol
        UNTIL SymbolName = RightParenth;
        WriteSymbol; ReadSymbol;
        ChangeMarginTo (ActualLeftMargin - IndentIndex);
      END;
    LongLineIndent := SavedLgLnId
  END (*DoParentheses*);
  
  
  PROCEDURE DoFieldListUntil (EndFieldList: SymbolSet);
  
  VAR  LastEOL: Margins;  AlignColumn: Width;
  
  
    PROCEDURE DoRecord;
    
    VAR SavedLeftMargin: Width;
    
    BEGIN
      SavedLeftMargin := ActualLeftMargin;  WriteSymbol;  ReadSymbol;
      ChangeMarginTo (WriteColumn - 6 + IndentIndex - WriteLeftCol);
      StartNewLineAndIndent;  DoFieldListUntil ([EndSymbol]);
      ChangeMarginTo (ActualLeftMargin - IndentIndex);
      StartNewLineAndIndent;  WriteSymbol;  ReadSymbol;
      ChangeMarginTo (SavedLeftMargin);
    END (*DoRecord*);
    
    
    PROCEDURE DoVariantRecordPart;
    
    VAR SavedLeftMargin, OtherSavedMargin:  Margins;
    
    BEGIN
      OtherSavedMargin := ActualLeftMargin;
      IF DeclarAlignment > 0
        THEN BEGIN
          REPEAT WriteSymbol;  ReadSymbol
          UNTIL SymbolName IN [ColonSymbol, OfSymbol];
          IF SymbolName = ColonSymbol
            THEN BEGIN
              WriteSymbol;  ReadSymbol;
              WITH UnWritten [LastEOL] DO
                BEGIN
                  IndentAfterEOL := IndentAfterEOL + AlignColumn -
                      WriteColumn;
                  IF IndentAfterEOL < 0 THEN IndentAfterEOL := 0
                END;
              WriteColumn := AlignColumn;
              ChangeMarginTo (ActualLeftMargin + AlignColumn - WriteColumn)
            END
        END (*then*);
      IF SymbolName <> OfSymbol THEN REPEAT WriteSymbol;  ReadSymbol
        UNTIL SymbolName = OfSymbol;
      ChangeMarginTo (ActualLeftMargin + IndentIndex);
      REPEAT
        WriteSymbol;  ReadSymbol;
        IF SymbolName <> EndSymbol
          THEN BEGIN
            StartNewLineAndIndent;
            REPEAT WriteSymbol;  ReadSymbol
            UNTIL SymbolName IN [LeftParenth, SemiColon, EndSymbol];
            IF SymbolName = LeftParenth
              THEN BEGIN
                WriteSymbol;  ReadSymbol;  SavedLeftMargin := ActualLeftMargin;
                ChangeMarginTo (WriteColumn - WriteLeftCol);
                DoFieldListUntil ([RightParenth]);  WriteSymbol;
                ReadSymbol;  ChangeMarginTo (SavedLeftMargin)
              END
          END;
      UNTIL SymbolName <> Semicolon;
      ChangeMarginTo (OtherSavedMargin)
    END (*DoVariantRecordPart*);
    
    
  BEGIN (*DoFieldListUntil*)
    LastEOL := Oldest;
    IF LastSymbol = LeftParenth
    THEN FOR I := 1 TO DeclarAlignment - Length DO WriteA (' ');
    AlignColumn := LeftMargin + WriteLeftCol + DeclarAlignment + 1;
    WHILE NOT (SymbolName IN EndFieldList) DO
      BEGIN
        IF LastSymbol IN [Semicolon, Comment] THEN IF SymbolName <> Semicolon
          THEN BEGIN StartNewLineAndIndent;  LastEOL := Oldest END;
        IF SymbolName IN [RecordSymbol, CaseSymbol, LeftParenth,
            CommaSymbol, ColonSymbol, EqualSymbol]
          THEN CASE SymbolName OF
            RecordSymbol:  DoRecord;
            CaseSymbol:    DoVariantRecordPart;
            LeftParenth:   DoParentheses;
            CommaSymbol, ColonSymbol, EqualSymbol:
                           BEGIN
                             WriteSymbol;
                             IF DeclarAlignment > 0
                               THEN IF NOT (EndLabel <= EndFieldList)
                                 THEN BEGIN
                                   WITH UnWritten [LastEOL] DO
                                     BEGIN
                                       IndentAfterEOL := IndentAfterEOL +
                                         AlignColumn - WriteColumn;
                                       IF IndentAfterEOL < 0
                                         THEN IndentAfterEOL := 0;
                                       WriteColumn := AlignColumn
                                     END;
                                   IF SymbolName = CommaSymbol
                                     THEN BEGIN
                                       StartNewLineAndIndent;  LastEOL := Oldest
                                     END
                                 END (*then*);
                             ReadSymbol
                           END (* , : = *)
          END (*case*)
          ELSE BEGIN WriteSymbol;  ReadSymbol END;
      END (*while*)
  END (*DoFieldListUntil*);
  
  
  
BEGIN (*DoDeclarationUntil*)
  StartNewLineAndIndent;  WriteSymbol;
  ChangeMarginTo (ActualLeftMargin + IndentIndex);
  StartNewLineAndIndent;  ReadSymbol;
  DoFieldListUntil (EndDeclaration);  StartNewLineAndIndent;
  ChangeMarginTo (ActualLeftMargin - IndentIndex)
END (*DoDeclarationUntil*);





PROCEDURE DoBlock (BlockName: CommentText;  BlockNmLength: Width);

VAR  I: Width;  IfThenBunchNeeded, AtProcBeginning: boolean;



  PROCEDURE DoProcedures;
  
  VAR  I: 0..20;
       ProcName: CommentText;
       ProcNmLenght: Width;
       
  BEGIN
    FOR I := 2 TO ProcSeparation DO StartNewLineAndIndent;
    StartNewLineAndIndent;  WriteSymbol;  ReadSymbol;
    IF SymbolName IN [ProcSymbol, FuncSymbol]
      THEN BEGIN WriteSymbol;  ReadSymbol END; {handle SEPARATE PROCEDURES--JLG}
 (* FOR I := 0 TO (Length - 1) DIV AlfaLeng DO
      Pack (Symbol, I * AlfaLeng + 1, ProcName [I + 1]; *)
    (* Equivalent: *)
    FOR I := 0 TO (Length - 1) DIV AlfaLeng DO FOR J := 1 TO AlfaLeng DO
      ProcName [I + 1, J] := Symbol [J + I*AlfaLeng];
    ProcNmLength := Length;  WriteSymbol;  ReadSymbol;
    IF SymbolName = LeftParenth
      THEN BEGIN
        WriteSymbol;
        REPEAT ReadSymbol;  WriteSymbol
        UNTIL SymbolName = RightParenth;
        ReadSymbol
      END;
    IF SymbolName = ColonSymbol THEN
      REPEAT WriteSymbol;  ReadSymbol UNTIL SymbolName = Semicolon;
    WriteSymbol;  ReadSymbol;
    ChangeMarginTo (ActualLeftMargin + IndentIndex);
    StartNewLineAndIndent;  LastProgPartWasBody := false;
    DoBlock (ProcName, ProcNmLength);  LastProgPartWasBody := true;
    ChangeMarginTo (ActualLeftMargin - IndentIndex);  WriteSymbol;
    ReadSymbol;  StartNewLineAndIndent
  END (*DoProcedures*);
  
  
  PROCEDURE DoStatement (VAR AddedBlanks: Width; StatmtSymbol:
    CommentText;  StmtSymLength: Width);
    
  VAR  I: Width;
       StatmtBeginning, BlksOnCurrntLine, BlksAddedByThisStmt: integer;
       StatmtPart:  ARRAY [1..4] OF integer;
       Successful: boolean;
       
       
       
    PROCEDURE Bunch (Beginning, Breakpt, Ending: integer;
      StatmtSeparation: OptionSize);
      
    BEGIN
      IF BunchWanted OR IfThenBunchNeeded
        THEN BEGIN
          IF StatmtSeparation < 1 THEN StatmtSeparation := 1;
          BlksOnCurrntLine := BlksOnCurrntLine + StatmtSeparation - 1;
          Successful := ((Ending - Beginning + BlksOnCurrntLine +
            UnWritten [Beginning MOD BufferSize].IndentAfterEOL) <
            WriteRightCol) AND (CharCount - Beginning < BufferSize);
          IF Successful
            THEN BEGIN
              BlksAddedByThisStmt := BlksAddedByThisStmt +
                StatmtSeparation - 1;
              UnWritten [Breakpt MOD BufferSize].IndentAfterEOL :=
                - StatmtSeparation;
            END
        END
    END (*bunch*);
    
    
    PROCEDURE WriteComment;
    
    VAR  I, SavedLength: Width;
         SavedSymbolName: Symbols;
         SavedChars:  SymbolString;
         
    BEGIN
      IF PackerIsOff                                    (*added - JLG*)
        THEN BEGIN
          SavedSymbolName := SymbolName;
          FOR I := 1 TO Length DO SavedChars [I] := Symbol [I];
          SavedLength := Length;  SymbolName := OtherSymbol;
          Symbol [1] := '(';  Symbol [2] := '*';  Length := 2;  WriteSymbol;
(* FOR I := 0 TO (StmtSymLength - 1) DIV AlfaLeng DO
            Unpack (StatmtSymbol [I + 1], Symbol, (I * AlfaLeng + 1));*)
(* EQUIVALENT:  *)
          FOR I := 0 TO (StmtSymLength - 1) DIV AlfaLeng DO 
            FOR J := 1 TO AlfaLeng
              DO Symbol [J + I * AlfaLeng] := StatmtSymbol [I + 1, J];
          Length := StmtSymLength;  SymbolName := PeriodSymbol;
          LastSymbol := PeriodSymbol;  WriteSymbol;  Symbol [1] := '*';
          Symbol[2] := ')';  Length := 2;  WriteSymbol;
          SymbolName := SavedSymbolName;  Length := SavedLength;
          FOR I := 1 TO Length DO Symbol [I] := SavedChars [I]
        END
    END (*WriteComment*);
    
    
    PROCEDURE DoStmtList (EndList: Symbols);
    
    VAR  BlksAfterPrt2: Width;
         AtProcEnd: boolean;
    
    BEGIN
      AtProcEnd := AtProcBeginning;  WriteSymbol;  ReadSymbol;
      StatmtPart [1] := CharCount + 1;  StatmtPart [2] := StatmtPart [1];
      IF SymbolName <> EndList
        THEN BEGIN
          IF ProcNamesWanted THEN IF AtProcBeginning THEN IF
            LastProgPartWasBody THEN IF LastSymbol = BeginSymbol
              THEN WriteComment;
          AtProcBeginning := false;
          DoStatement (AddedBlanks, StatmtSymbol, StmtSymLength);
          BlksAfterPrt2 := AddedBlanks;
          BlksAddedByThisStmt := BlksAddedByThisStmt + AddedBlanks;
          WHILE SymbolName <> EndList DO
            BEGIN
              WriteSymbol;  ReadSymbol;
              IF SymbolName <> EndList
                THEN BEGIN
                  StatmtPart [3] := CharCount + 1;
                  DoStatement (AddedBlanks, StatmtSymbol, StmtSymLength);
                  BlksOnCurrntLine := AddedBlanks + BlksAfterPrt2;
                  BlksAddedByThisStmt := BlksAddedByThisStmt + AddedBlanks;
                  Bunch (StatmtPart [2], StatmtPart [3], CharCount,
                    StatmtSeparation);
                  IF NOT Successful
                    THEN BEGIN
                      BlksAfterPrt2 := AddedBlanks;
                      StatmtPart [2] := StatmtPart [3];
                    END
                    ELSE BlksAfterPrt2 := BlksOnCurrntLine;
                END (*then*)
            END (*while*)
        END (*main then*);
      BlksOnCurrntLine := BlksAddedByThisStmt;
      Bunch (StatmtBeginning, StatmtPart [1], CharCount, SymbolGap);
      StartNewLineAndIndent;  StatmtPart [1] := CharCount;
      REPEAT WriteSymbol;  ReadSymbol
      UNTIL SymbolName IN [Semicolon, UntilSymbol, EndSymbol, ElseSymbol,
          PeriodSymbol];
      IF Successful
        THEN BEGIN
          IF EndList = UntilSymbol
            THEN StatmtPart [4] := StatmtSeparation
            ELSE StatmtPart [4] := SymbolGap;
          Bunch (StatmtBeginning, StatmtPart [1], CharCount, StatmtPart [4]);
        END;
      IF NOT (Successful AND BunchWanted)
        THEN IF EndList = EndSymbol THEN IF LastSymbol = EndSymbol THEN
          IF AtProcEnd AND ProcNamesWanted THEN WriteComment
            ELSE IF EndCommentsWanted THEN WriteComment;
    END (*DoStmtList*);
  


========================================================================================
DOCUMENT :usus Folder:VOL06:format.6.text
========================================================================================

  BEGIN {DoStatment}
    BlksOnCurrntLine := 0;  Successful := false;
    BlksAddedByThisStmt := 0;
    ChangeMarginTo (ActualLeftMargin + IndentIndex);
    StartNewLineAndIndent;  StatmtBeginning := CharCount;
    IF SymbolIsNumber
      THEN BEGIN
        WITH UnWritten [Oldest] DO
          BEGIN
            IndentAfterEOL := IndentAfterEOL - 1 - Length - SymbolGap;
            IF IndentAfterEOL < 0 THEN IndentAfterEOL := 0
          END;
        WriteSymbol;  ReadSymbol {Write LABEL};  WriteSymbol;
        ReadSymbol {Write COLON}
      END;
    CASE StatementTypeOf [SymbolName] OF
      ForWithWhileStatement:
           BEGIN
             { PACK (Symbol, 1, StatmtSymbol [1]);  EQUIVALENT: }
             FOR I := 1 TO AlfaLeng DO StatmtSymbol [1, I] := Symbol [I];
             StmtSymLength := Length;
             REPEAT WriteSymbol;  ReadSymbol
             UNTIL SymbolName = DoSymbol;
             WriteSymbol;  ReadSymbol;  StatmtPart [1] := CharCount + 1;
             DoStatement (AddedBlanks, StatmtSymbol, StmtSymLength);
             BlksOnCurrntLine := BlksOnCurrntLine + AddedBlanks;
             BlksAddedByThisStmt := BlksAddedByThisStmt + AddedBlanks;
             Bunch (StatmtBeginning, StatmtPart [1], CharCount, SymbolGap)
           END;
      RepeatStatemtnt:
           DoStmtList (UntilSymbol);
      IfStatement:
           BEGIN
             { PACK (Symbol, 1, StatmtSymbol [1]);  EQUIVALENT:  }
             FOR I := 1 TO AlfaLeng DO StatmtSymbol [1, I] := Symbol [I];
             StmtSymLength := Length;
             REPEAT WriteSymbol;  ReadSymbol
             UNTIL SymbolName = ThenSymbol;
             StartNewLineAndIndent;  StatmtPart [1] := CharCount;
             WriteSymbol;  ReadSymbol;  StatmtPart [2] := CharCount + 1;
             DoStatement (AddedBlanks, StatmtSymbol, StmtSymLength);
             BlksOnCurrntLine := AddedBlanks;
             BlksAddedByThisStmt := AddedBlanks;
             Bunch (StatmtPart [1], StatmtPart [2], CharCount, SymbolGap);
             IF Successful
               THEN Bunch (StatmtBeginning, StatmtPart [1], CharCount,
                 StatmtSeparation)
               ELSE IfThenBunchNeeded := true;
             If SymbolName = ElseSymbol
               THEN BEGIN
                 { PACK (Symbol, 1, StatmtSymbol [1]);  EQUIVALENT:  }
                 FOR I := 1 TO AlfaLeng DO StatmtSymbol [1, I] := Symbol [I];
                 StmtSymLength := Length;  IfThenBunchNeeded := false;
                 StartNewLineAndIndent;  StatmtPart [3] := CharCount;
                 WriteSymbol;  ReadSymbol;  StatmtPart [4] := CharCount + 1;
                 DoStatement (AddedBlanks, StatmtSymbol, StmtSymLength);
                 BlksOnCurrntLine := AddedBlanks;
                 BlksAddedByThisStmt := BlksAddedByThisStmt + AddedBlanks;
                 Bunch (StatmtPart [3], StatmtPart [4], CharCount, SymbolGap);
                 BlksOnCurrntLine := BlksAddedByThisStmt;
                 IF Successful
                   THEN Bunch (StatmtBeginning, StatmtPart [3], CharCount,
                     StatmtSeparation)
               END
               ELSE IF (CharCount - StatmtBeginning) < BufferSize
                 THEN BEGIN
                   BunchWanted := NOT BunchWanted;
                   BlksOnCurrntLine := 0;
                   Bunch (StatmtBeginning, StatmtPart [1], StatmtPart [2],
                     SymbolGap);
                   BunchWanted := NOT BunchWanted;
                 END;
             IfThenBunchNeeded := false
           END {IfStatement};
      CaseStatement:
           BEGIN
             REPEAT WriteSymbol;  ReadSymbol
             UNTIL SymbolName = OfSymbol;
             WriteSymbol;  ReadSymbol;
             ChangeMarginTo (ActualLeftMargin + IndentIndex);
             WHILE SymbolName <> EndSymbol DO
               BEGIN
                 StartNewLineAndIndent;  StatmtPart [1] := CharCount;
                 { FOR I := 0 TO (Length - 1) DIV AlfaLeng DO
                   PACK (Symbol, (I + AlfaLeng + 1), StatmtSymbol [I + 1]);}
                 { EQUIVALENT:  }
                 FOR I := 0 TO (Length - 1) DIV AlfaLeng DO
                   FOR J := 1 TO AlfaLeng DO
                   StatmtSymbol [I + 1, J] := Symbol [J + I * AlfaLeng];
                 StmtSymLength := Length;
                 REPEAT WriteSymbol;  ReadSymbol
                 UNTIL SymbolName = ColonSymbol;
                 WriteSymbol;  ReadSymbol;
                 IF NOT (SymbolName IN [Semicolon, EndSymbol])
                   THEN BEGIN
                     StatmtPart [2] := CharCount + 1;
                     DoStatement (AddedBlanks, StatmtSymbol, StmtSymLength);
                     BlksOnCurrntLine := AddedBlanks;
                     BlksAddedByThisStmt := BlksAddedByThisStmt + AddedBlanks;
                     Bunch (StatmtPart [1], StatmtPart [2], CharCount, SymbolGap);
                   END;
                 IF SymbolName = Semicolon
                   THEN BEGIN WriteSymbol;  ReadSymbol END
               END {while};
             ChangeMarginTo (ActualLeftMargin - IndentIndex);
             StartNewLineAndIndent;  WriteSymbol;  ReadSymbol;
             IF EndCommentsWanted AND (LastSymbol = EndSymbol)
               THEN BEGIN
                 StatmtSymbol [1] := 'CASE      ';  StmtSymLength := 4;
                 WriteComment
               END
           END {CaseStatement};
      OtherStatement:
           WHILE NOT (SymbolName IN [Semicolon, UntilSymbol, EndSymbol,
               ElseSymbol]) DO
             BEGIN  WriteSymbol;  ReadSymbol  END;
      CompoundStatement:
           DoStmtList (EndSymbol)
    END {main case };
    AddedBlanks := BlksAddedByThisStmt;
    ChangeMarginTo (ActualLeftMargin - IndentIndex);
  END {DoStatement};
  

BEGIN {DoBlock}
  IF CharCount > BufferSize * 2         {clear out buffer if too long - JLG}
    THEN CharCount := (CharCount MOD BufferSize) + BufferSize;
  LastProgPartWasBody := LastProgPartWasBody AND (SymbolName = BeginSymbol);
  IF SymbolName = LabelSymbol THEN DoDeclarationUntil (EndLabel);
  IF SymbolName = ConstSymbol THEN DoDeclarationUntil (EndConst);
  IF SymbolName =  TypeSymbol THEN DoDeclarationUntil (EndType );
  IF SymbolName =   VarSymbol THEN DoDeclarationUntil (EndVar  );
  WHILE SymbolName IN [SegmntSymbol, FuncSymbol, ProcSymbol] DO DoProcedures;
  IF SymbolName = BeginSymbol
    THEN BEGIN
      IF LastProgPartWasBody
        THEN FOR I := 2 TO ProcSeparation DO StartNewLineAndIndent;
      IfThenBunchNeeded := false;  AtProcBeginning := true;
      ChangeMarginTo (ActualLeftMargin - IndentIndex);
      DoStatement (I, BlockName, BlockNmLength) {I is dummy param};
      LastProgPartWasBody := true;
      ChangeMarginTo (ActualLeftMargin + IndentIndex)
    END
    ELSE BEGIN WriteSymbol;  ReadSymbol {Write FORWARD } END
END {DoBlock};


PROCEDURE DoImplementationDeclaration;
VAR I: integer;
BEGIN
  ChangeMarginTo (ActualLeftMargin + IndentIndex);
  IF SymbolName = LabelSymbol THEN DoDeclarationUntil (EndLabel);
  IF SymbolName = ConstSymbol THEN DoDeclarationUntil (EndConst);
  IF SymbolName =  TypeSymbol THEN DoDeclarationUntil (EndType );
  IF SymbolName =   VarSymbol THEN DoDeclarationUntil (EndVar  );
  WHILE SymbolName IN [ProcSymbol, FuncSymbol] DO
    BEGIN
      FOR I := 2 TO ProcSeparation DO StartNewLineAndIndent;
      StartNewLineAndIndent;
      WriteSymbol;  ReadSymbol;  WriteSymbol;  ReadSymbol;
      IF SymbolName = LeftParenth
        THEN BEGIN
          REPEAT WriteSymbol;  ReadSymbol UNTIL SymbolName = RightParenth;
          WriteSymbol;  ReadSymbol;
        END;
      IF SymbolName = ColonSymbol
        THEN REPEAT WriteSymbol;  ReadSymbol UNTIL SymbolName = Semicolon;
      WriteSymbol {semicolon};  ReadSymbol 
    END;
  ChangeMarginTo (ActualLeftMargin - IndentIndex);
  FOR I := 1 TO ProcSeparation DO StartNewLineAndIndent;
  StartNewLineAndIndent;  WriteSymbol;  ReadSymbol {write IMPLEMENTATION part}
END;

  
PROCEDURE Initialize;

VAR I: Width;
    InfileName, OutfileName:  string [25];

BEGIN {Constants:}
  Digits := ['0'..'9'];  Letters := ['A'..'Z', 'a'..'z'];       {JLG}
  LettersAndDigits := Letters + Digits;
  AlphaSymbols := [ProgSymbol, BeginSymbol, EndSymbol, ConstSymbol,
      TypeSymbol, RecordSymbol, CaseSymbol, IfSymbol, ThenSymbol,
      ElseSymbol, DoSymbol, OfSymbol, ForSymbol, WithSymbol,
      WhileSymbol, RepeatSymbol, UntilSymbol, Identifier, VarSymbol,
      ProcSymbol, FuncSymbol, LabelSymbol, AlphaOperator];
  EndLabel := [ConstSymbol, TypeSymbol, VarSymbol, ProcSymbol,
      FuncSymbol, BeginSymbol];
  EndConst := EndLabel - [ConstSymbol];
  EndType := EndConst - [TypeSymbol];
  EndVar := EndConst - [VarSymbol];
{ Initialize Column Data: }
  WriteColumn := 0;  LeftMargin := 0;  ActualLeftMargin := 0;
  OutputCol := 1;  ReadLeftCol := 1;  ReadRightCol := MaxReadRightCol;
  WriteLeftCol := 1;  WriteRightCol := MaxWriteRightCol;  Oldest := 1;
  CharCount := 1;  LineNumber := 0;  Increment := 0;
{ Initialize Boolean Parameters: }
  PackerIsOff := true;  BunchWanted := false;  DisplayIsOn := true;
  ProcNamesWanted := true;  EndCommentsWanted := false;
  NoFormatting := false;  LastSymWasRange := false;
{ Initialize Numeric Parameters: }
  IndentIndex := 3;  LongLineIndent := 3;  ProcSeparation := 2;
  SymbolGap := 1;  StatmtSeparation := 3;  DeclarAlignment := 0;
{ Initialize Input Context Data: }
  ReadColumn := 1;  ChIsEOL := false;  NextChIsEOL := false;
  FOR I := 0 TO BufferSize DO Symbol [I] := ' ';
  LastSymbol := PeriodSymbol;  LastProgPartWasBody := false;
{ Now get filenames }
  Writeln;
  Writeln ('Welcome to the     P a s c a l   F O R M A T T E R.':65);
  Writeln ('From the Pascal News No. 13.  Written by Michael Condict.':68);
  REPEAT
    Writeln;
    Write ('Please type input file name --> ');
    Readln (Infilename);
    IF Infilename = '' THEN EXIT (Program);
    {$I-}
    Reset (Infile, Infilename);
    IF IORESULT > 0 THEN Reset (Infile, CONCAT (Infilename, '.TEXT'));
    {$I+}
    I := IORESULT;
    IF I > 0 
      THEN BEGIN
        Writeln ('Oops, something''s wrong.  IORESULT = ', I);
        Writeln ('To exit the program, just type <RETURN>.');
      END
  UNTIL I = 0;
  REPEAT
    Write ('Now the output filename (type <return> if you wish to print):  ');
    Readln (Outfilename);
    IF Outfilename = '' THEN Outfilename := 'PRINTER:';
    IF (Outfilename = 'quit') OR (Outfilename = 'QUIT') THEN Exit (Program);
    {$I-}
    Rewrite (Outfile, outfilename);
    {$I+}
    I := IORESULT;
    IF I > 0 
      THEN BEGIN
        Writeln ('Oops, something''s wrong.  IORESULT = ', I);
        Writeln ('To exit the program, just type "QUIT".');
      END
  UNTIL I = 0;
  END {Initialize };


BEGIN {MAIN PROGRAM !!!}
  ConstantsInitialization;  Initialize;  GetNewInitValues;
  IF eof(Input)
    THEN Writeln (' *** No Program Found To Format')
    ELSE BEGIN
      ReadACharacter;  ReadSymbol;
      WHILE SymbolName = Comment DO ReadSymbol; {JLG}
      ThisIsAUnit := SymbolName = UnitSymbol;
      IF NOT (SymbolName IN [ProgSymbol, UnitSymbol])
        THEN BEGIN WriteSymbol;  ReadSymbol END; {skip SEPARATE/INTRINSIC JLG}
      IF NOT (SymbolName IN [ProgSymbol, UnitSymbol])
        THEN Writeln ('  ***  "PROGRAM" or "UNIT" EXPECTED.')
        ELSE BEGIN
          StartNewLineAndIndent;  WriteSymbol;  ReadSymbol;
          { FOR I := 0 TO (Length - 1) DIV AlfaLeng DO
            PACK (Symbol, (I * AlfaLeng + 1), Main [I + 1]); }
          {EQUIVALENT:}
          FOR I := 0 TO (Length - 1) DIV AlfaLeng DO  FOR J := 1 TO AlfaLeng
            DO Main [I + 1, J] := Symbol [J + I * AlfaLeng];
          IF ThisIsAUnit THEN MainNmLength := 0 ELSE MainNmLength := Length; 
          REPEAT WriteSymbol;  ReadSymbol UNTIL SymbolName = Semicolon;
          WriteSymbol;  ReadSymbol;  StartNewLineAndIndent;
          WHILE (SymbolName IN [Semicolon, Comment, CommaSymbol, Identifier])
            DO BEGIN WriteSymbol;  ReadSymbol END;                     {JLG}
          IF ThisIsAUnit THEN DoImplementationDeclaration;
          StartNewLineAndIndent;
          DoBlock (Main, MainNmLength);  
          WriteA ('.');  FlushUnwrittenBuffer;
          Close (Outfile, lock)
        END
    END
END {main program }.
    

========================================================================================
DOCUMENT :usus Folder:VOL06:format.doc.text
========================================================================================


     
                              FORMAT DOCUMENTATION

     The following text accompanied the program listing in Pascal News, No. 13 
(December 1978).  For further comments, see "PRETTY.DOC.TEXT" elsewhere on 
this disk.

     
     
What Format Does

     Format is a flexible prettyprinter for Pascal programs.  It takes as 
input a syntactically correct Pascal program and produces as output an 
equivalent but reformatted Pascal program.  The resulting program consists of 
the same sequence of Pascal symbols and comments, but they are rearranged with 
respect to line boundaries and columns for readability.

     Format maintains consistent spacing between symbols, breaks control and 
data structures onto new lines if necessary, indents lines to reflect the 
syntactic level of statements and declarations, and more.  Miscellaneous 
features, such as supplying line numbers and automatic comments or deleting
all unnecessary blanks to save space, are described below.

     The flexibility of Format is accomplished by allowing you to supply 
various directives (options) which override the default values.  Rather than 
being a rigid prettyprinter which decides for you how your program is to be 
formatted, you have the ability to control how formatting is done, not only 
prior to execution, but also during execution through the use of prettyprinter 
directives embedded in your program.

     Experience with Format over the last three years has shown that most 
users can find a set of values for the directives which produce satisfactory 
results.  The default values are typical.

     
How To Use Format

     The use of Format will vary from implementation to implementation, but 
will involve one major input file containing a Pascal program and one output 
file for the reformatted program.  Additionally it may be possible to supply 
the initial values of directives to Format when it begins execution.
[NOTE to UCSD users: I did not implement this feature, though it should be
easy to do.]

     Directives to Format may always be specified in the program itself inside 
comments with a special syntax.  Thus the first line of a program is an ideal 
spot for a comment containing directives.  Subsequent use of embedded 
directives allows you to change the kind of formatting for different sections 
of your program.  The syntax of these special comments is given below (The 
syntax is given using "EBNF"--Extended Backus-Naur Form--see Communications 
ACM, November, 1977, page 822.):

DirectiveComment = "(*" DirectiveList "*)" |
                       "(*$" CompilerOptionList CommentText DirectiveList"*)".

   
   DirectiveList = "["  Directive  {"," Directive}  "]"  CommentText.

       Directive = Letter Setting.

          Letter = "A"| "B"| "C"| "D"| "E"| "F"| "G"| "H"|
                   "I"| "L"| "N"| "P"| "R"| "S"| "W".

         Setting = Switch | Value | Range.

          Switch = "+" | "-".

           Value = "=" Unsigned Integer.
      
           Range = "="UnsignedInteger "-" UnsignedInteger ["<" | ">"].
      
 UnsignedInteger = Digit(Digit).

     CommentText = (Any character except "]" or close-comment).

Note:  As defined above, a Directive may be within a comment specifying a 
Pascal CompilerOptionList.  On most implementations this is a "$" followed by 
a series of letters and values ("+", "-", or digits), separated by commas.  
See your local manual.

Examples of DirectiveComments:

     (*[A=15, E=3, N=1,1<]*) - good for publication quality.
     (*[G-0, W=1-100, C+]*) - good for compact storage.
     (*$U+ [R=1-72, I=2]*) - an example of a DirectiveList with a
                             CompilerOptionList.

     
Directives to Format.

A=n  Align declarations.
        The A directive forces the alignment of ":" and "=" in declarations.  
        If A is set to a value greater than O, then n should be equal to the
        maximum identifier length for that section of your program.  The A
        directive visually clarifies the declaration part of your program.  
        See example below.
        Default:  A=O (no alignment).

 B+ or B-  Bunch statements and declarations reasonably.
        B+ will place as many statements or declarations onto one line as will 
        fit within the specified write margins (W directive) subject to read-
        ability constraints.  Bunching (B+) when the display is off (D-) has 
        no effect.  In general, B+ saves paper and prevents your program from
        becoming overly stretched in the vertical direction.  See example  
        below.
        Default:  B- (one statement or statement part per line).
  
C+ or C-  Fully Compress program.
        C+ removes all non-essential blanks, end-of-lines, and comments from 
        your program.  A compilable, packed program will be written within the
        specified write margins (W directive).  The number of spaces specified
        by the G directive will still be written between symbols.  C+ might 
        save some space on long-term storage media such as disk; you might 
        store a program in compressed form and expand it later by reformatting
        with C-.
        Default:  C-.

D+ or D-  Turn Display on or off.
        D allows you to selectively display portions of your program during 
        formatting.  Therefore, D must be switched on and off with directives
        which are appropriately placed in your program.  D is perhaps useful
        to obtain program fragments for publication (such as one or more pro-
        cedures) without having to print the whole program.
        Default:  D+.
        
E=n  Supply END comments.
        The E directive generates comments after "END" symbols if none are 
        already there.  Common Pascal coding styles frequently employ these
        comments.  E=1 creates comments after the "END" symbol in compound
        statements which are within structured statements, as well as those
        constituting procedure and function bodies.  The comments take the 
        form:  (*StatementPart*) or (*ProcedureName*).  E=2  creates comments
        after the "BEGIN" and "END" symbols constituting procedure and func-
        tion bodies only.  E=O creates no comments at all.  E=3 means E=1
        and E=2.  See example below.
        Default:  E=2.
        
F+ or F-  Turn Formatting on or off.
        F allows you to format selected portions of your program.  F- causes
        Format to copy the input program directly with no changes.  Therefore
        by switching F on and off with directives which are appropriately
        placed in your program, you can preserve text which is already 
        properly formatted (such as comments).
        Default:  F+ (of course!).
        
G=n  Specify symbol Gap.
        The G directive determines the number of spaces placed between Pascal
        symbols during formatting.  G=O still places one space between two 
        identifiers and reserved words.  The symbols [] () , and : are handled 
        independently of G.  
        Default:  G=1.
        
I=n  Specify Indent tab. 
        I indents each nesting level of statements and declarations a given
        number of columns.  Using  I=2  or  I=1 helps prevent excessively-
        narrow lines within the specified write margins (W directive) where 
        there are heavily-nested constructs.  
        Default:  I=3.
        
L=n  Specify Line-wraparound indent tab.
        L  determines the indentation of the remainder of statements or 
        declarations which are too long to fit on one line.
        Default:  L=3.
        
N=x-y< or N=x-y>  Generate line-numbers on the left or right.
        The N directive indicates the starting line-number (x) and the incre-
        ment (y) for each succeeding line-number.  If y > O then line-numbers
        are written outside the specified write margins for the formatted pro-
        gram in sequential order starting at x; y = O shuts off line-number-
        ing.  "<" writes up to 4-digit, right-justified line numbers together 
        with a trailing space ot the left of each line.  ">" writes 6-digit, 
        zero-filled line numbers to the right of each line.  Use the N 
        directive along with the W directive.
        Default:  N=0-0> (no line numbers).
        
P=n  Specify spacing between Procedure and function declarations.
        The P directive determines the number of blank lines to be placed 
        between procedure and function declarations.  n>2 makes procedures and 
        functions visually stand out.
        Default:  P=2.
        
R=x-y  Specify Read margins.
        The R directive indicates which columns are significant when Format 
        reads from the input file.  R allows Format to accept files which have 
        line numbers in the first (x-1) columns or after the y~h column.
        Default:  R=1-999 (large enough to read end-of-line in most cases).
        
S=n  Specify Statement separation.
        The S directive determines the number of spaces between statements 
        bunched on the same line by the use of the B+ directive.  Note that 
        this directive is in effect only if B+ is used.
        Default:  S=3.
        
W=x-y  Specify Write margins.
        The W directive indicates which columns are used for writing the 
        reformatted program on the output file.  Any line numbers generated (N 
        directive) are written outside these margins.
        Default:  N=1-72.
        


EXAMPLES
        

The A directive.
        
Here is a sample program fragment before using Format:
     
     PROGRAM SAMPLE(OUTPUT);
     CONST A=6; ABC='LETTERS'; THREE=3;
     TYPE RANGE=1..6;
     COLOR=(RED,BLUE);
     VAR
     I,I2,I33,I444,I555:RANGE;
     YES,NO,MAYBE:BOOLEAN;
     BEGIN END.
     
Here is the output from Format with all defaults set:
     
     PROGRAM SAMPLE(OUTPUT);
     
     CONST
        A = 6;
        ABC = 'LETTERS';
        THREE = 3;
     
     TYPE
        RANGE = 1 .. 6;
        COLOR =
           (RED, BLUE);
           
     VAR
        I, I2, I33, I444, I5555: RANGE;
        YES, NO, MAYBE: BOOLEAN;
        
     BEGIN
     END (*SAMPLE*).
     
Here is the output from Format with an added A=5 directive:

     (*[A=5] ALIGN DECLARATIONS.  *)
     PROGRAM SAMPLE(OUTPUT);
     
     CONST
            A = 6;
          ABC = 'LETTERS';
        THREE = 3;
     
     TYPE
        RANGE = 1 .. 6;
        COLOR = (RED, BLUE);
           
     VAR
             I, 
            I2, 
           I33, 
          I444, 
         I5555: RANGE;
           YES, 
            NO, 
         MAYBE: BOOLEAN;
        
     BEGIN
     END (*SAMPLE*).
     
     
The B Directive.

If the input to Format is:

     PROGRAM T(OUTPUT);
     CONST INCREMENT = 5;
     VAR I,J,N:INTEGER;
     BEGIN
     N:=0;
     J:=3; I:=SQR(N); N:=N+INCREMENT;
     IF N>73 THEN BEGIN DOTHIS; DOTHAT END ;
     IF N>5 THEN  IF J>6 THEN DOSOMETHINGELSE;
     END.
     
then the output from Format (using the default, B-) is:

     PROGRAM T(OUTPUT);
     
     CONST
        INCREMENT = 5;
      
     VAR
        I,J,N:INTEGER;
     
     BEGIN
        N:=0;
        J:=3; 
        I:=SQR(N); 
        N:=N + INCREMENT;
        IF N>73 THEN
           BEGIN
              DOTHIS; 
              DOTHAT
           END;
        IF N>5 THEN
           IF J>6 THEN
              DOSOMETHINGELSE;
     END (*T*).
     
and the output from Format with B directives embedded is:

     (*[B+] BUNCH STATEMENTS.  *)
     PROGRAM T(OUTPUT);
     
     CONST
        INCREMENT = 5;
      
     VAR
        I,J,N:INTEGER;
     
     BEGIN
        N:=0;   J:=3;   I:=SQR(N);   N:=N + INCREMENT;
        IF N>73   THEN BEGIN DOTHIS;   DOTHAT END;
     (*[B-] UNBUNCH.  *)
        IF N>5 THEN
           IF J>6 THEN
              DOSOMETHINGELSE;
     END (*T*).
     

The E Directive.

Suppose that a Pascal program fragment looked like:

     PROCEDURE SAMPLE;
       PROCEDURE INNER;
       BEGIN END;
     BEGIN
       IF X=3 THEN
                 BEGIN X := 1; I := I+1
                 END
              ELSE
                BEGIN X := X+I; I := 0
                END;
       WHILE (CH <> 'X') AND FLAG1 DO
         BEGIN I := I+3; INNER END; END;
         
 then using Format with E=3 produces:
 
     PROCEDURE SAMPLE;
       
       
       PROCEDURE INNER;
       
       
          BEGIN 
          END (*INNER*);
     
     
     BEGIN (*SAMPLE*)
        IF X=3 
        THEN
           BEGIN
              X := 1; 
              I := I+1
           END (*IF*)
        ELSE
           BEGIN
              X := X+I; 
              I := 0
           END (*ELSE*);
        WHILE (CH <> 'X') AND FLAG1 DO
           BEGIN
              I := I+3; 
              INNER 
           END (*WHILE*); 
     END (*SAMPLE*);
         
         
 How Format Works.
 
     Format parses your program by performing syntax analysis similar to the 
Pascal compiler:  recursive descent within nested declarations and statements. 
It gathers characters into a buffer in which the indenting count of each 
character is maintained.  The characters are being continually emptied from 
the buffer as new ones are added.

     Format has limited error-recovery facilities, and no results are 
guaranteed if a syntactically incorrect program is input.

     The bane of most Pascal prettyprinters is the treatment of comments.  
Format considers them in the context of a declaration or statement.  Therefore 
using comments like:

     CONST LS=6 (*LINESIZE*);

is a good idea because Format will carry the comment along with the 
declaration.  Similarly:

     BEGIN (* 'Z' < CH <= ' ' *)

is also okay.

     Stand-alone comments, however, receive rough treatment from Format.  The 
first line of such comments is always left justified and placed on a separate 
line.  See the F directive.  Thus:

     CONST LS=6; (*LINESIZE*)

will be reformatted as:

     CONST
        LS = 6;
     (*LINESIZE*)

     Proper treatment of comments is certainly an area of future development 
for Format.

     
Error Messages.

     Format issues the following error messages:

1.  " *** 'PROGRAM' EXPECTED."
     The Pascal program you fed to Format did not contain a Standard Pascal 
program declaration.

2.  " *** ERRORS FOUND IN PASCAL PROGRAM."
     Your program is syntactically incorrect.  The output from Format probably 
does not contain all of the text from your input file.  The cause could be any 
syntactic error, most commonly unmatched "BEGIN-END" pairs or the lack of 
semicolons, string quotation marks, or the final period.

3.  " *** STRING TOO LONG."
     Your program contains a character string (including both the quotes) 
which is wider than the specified write margins (W directive).

4.  " *** NO PROGRAM FOUND TO FORMAT."
     The input file is empty.


========================================================================================
DOCUMENT :usus Folder:VOL06:format.text
========================================================================================

{$S+}
{ PROGRAM Format 

        THE PASCAL PROGRAM FORMATTER
        
        AUTHOR:  Michael M. Condict, 1975
                 Par Corp.
                 228 Liberty Plaza
                 Rome, NY 13440
        UPDATED: Aug 1978, by Rick Marcus & Andy Mickel, then
        PUBLISHED in Pascal News No. 13
        
        CONVERTED TO UCSD PASCAL, IDENTIFIER CASE-TRANSPARENCY ADDED:  Jan 1980
        EXTENSIVELY REVISED (SEE ACCOMPANYING DOCUMENTATION):  Aug 1980
                 Jim Gagne
                 1433 Roscomare Road
                 Los Angeles
                 
THIS PROGRAM IS FOR NONCOMMERCIAL USE ONLY.  FOR ALL OTHER PURPOSES, FIRST
CONTACT MICHAEL CONDICT.}

{$IFORMAT.1.TEXT}
{FORMAT.1 contains the global declarations & constants initialization sections.}

{$IFORMAT.2.TEXT}
{FORMAT.2 has the (largely) original text from FORMAT.1 thru WRITESYMBOL.}

{$IFORMAT.3.TEXT}
{FORMAT.3 is the new menu-driven parameter setting section.}

{$IFORMAT.4.TEXT}
{FORMAT.4 contains a revised READSYMBOL, including the expanded 
 comment-handling part.}

{$IFORMAT.5.TEXT}
{FORMAT.5 has the middle portion of the original FORMAT, to DOSTMTLIST.}

{$IFORMAT.6.TEXT}
{FORMAT.6 wraps up with the rest of DOBLOCK, DOSTATEMENT, etc., with many 
 changes near the end.}

========================================================================================
DOCUMENT :usus Folder:VOL06:hangup.a.text
========================================================================================

; NOTE THIS IS THE SAME ROUTINE AS USED BY MODEM INIT
        
        .PROC   HANGUP,0 
        .PRIVATE RETADDR

MCNTRL  .EQU    0C3H            ;STATUS PORT
IDLE    .EQU    03FH            ;DEFINES IDLE STATE FOR PMMI MODEM
        POP     HL
        LD      (RETADDR),HL
        LD      A,IDLE
        OUT     (MCNTRL),A     ;SET MODEM TO IDLE STATE
        LD      HL,(RETADDR)
        JP      (HL)
        .END


========================================================================================
DOCUMENT :usus Folder:VOL06:kbstat.a.text
========================================================================================

        .FUNC   KBSTAT,0
        .PRIVATE RETADDR
        POP     HL
        LD      (RETADDR),HL
        POP     HL              ;CORRECT STACK
        POP     HL
        LD      HL,RADDR        ; RETURN ADDRESS
        PUSH    HL
        LD      HL,(1)
        LD      L,6
        JP      (HL)
RADDR   OR      A               ; SET FLAGS
        LD      HL,1
        JP      NZ,DONE         ;READY
        LD      HL,0            ;FALSE
DONE    PUSH    HL
        LD      HL,(RETADDR)
        JP      (HL)
        .END


========================================================================================
DOCUMENT :usus Folder:VOL06:modemini.a.text
========================================================================================

        .PROC   MODEMINIT,0 
        .PRIVATE RETADDR

MCNTRL  .EQU    0C3H            ;STATUS PORT
IDLE    .EQU    03FH            ;DEFINES IDLE STATE FOR PMMI MODEM
        POP     HL
        LD      (RETADDR),HL
        LD      A,IDLE
        OUT     (MCNTRL),A     ;SET MODEM TO IDLE STATE
        LD      HL,(RETADDR)
        JP      (HL)
        .END


========================================================================================
DOCUMENT :usus Folder:VOL06:mread.a.text
========================================================================================


        .FUNC   MREAD,0
        .PRIVATE RETADDR
TPORT   .EQU    0C0H            ;STATUS PORT
DPORT   .EQU    0C1H            ;DATA PORT
RECRDY  .EQU    02H             ;REC BUF FULL
        POP     HL
        LD      (RETADDR),HL    ;SAVE RET ADDR
        POP     HL              ;CORRECT STACK
        POP     HL              ;CORRECT STACK
WAIT:   IN      A,(TPORT)        ;READ STATUS WORD
        AND     RECRDY          ;IS REC FULL
        JP      Z,WAIT
        IN      A,(DPORT)
        LD      L,A             ;STORE FOR RETURN
        PUSH    HL              ;RETURN VALUE ON STACK
        LD      HL,(RETADDR)
        JP      (HL)
        .END



========================================================================================
DOCUMENT :usus Folder:VOL06:mrecstat.a.text
========================================================================================

        .FUNC   MRECSTAT,0
        .PRIVATE RETADDR
TPORT   .EQU    0C0H
RECRDY  .EQU    2H
        POP     HL
        LD      (RETADDR),HL
        POP     HL              ;CORRECT STACK
        POP     HL
        LD      HL,1            ;TRUE 
        IN      A,(TPORT)       ;READ STATUS
        AND     RECRDY          ;CHECK READ STATUS
        JP      NZ,DONE         ;REC NOT RDY
        LD      HL,0            ;FALSE
DONE    PUSH    HL
        LD      HL,(RETADDR)
        JP      (HL)
        .END


========================================================================================
DOCUMENT :usus Folder:VOL06:mwrite.a.text
========================================================================================

        .PROC   MWRITE,1
        .PRIVATE OUTC,RETADDR
TSTAT   .EQU    0C0H            ;STATUS PORT
DATA    .EQU    0C1H            ;DATA PORT
TRE     .EQU    01H             ;XMIT REG EMPTY    

        POP     HL
        LD      (RETADDR),HL
        POP     HL
        LD      (OUTC),HL
WAIT:   IN      A,(TSTAT)        ;GET STATUS
        AND     TRE             ;CK STATUS        
        JP      Z,WAIT          ;XMIT BUSY 
        LD      A,(OUTC)
        OUT     (DATA),A        ;SEND DATA
        LD      HL,(RETADDR)
        JP      (HL)
        .END


========================================================================================
DOCUMENT :usus Folder:VOL06:ptp-files.text
========================================================================================


The following files make up the Pascal Transfer Program:

PTP.TEXT - This the main program written entirely Pascal.

PTP.CODE - A compiled but not linked version of the main program PTP.TEXT.
           PTP.TEXT requires a 56K system to compile therefore 
           this precompiled version can be used as the main program
           during linking by those with less memory. Be sure not
           to call the outfile of the linker PTP.CODE or this
           file will be destroyed.


PTPMMI.CODE - A linked version ready to run with a PMMI modem.

SYSNAME  - A text file that contains the nodes id string (see example).

KBSTAT   - An assemble language function which return a TRUE if
           there is a character ready at the keyboard port.
           Since this routine calls the CP/M keyboard status
           routine it should work with most system that use
           the CP/M BIOS.
           
MRECSTAT - An assemble language function which returns TRUE if 
           there is a character ready at the modem receiver port.

MREAD    - An assemble language function which returns a character 
           from the modem receive port. If no character is ready this 
           routine will wait for one. This routine could be replaced
           by a read from unit #7 (remote in) if implemeted in your
           system.
           
MWRITE   - An assemble language procedure which writes a character
           to the modem xmit port. If the line is busy this routine will
           wait for the line to become ready. This routine could
           be replaced by a write to unit #7 (remote out) if 
           implemented in your system.

MODEMINI - An assemble language routine to initialize the modem at
           startup.

HANGUP   - An assemble language routine to hangup the phone (on hook)

CTS      - Returns TRUE if clear-to-send is set on the modem (may use
           carrier detect on other modems). Indicates that a connection
           is established.
           
DTRON    - Turns data-terminal-ready on to allow the modem to operate.

RINGING  - Returns TRUE if the phone is ringing.

RI       - Set the ring-indicator in the PMMI modem causing the modem
           to go off-hook in answer mode.
           
SH       - Causes the modem to go off-hook in orginate mode.

DTONEDET - Returns TRUE if a dial tone is detected.

DIALER   - Dials one digit of a phone number, digit maybe in either
           ASCII or binary.
           
BAUD     - Set the specified baud rate. The value passed to this assemble
           language routine must be the value to output to the modem not
           necessarly the actual baud rate. Baud rate calculations are
           done in the PASCAL program.



========================================================================================
DOCUMENT :usus Folder:VOL06:ptp-inst.text
========================================================================================


     The PTP system is made up of a large Pascal program and 13 small
assemble language routines, and one small text file. The large Pascal program
should work with most systems and because it requires 56K to compile a
precomplied version PTP.CODE has been provided. The text of this file
is too large for the L1 editor you may wish to break it into smaller
files.

     With the exception of the routine KBSTAT most of the assemble language
will have to modified to work with your system. The current modem routines
are intended to work with the PMMI modem, if some of the functions are not
available in your system these routines can be replaced with dummies. The
routine KBSTAT should work with most system that use CP/M BIOS. After
modifing these routines for your system they can be entered into the comm
libraries which is then linked with PTP.CODE (be sure to use another name for
the output file so as to not destroy this file).
 
     If you do not understand the library procedures you can link the program
by entering each of the routine names when the linker asks for lib file.
PTP.CODE is always used as the host file. The library "system.library" is
not used by this program and automatic linking which may occur if you say run
after compiling will not work correctly.
 
     The file systemname.text should contain the lat/long of your system and 
your system name. This file can be edited with the standard editor.

 
 

========================================================================================
DOCUMENT :usus Folder:VOL06:ptp-use.text
========================================================================================


          An Introduction to Using the Pacsal Transfer Program

     This brief introduction will hopefully provide you with enough
information to run PTP. The first question you will be asked after starting
PTP is if your system can support binary mode. Inorder to support this 
your modem (serial port) must be able to pass any 8-bit byte to the PTP
program (most home systems can do this - most time sharing systems can not).
Binary mode always considerably fast transfer and should be used if
possible. The next questions select valid speeds at which your modem can
operate. Simply answer yes to the valid baud rates. To support mulitple baud
rates your modem baud rate must be software settable with the baud assembly
language routine, if is not answer yes only to the 300 baud rate which will
keep the baud rate at its inital value. Because the program uses a split baud
rate for transmit and receive during baud rate negotiation it is not possible
to switch baud rates manually. 

     Next the number of data characters that can be sent and  received in
one packet is requested. The actual packet maybe considerable larger due to
packet overhead. The larger the packet the more likely a transmission error
will occur.

     The answer or orginate mode of the program must be different for two
communciating programs. This is set to orginate mode when you dial a number
and to answer when you go into an answer mode. The mode of the modem is set
to the same mode as the program. 
     
     The top level menu varies depending upon if a carrier is detect. In
the case there is no carrier the menu is as followed:

     Autoans  - Wait for the phone to ring, answer in answer mode and
                establish a connection. Typing any character will abort this 
                mode.

     Cntdial  - Continously redial the number after a delay in an attempt to 
                establish a connection.

     Dial     - Dial the number to be supplied. Do not use in spaces or other 
                characters inbetween digits. A "*" should cause the dialer to 
                wait for another dial tone detect (not tested). Typing any
                character will interrupt this function.

     Exit     - Exit the PTP program.

     Go       - Used to continue when a modem connection is already 
                established.

     Hangup   - Hangup the phone.

     Options  - Go to the options menu (see below).

     Redial   - Redial the number last dialed.

     Unattended - Same as autoanswer except that the program will go
                back into the autoanswer mode at the end of a connection
                to wait for the next call. Typing any character will exit
                this mode.

If a carrier is present the top level menu will be a subset of the above. The 
"go" command in this case causes the modems to attempt to establish a 
connection (usefully when you have been using voice and now wish to
connect the programs without having to hangup).

     The options menu allows the following options to be set:

     PTP - Set the PTP mode which is what the program is all about.

     Mode- Allows the resetting of the modes and baud rates setup
           when the program was started. This will result in the 
           renegotion of the mode and baud rates with the other
           computer.

     Trace- Set the tracing flags used for debugging. Also used to set
           the local loopback mode (see trace below).
     
     Raw - This puts you in a raw terminal mode in which makes the system
           look like a terminal and is intented mainly to allow logging 
           into timesharing systems. Type a control-E to exit this mode.
     
     Baud- Set the baud rate to be used in raw mode.

     Fullduplex - Set full duplex raw mode.

     Halfduplex - Set half duplex raw mode.
     
     If you have made contact with another PTP both programs should now be in
a loop sending empty packets back and forth. The first thing you will see
after a connection is established is the id of the other program. 
After this the programs will negotate binary or radix-41 mode, the baud rate 
and buffer sizes. At this point you may try to send a terminal to terminal
message. To do this type the first character of the message and wait for a
">" follwed by the character you typed. Type the rest of the message and hit
return (if the message is to long echoing will stop and the first part will
be sent). The message will then be sent to the other PTP. It should be
realised that whenever a PTP program is waiting for a character from the
keyboard it will not be listening or sending on the modem line. This will
cause the PTP on the other end to timeout while waiting for a transmission
and display a receiver timeout message. If this were to continue for a long
time the PTP on the other end would finally give up and abort. Also even
after you finish typing your message it may take several transmissions for
the programs to get their half duplex transmissions resynced (both programs
may be sending at the same time and miss part of the other's transmission).
This condition should correct itself shortly since the timeout for answer and
orginate modes are different.
 
     To send files or perform other functions it is first necessary to get
the attention of the PTP, to do this type a control-E and wait. A menu should
be displayed shortly simlar to the type displayed by the UCSD Pascal system.
It should be remebered that when the program is in this mode it is the other
PTP will be experiencing receiver timeouts. To exit the menu function and
return control to PTP just hit a carriage return to the menu display. The
following is a description of the current menu functions:

     Get - Get a file from the other system. It should be noted that you
           must already know the name of the file you wish transfered
           and there is no remote list directory function. For this
           reason it would be a good idea if each system contained a
           file with the well know name "dir.text" which contains the 
           name of the files which that person is willing to have
           transfered. 

     Send - Send a file from your system to the other system. The PTP
            program will not create a file on a system if it already
            exists. This is to prevent overwriting files on the other
            system which you did not know existed.

     Init - This function will reinitialize most of the counters
           in the program. If you are in contact with another PTP
           this will result in a loss of sequencing.
    
     Exit - Will cause PTP to terminate and return to the top menu level.

     Mode- See mode above.

     Trace- See trace below.

     
     Trace allows you to control various trace and other options as
described below:
          
          Trace LTB - Trace the link transmission blocks. This trace
                      dumps the variously encoded forms of all 
                      transmissions sent and received. It is helpful
                      in gaining an understanding of how the program
                      works but does a lot of data and must be used
                      with CRT type terminal.

        Trace PPS - Trace the process to process stream functions. In
                     general this trace is not very helpful unless you
                     already know what you are looking for.

        Trace FTP - Trace the file transfer functions and data. 

        Local loopback test - This puts the program in a mode where
                    it talks to itself and can be very useful in 
                    testing the program especially when combined
                    with the LTB trace. You should try this mode
                    before attempting to use this program with 
                    another PTP to see if the program will run on
                    your system.

     
     Because of the low baud rates that our modems use and the encoding done
in the PCNET format the transmission of files will be very slow, however, the
transfered file should contain no transmission errors and any type of file
including binary can be transfered. In addition files can be transfered in
both directions at the same time and the terminal to terminal mode can still
be used. Inorder to give you some assurance that the program is running      
a dot will be printed when an packet is received. Be sure you are in PTP mode
when you wish to transfer files. Best of luck and please contact me with
errors, questions, or suggestions you may have.

Mark Gang
408-267-4913

     

========================================================================================
DOCUMENT :usus Folder:VOL06:ptp.bush.text
========================================================================================

{$S+}
{$G+}
{||| $R-}
{***************************************************************}
{                                                               }
{                        PTP                                    }
{                                                               }
{               PASCAL  TRANSFER  PROGRAM                       }
{                                                               }
{                                                               }
{  (C) COPYRIGHT 1979  J. MARK GANG                             }
{                                                               }
{                                                               }
{  PERMISSION GRANTED FOR NON-COMMERCIAL USE BY INDIVIDUALS.    }
{  ALL OTHER RIGHTS RESERVED.                                   }
{                                                               }
{  HISTORY:                                                     }
(*
        05-Oct-80 turn off iochecking around disk writes
        05-Oct-80 uattended lets estconnection do call to progstart
        05-Oct-80 timeouts halved {9k,6k}, autoans clears modem when through
        04-Oct-80 close files in modemmenu
        03-Oct-80 disk writes verified
        03-Oct-80 wln adjustments, prompt info and ans/org options
        03-Oct-80 init modemmode with mynode in init
        02-Oct-80 tell duplexity
        02-Oct-80 timeouts * 10 {30000 & 20000}
        02-Oct-80 DotCount rather than ..........................
        01-Oct-80 originate_wait_time to 60 secs from 20
        30-Sep-80 preset baudrates and reclengths
        30-Sep-80 only test Ringing once for uarts who tell and forget
        30-Sep-80 Wait for Carrier from 200 to 20 secs
        25-Sep-80 Delay Timer set to 1166 for uEngine for .1sec.
        25-Sep-80 ModemMode to Org if loopback mode
        25-Sep-80 Scan loop terminates on < also for recd ltb
        25-Sep-80 GenCkSum fix Val Rge Err
        24-Sep-80 m41wd41 brought over from old
        24-Sep-80 IO.DCL include
        24-Sep-80 Range check inhibit localization started
        24-Sep-80 titling, logs version etc.
*)
{       VERSION 1.0   JULY 1979                                 }
{       VERSION 1.1   NOV  1979   PMMI MODEM CONTROL            }
{       VERSION 1.2   MAR  1980   LINK MODE CONTROL             }
{                                                               }
{***************************************************************}

{Note 1: In several places in this program it was necessary to set
         the length of a string. The length is held in byte 0 of the 
         string. In order to assign to this byte it is necessary that
         range checking be turned of.

|xjm$ver|nx|f8|ejm$profile|n|n|*|f1|.
|.

}


program ptp ();
const
   
{|||}
   title        = 
'PTP {Pascal Transfer Program} by J M Gang / Volition Systems, Inc.';
   version      = 
'               uEngine Version of 05-Oct-80';
   LOR          = 160;
   STO          = 196;
{|||}
   
   TIMER = {|||28 |||}  1166;           {adjust to .1 second for DELAY}
(*|||   Vol Sys Mod
   ANSTIMEOUT = 3000;                   {receiver timeout }
   ORGTIMEOUT = 2000;                   {a different timeout for org mode}
|||*)
   AnsTimeOut = 9000;                   {receiver timeout }
   OrgTimeOut =  6000;                   {a different timeout for org mode}
(*|||*)
   ATTENCHAR=05;                        {^E - used to get to menu}
   BLKSZ = 512;                         {disk block size}
   PPSBUFSZ = 130;                      {size of pps data buffers}
   MAXLTBSZ= 271;                       {size of the LTB buffer}
   MAXDATASZ = 128;                {max amount of unencoded data in LTB blocks}
   MAXREXMIT = 16;                      {maximum number of retransmit attempts}
   MAXDUPSEQ = 5;                       {max allowed dup seq before correction}
   LTBHDLEN = 2;                        {length of the LTB header}
   ESC = 27;                            {escape}
   LF = 10;                             {line feed}
   CR = 13;                             {carriage return}
   NULLPPS = 255;                       {indicates invalid pps}

   {process numbers}
   CTRL = 0;                            {process number of control process}
   LSTNER=1;                            {process number of file xfer listener}
   FTPREC = 2;                          {process number of file xfer receiver}
   FTPSND = 3;                          {process number of file xfer sender}
   TERM = 4;                            {process number of terminal hanndler}
   GETFILE = 5;                        {process number of remote file requester}
   SINK = 6;                            {dummy process to dump unwamted input}
   MAXPROCESS = 6;                      {maximum process number}
   MAXPPS = 9 {MAXPROCESS+3};           {maximum process to process streams
                                         allows for a few 2 stream processes}

   {control messages codes}
   IWN = 0;                             {I won't}
   PDN = 64;                            {Please don't - hex 40}
   IW  = 128;                           {I will - hex 80}
   PD  = 192;                           {Please do - hex C0}
   SF  = 17;                            {send file - hex 11}
   RF  = 18;                            {receive file - hex 12}
   AF  = 19;                            {accept file - hex 13}
   PROTO = 22;                          {sending valid modes}
   GOPROTO = 23;                        {go to following modes}        
   PDPROTO = 214;                       {PD + PROTO}
   PDGOPROTO = 215;                     {PD + GOPROTO}
   IWPROTO = 150;                      {IW + PROTO (returns common vaild modes)}
   IWGOPROTO = 151;                   {IW + GOPROTO (have gone to common modes)}
   

type
    
    seqno=0..7;
    
    bytesz=0..255;
    
    iam= (ORG, ANS);
    
    exception = (EMPTY, FULL, LAST, OK, ERROR);    {status of PPS buffer}
    
    controlState = (SNDSYSNAME, REQPROTO,  CIDLE);{state of control process}
    
    ftpState = (idle, initiate, request, send, terminate, ack, localabort);
                                        {state of ftp process}
    
    fileLength = ARRAY [0:2] of integer; {holds length of file to be transfered
                                          in bits low byte first}
    
    pSelect = (PT,                      {PTP mode}
               RT);                     {raw terminal mode}
    
    coroutine = (rltb, xltb, done);
    
    blk= packed array [0..511] of char; {disk block buffer}
    
    word = packed record case integer of       {address word as int or two char}
                0: (intval: integer);
                1: (byteval: packed record
                       hibyte, lobyte : char;
                       end);
                end;
    
    byte = packed record case char of
            'a':(hdr:  packed record    {LTB header format}
                  oob: seqno;
                  seq: seqno;
                  esc: 0..1;
                  oa : iam;
                  end);
            'b':(ppsh: packed record    {PPS header format}
                 seq: seqno;
                 fil: seqno;
                 lst: boolean;
                 fst: boolean;
                 end);
            'c':(bte:bytesz);
            'd':(ch: char);
            'e':(op: packed record      {control character format}
                msg: 0..63;
                flavor: 0..3;
                end);
            'f':(md: packed record     {LTB and hardware modes}
                bin: boolean;           {binary mode vs r41}
                full: boolean;          {full duplex vs half}
                res: 0:63;              {reserved for future use}
                end);
            'g':(bd: packed record      {defines baud rates}
                b110: boolean;
                b150: boolean;
                b300: boolean;
                b450: boolean;
                b600: boolean;
                b1200: boolean;
                b2400: boolean;
                b4800: boolean;
                end);
         end;
   
   ltbarray = packed array [0..MAXLTBSZ] of byte;       {LTB buffer}
   datarray = packed array [0..MAXDATASZ] of byte;      {send data buffer}

   pps = packed record                  {PPS header record format}
           ppsnum:bytesz;
           pseq:seqno;
           active:boolean;
           err: boolean;
           fstblk:boolean;
           lstblk:boolean;
           srcproc:bytesz;
           destproc:bytesz;
           fstptr: integer;    
           nxtptr: integer;    
           buf: packed array [0:PPSBUFSZ] of char;
         end;

    ppsarray = packed array [0..MAXPPS] of pps;       {PPS table}

{---------------- GLOBALS ------------------------------------------}

var
    c:char;
    acr: string[1];                     {a carriage return}
    
    {-- TEST --}
    ppsmon:boolean;                     {indicates PPS tracing is on}
    ftpmon:boolean;                     {indicates ftp tracing is on}
    loopbk:boolean;                     {internal loop back for debugging}
    trace:boolean;                      {LTB tracing}
    serbuf:array[0..256] of char;       {loopback buffer}
    serptr:integer;                     {loopback buffer pointer}
    
    {-- SCHEDULING/SEQUENCE/FLOW --}
    mynode:iam;                 {indicates sex of this site during a connection}
    i:integer;                          {answer delay counter}
    timeout: integer;                   {holds timeout constant}
    ansbrkt,orgbrkt:char;            {hold answer and orignate break characters}
    xmtgen:seqno;                       {seq no for next LTB generated}
    rcvoob:seqno;                       {old block not yet received }
    xmtoob:seqno;                       {oldest LTB not yet acked by other end}
    sch:coroutine;                      {next LTB process to be run}
    
    {---- LTB GENERAL ---}
    vMode: byte;                        {vaild modes for this node}
    vBaud: byte;                        {vaild bauds for this node}
    cMode: byte;                        {current mode for this node}
    cBaud: byte;                        {current baud for this node}
    
    {---- LTB XMIT ---}
    xmitBinary: boolean;                {LTB xmit is using pure binary mode }
    xmitFull: boolean;                  {full duplex (not implemented)}
    xmitBaud: integer;                  {baud rate for transmitting}
    r41:string;                         {holds r41 character set}
    rmtRecDataSz: integer;              {max data remote will accept}
    maxXmitDataSz: integer;             {max data to send in one LTB}
    xmitDataSz: integer;                {max amoutn data to send in one LTB}
    rexmtcnt:integer;                   {number of consetive rexmits attempted}
    xbuf: ltbarray;                     {LTB xmit buffers}
    xdataptr,xlen: integer;             {LTB xmit buffer pointers}
    
    {-- LTB REC --}
    recDataSz: integer;                 {max data to receive in one LTB}
    recEscSet: boolean;                 {binary mode last char was escape}
    recBinary: boolean;                 {LTB rec is using pure binary mode }
    recFull: boolean;
    recBaud:integer;                    {baud rate for receiving}
    turncnt: integer;
    atcnt:integer;
    
    {-- PPS --}
    rppstbl: ppsarray;                  {receive PPS table}
    xppstbl: ppsarray;                  {xmit PPS table}
    lstOpenPPS: integer;                { last xmit PPS which was opened }
    pollpps:bytesz;                     {next process to be polled by PPS xmitter}
    ctrLock: boolean;                   {send only control messages}
    
    {-- CTRL --}
    ctrlInPPS: integer;                 {incomming PPS stream number}
    ctrlInSlot: integer;                {incomming PPS slot number}
    ctrlState: controlState;            {state of control process}
    ctrlOtPPS:integer;                  {hold control process PPS number (always 0)}
    ctrlReply: array [0:2] of byte;     {holds msg to be sent to remote}
    ctrlMsgLen: integer;                {length of  ctrl msg to send to remote}
    ctrlRequestCnt: integer;            {number of request to send}
    
    {--- TERMINAL---}
    termppsno:bytesz;                   {holds terminal handler PPS number}
    termInPPS: integer;                 {incomming PPS stream number}
    termInSlot: integer;                {incomming PPS slot number}
    termot: integer;                    {out going PPS stream number}
    fstKbCh: char;                      {first char of terminal string}
    kbInterrupt: boolean;               {keyboard interrupt set}
    
    {-- FTP XMITTER --}
    xfile:file;                         {fileid of file to be xmitted}
    xfilptr:integer;                    {xmit file pointer}
    xblk:blk;                           {number of blocks xmitted}
    xbufptr:integer;                    {pointer into xmit data buffer}
    xname:string;                     {name of file to be xmitted}
    destname:string;                  {destination name of file being xmitted}
    xeof:boolean;                       {xmit file EOF flag}
    fSndOtPPS: integer;                 {out going PPS stream number}
    fSndInPPS: integer;                 {incomming PPS stream number}
    fSndInSlot:integer;                 {incomming PPS slot number}
    xfiletype:bytesz;    {indicates type of file being xfered (not version 1.0)}
    xfilesize:word;      {indicates size of file to be xfered (not version 1.0)}
    fsndstate: ftpState;                {FTP sender state}
    fsndcode:bytesz;                    {holds control to be sent}
    
    {---- LISTENER ------}
    lsnrInSlot: integer;                {listner incomming slot numner}
    lsnrInPPS: integer;                 {listner incomming stream numner}
    lsnrOtPPS: integer;                 {listner out going stream number}
    
    {---- FTP RECEIVER ----}
    rfile:file;                         {ftp receive file fileid}
    rfilptr:integer;                    {receive file block pointer}
    rblk:blk;                           {receive buffer}
    rbufptr:integer;                    {receive buffer pointer}
    rname:string;                     {receive file name}
    rck0, rck1:integer;                 {checksums}
    srcname:string;                   {name of file at sending end}
    receiving:boolean;                  {indicates ftp receiver is active}
    lastc: byte;                        { holds last character received }
    firstChar: boolean;                 {first char of incomming stream}
    fRecInSlot: integer;                {incomming slot number}
    fRecInPPS: integer;                 {incomming PPS stream number}
    fRecOtPPS: integer;                 {out going PPS stream number}
    
    {--- GET FILE ---}
    getstr:string;                  {name of remote file to be gotten}
    
    {---- RAW TERMINAL ----}
    halfduplex: boolean;                {raw terminal half duplex else full}
    
    {--- MENU --- }
    menuexit:boolean;                   {flag to indicate to exit the menu}
    
    {---- MODEM CONTROL-----}
    currentBaud: integer;               {current rate before computation}
    baudrate: integer;                  {baud rate }
    telnum: string;                     {telphone number }
    modemMode: iam;                     {ans/org mode of modem }
    progSelect: pSelect;                {current program selected}
    unattended: boolean;                {indicates unatteneded mode in use}

{|||}
    DotCount    : INTEGER;
    
    
{$I UTIL_5:IO.DCL.TEXT }
{|||}



{------------------------- FORWARD  DECLARATIONS -------------------------}

procedure ltbinit; forward;
procedure sched; forward;
procedure xpps; forward;
procedure rpps (var rbuf:ltbarray; var rstrt:integer; var rcnt:integer); 
forward;
function frecstart(inSlot: integer):boolean; 
forward;
function rmtsndstart(inSlot: integer):boolean; 
forward;
procedure pollProcesses; forward;
procedure pCtrl; forward;
procedure pSinker; forward;
procedure pListner; forward;
procedure pFtpSnd; forward;
procedure pFtpRec; forward;
procedure pTerm; forward;
procedure pGetFtp; forward;
procedure menu; forward;
procedure init; forward;
procedure initState; forward;
procedure setBaud (rate: integer); forward;
procedure changeBaud (rate: integer); forward;

(*||| REPLACED UNITS WITH ONE BIG INCLUDE       |||
{--- external functions ----}
function mread:char; external;          { returns char from modem rec }
function kbstat: boolean; external;     { returns true if keyboard char rdy}
function mrecstat: boolean; external;   { returns true if modem rec char rdy}
function ringing: boolean; external;    { returns true if phone is ringing }
function cts: boolean; external;        { returns true if modem clear to send set}
function dtonedet: boolean; external;   { returns true if dial tone present }

{--- external procedures ----}
procedure mwrite(c:char); external;     { write char to modem xmitter }
procedure modemInit; external;          { performs modem initialization }
procedure hangup; external;             { hangup phone - go on hook }
procedure ri; external;                 { go off hook in answer mode } 
procedure baud; external;               { set modem baud rate }
procedure dtron; external;              { set data terminal ready }
procedure dialer (c: char); external;   { dial a digit }
procedure sh; external;                 { go off hook in orginate mode }
|||*)
{$I UTIL_5:IO.PKG.TEXT }
{|||}

{----------------- GENERAL ----------------------------------------------}

procedure delay (ticks: integer);
{purpose: delay .1 seconds for each tick }
var
    i: integer;
begin
    while ticks > 0 do
        begin
        i := timer;
        while i > 0 do
            i := i-1;
        ticks := ticks -1;
        end;
end;



procedure byteprint (c: char);

{purpose: Print characters use decimal when not a printing character}
var
    w: word;
begin
    if (ord(c) < 32) or (ord(c) > 126) then
        begin
        w.byteval.lobyte := c;
        w.byteval.hibyte := chr(0);
        write ('<',w.intval,'>')
        end
    else
        write (c);
end;



{-------------------- LTB RECEIVER SECTION --------------------------------}

procedure getserial(var x:byte); 

{purpose : Get a character for the LTB receiver from either the loopback
           buffer or the serial line  - if no character arrives 
           on the serial line by TIMEOUT return a turnaround character
}

var
   i:integer;
begin
    if loopbk then
        begin
        x.ch := serbuf[serptr];
        if trace then byteprint (x.ch);
        serptr := serptr +1;
        end
    else
        begin
        i:=0;
        while (i<>timeout) and (not mrecstat) do
            i := i+1;
        if i=timeout then
            begin
            if trace then
                writeln ('RECEIVER TIMEOUT');
            if mynode = ORG then
                x.ch:=ansbrkt
            else
                x.ch:=orgbrkt;
            end
        else
            begin
            x.ch := mread ;
            {if r41 mode clear high order bit}
            if not recBinary and (x.bte > 127) then
                x.bte := x.bte - 128;
            if trace then byteprint (x.ch);
            end;
       end;
end;

procedure m41wd1 (var buf:ltbarray; var len:integer);
{purpose: Convert 3 bytes of mod 41 to 2 bytes of binary
          repeat thur entire buffer, output is placed back in 
          source buffer, length is set to the length of the converted form.
}
{|||
        rb and rhk thought of this hairy one w/o overflow
|||}

var
   i,j:integer;
   tmp:word;
   K            : INTEGER;
   K_0          : INTEGER;
   K_1          : INTEGER;
begin 
   j:=0;
   i:=0;
   while j < len do
      begin
      K   := Buf[J+1].Bte + Buf[J+2].Bte * 41 ;     
      K_0 := K * 1 + Buf[J].Bte ;    
      K_1 := K * 10 ;
      IF ( (((MAXINT - K_1) - K_1) - K_1) - K_1 ) > K_0    
         THEN Tmp.IntVal := K_0 + 4 * K_1 
         ELSE BEGIN
            K := ((K_0 + 2 * (K_1 - 16384)) + K_1) + K_1 ;         
            PMACHINE (^Tmp.IntVal, (K), (-MAXINT-1), LOR, STO)
            END; 
      buf[i].ch := tmp.byteval.lobyte; 
      buf[i+1].ch := tmp.byteval.hibyte;
      j:= j+3;
      i:= i+2;
      end;
   len := i;
end;



procedure r41m41(var c:byte);

{purpose: Converts a character from radix 41 character set to mod 41}

var
   cv:integer;
begin
   if c.ch = '(' then cv := 0
   else
   if (c.bte > 47) and (c.bte < 58) then   {'0' to '9'}
       cv := c.bte - 47
   else
   if (c.bte > 64) and (c.bte < 91) then   {'A' to 'Z'}
       cv := c.bte - 54
   else
   if c.ch = '*' then cv := 37
   else
   if c.ch = '+' then cv := 38
   else
   if c.ch = '-' then cv := 39
   else
   if c.ch = ')' then cv := 40
   else
   cv := 41;    {invalid character}
   
   c.bte := cv; 
end;
    

function spCharChk (x: byte; rcnt: integer): boolean;
begin
   spCharChk := TRUE;
   if recEscSet then
       begin
       spCharChk := FALSE;
       recEscSet := FALSE;
       end
   else
       begin
       if x.ch = '@' then
           begin
           if turncnt < 3 then turncnt := turncnt+1;
           if (rcnt = 0) and (atcnt > 0) then atcnt := atcnt -1;
           if rcnt <> 0 then atcnt := 1; {stop after first data block}
           end
       else
           if ((x.ch=ansbrkt) and (mynode=ORG)) 
                                           or ((x.ch=orgbrkt) and (mynode=ANS)) 
           then turncnt:=turncnt-1
           else
               if recBinary and (x.bte = ESC) then
                   recEscSet := TRUE
               else
                   spCharChk := FALSE;
      end;
end;

    
procedure hdxscanner (var rbuf:ltbarray; var rcnt:integer);

{purpose: Pack incomming stream into LTB packets. Expects one 
          packet per transmission.
}
var
    x:byte;
    specChar: boolean;
begin
    if trace then begin writeln; write ('LTB REC ='); writeln; end;
    atcnt := 3;
    turncnt:=3;
    rcnt := 0;
    repeat
       getserial(x);                {get character from serial line}
       specChar := spCharChk (x, rcnt);
       if not specChar then
           if (rcnt < MAXLTBSZ) and (atcnt = 0) then
               begin
               if not recBinary then
                   begin
                   r41m41(x);
                   if x.bte<>41 then {valid char}
                       begin
                       rbuf[rcnt] := x;
                       rcnt := rcnt+1;
                       end
                   end
               else {is binary}
                   begin
                   rbuf[rcnt] := x;
                   rcnt := rcnt+1;
                   if odd(rcnt) then  {compute binary checksum}
                       rck0 := rck0 + x.bte
                   else
                       rck1 := rck1 + x.bte;
                   end
              end
           else {block has not begun }
              if atcnt < 3 then atcnt := atcnt+1;
    until turncnt=0;
end;
    
    
function ckcksum (rbuf:ltbarray; rcnt:integer) : boolean;

{purpose: Check checksum of an incomming LTB packet}

var
   i:integer;
begin
   i:=0;
   while i < rcnt do
       begin
       rck0 := rck0 + rbuf[i].bte;
       i:=i+1;
       rck1 := rck1 + rbuf[i].bte;
       i := i+1;
       end;
   rck0 := rck0 mod 256;
   rck1 := rck1 mod 256;
   if (rck0 <> 0) or (rck1 <> 0) then
      begin
      writeln ('ck0=',rck0,' ck1=',rck1);
      ckcksum := false
      end
   else
      ckcksum := true;
end;
   
   
   
procedure ltbframer;

{purpose: Checks validity of incomming LTB packet. Updates sequence
          numbers as needed. Check to see if a character has been 
          typed on the keyboard before returning to the LTB xmitter.
}

label
    1;
var
    rbuf:ltbarray;
    rstrt, rcnt,i:integer;
    c:char;
begin
       if recBaud <> currentBaud then
           changeBaud (recBaud);
       rck0 := 0;
       rck1 := 0;       {clear checksums}
       hdxscanner (rbuf, rcnt);
       if rcnt >= MAXLTBSZ then
           begin
           writeln; writeln ('REC ERROR - LTB TOO LONG');
           goto 1;
           end;
       if not recBinary then
           begin
           if (rcnt mod 3) <> 0 then
               begin
               writeln; 
               writeln ('REC ERROR -  NOT MULTIPLE OF THREE RADIX-41 CHARACTERS');
               goto 1;
               end;
           m41wd1 (rbuf, rcnt);     {convert 3 byte m41 to 2 binary}
           end;
       if rcnt < 4 then
           begin
           writeln; writeln ('REC ERROR - TIMEOUT OR LTB TOO SHORT.');
           goto 1;
           end;
       if not recBinary then
           if ckcksum (rbuf, rcnt) = FALSE then
              begin
              writeln ('REC ERROR - RECEIVE CHECKSUM');
              goto 1;
              end
      else
           begin
           rck0 := rck0 mod 256;
           rck1 := rck1 mod 256;
           if (rck0 <> 0) or (rck1 <> 0) then
              begin
              writeln ('ck0=',rck0,' ck1=',rck1);
              writeln ('REC ERROR - RECEIVE CHECKSUM');
              goto 1;
              end;
           end;
      
      if odd(rbuf[1].bte) and (rbuf[rcnt-1].bte = 0)
           then rcnt:=rcnt-1;
      rcnt:=rcnt-2;         {delete checksum bytes}
      if trace then 
         begin
         writeln;
         writeln ('RECEIVED ',rcnt,' BYTES');
         end;
      if rcnt <> rbuf[1].bte then        {lengths not equal}
           begin
           writeln; writeln ('REC ERROR - LTB LENGTH CHECK ERROR');
           goto 1;
           end;
     with rbuf[0], hdr do
         begin
         if (oa = mynode) and not loopbk or (oa <> mynode) and loopbk then
             begin
             writeln; writeln ('REC ERROR - LTB O/A MODE INCORRECT.');
             goto 1;
             end;
         if esc = 1 then  {should always be zero}
             begin
             writeln; writeln ('REC ERROR - PROTOCOL ESCAPE NON ZERO.');
             goto 1;
             end;
         if loopbk then
            xmtoob := (seq+1) mod 8
         else
            xmtoob:= oob;
         if seq = rcvoob-1 then
             begin
             writeln; writeln ('REC ERROR - DUPLICATE SEQUENCE RECEIVED.');
             goto 1;
             end;
         if seq <> rcvoob then
             begin
             writeln; writeln ('UNEXPECTED SEQUENCE NUMBER RECEIVED.');
             writeln; writeln ('REINITIALIZING PTP');
             ltbinit;
             goto 1;
             end
         else
             rcvoob:=(rcvoob+1) mod 8;
         rstrt := LTBHDLEN;
         end;
         {if length less than or equal to LTBHDLEN then no data in this LTB}
{|||    Vol Sys Mod     |||}
        DotCount := (DotCount+1) MOD (10000);
        IF (DotCount MOD 50) = 0
            THEN BEGIN
                WRITELN;
                WRITE ('[', DotCount:4, ']')
                END;
{|||}
         write ('.');
         if rcnt > LTBHDLEN then 
             rpps (rbuf, rstrt, rcnt);
1:
if sch<>done then sch := xltb;
end;

{--------------- LTB XMITTER SECTION ----------------------------}



procedure mkhdr(var buf:ltbarray; length:integer);

{purpose: Create LTB header for packet to sent}

begin
    with buf[0] do
    begin
        hdr.oob := rcvoob;
        hdr.seq := (xmtgen+7) mod 8;
        hdr.esc := 0;
        hdr.oa  := mynode;
    end;
    buf[1].bte := length;
end;
    
    

    
procedure gencksum( var buf:ltbarray; var len:integer );

{purpose: Generate checksum for LTB packet to be sent}

var ck0,ck1,i:integer;
begin
    ck0 := 0; ck1 := 0;
    i := 0;
    len := buf[1].bte;
    buf[len].bte := 0;
    while i < len do
        begin
        ck0 := ck0+ buf[i].bte;
        i := i+1;
        ck1 := ck1 + buf[i].bte;
        i := i+1;
        end;
{|||
    buf[len+(len mod 2)].bte := (-ck0) mod 256;
    buf[len+((len + 1) mod 2)].bte := (-ck1) mod 256;
|||}
    buf[len+(len mod 2)].ch := chr( 256 - (ck0 mod 256) );
    buf[len+((len + 1) mod 2)].ch := chr( 256 - (ck1 mod 256) );
{|||}
    len := len + 2;
    if odd(len) then
        begin
            buf[len].bte := 0;
            len := len + 1;
        end;
end;

        

procedure putserial( c:char );

{purpose: Put a character out to either the loopback buffer or the
          the serial line
}
begin
    if loopbk then
        begin
        serbuf[serptr] := c;
        serptr := serptr+1;
        end
    else
        begin
        mwrite(c);
        end;
    if trace then byteprint(c);
end;



procedure binm41(c1, c2: char);

{purpose: Convert incomming buffer from binary to mod 41 and place in output buffer}

var 
    k, dtmp:integer;
    wd, tmp:word;
    c: char;
begin
    wd.byteval.lobyte := c1;
    wd.byteval.hibyte := c2;
    for k:=0 to 2 do
        begin
        if wd.intval < 0 then   {correct for overflow problem}
            begin
            tmp.byteval.lobyte := wd.byteval.hibyte;
            tmp.byteval.hibyte := chr (0);
            dtmp := (tmp.intval div 41)*256;
            tmp.intval := tmp.intval mod 41;
            wd.byteval.hibyte := tmp.byteval.lobyte;
            end
        else
            dtmp := 0;
            
        c := r41[(wd.intval mod 41) + 1 ];
        putserial (c);
        wd.intval  := (wd.intval div 41) + dtmp;
        end;
end;


procedure binExpand (c: char);

{purpose: Place escape character in front of special characters when they
          are not special and send cahracter}
begin
    if c in [chr(ESC), '@', ']', '[' ] then
        putserial (chr(ESC));
    putserial (c);
end;


procedure endxmit;

{purpose: Send turnaround characters.}

var
   i:integer;
begin
    putserial( '@' );
    for i:=1 to 5 do
        begin
        if mynode = ANS then
            putserial ('[')
        else
            putserial (']');
        end;
    putserial (chr(CR));
end;
      
      
      
procedure xmitblk( buf:ltbarray; len:integer);

{purpose: Send the LTB buffer.}

var i:integer;
begin
    for i:=1 to 6 do
        putserial( '@' );
    if xmitBinary then
        begin
        for i:=0 to len-1 do
            binExpand (xbuf[i].ch);             {expand escape char}
        end
    else
        begin
        i:=0;
        while i < len-1 do
            begin
            binm41(xbuf[i].ch, xbuf[i+1].ch);       
            i:=i+2;
            end;
        end;
    endxmit;
end;



procedure ltbsend;

{purpose: Create an LTB packet containing the data, send it}

var
   i:integer;
begin
    if trace then 
       begin
       writeln;
       writeln ('XMIT ',xdataptr,' BYTES');
       end;
    xlen := xdataptr;
    mkhdr (xbuf, xlen);              {update header info}
    gencksum (xbuf, xlen);           {generate checksum, return total length} 
    if trace then
        begin
        writeln;
        for i:=0 to xlen-1 do
           byteprint (xbuf[i].ch);
        writeln;
        end;
    xmitblk(xbuf,xlen);                    {transmit}
end;
    
    
    
procedure xmitltb;

{purpose: Determine if the previous packet must be retransmitted or
          if a new packet can be sent. In the case of excessive 
          retransmission attempts aborts the program.
}
begin
   if xmitBaud <> currentBaud then
       changeBaud (xmitBaud);
   if rexmtcnt >= MAXREXMIT then
       begin
       writeln;
       writeln ('EXCESSIVE RETRANSMISSION ATTEMPTS -- CONNECTION ABORTED');
       sch := done;
       end
   else
       begin
           if xmtoob = xmtgen then  
               begin
               xdataptr := 2;
               xpps;
               rexmtcnt := 0;
               xmtgen := (xmtgen+1) mod 8;     {increment seq number}
               end
           else
               begin
               rexmtcnt := rexmtcnt+1;
               end;
           ltbsend;
       end;
if sch<>done then sch := rltb;
end;


{----------- LTB GENERAL ------------------------------------}


procedure sched;

{purpose: Low level dispatcher for the LTB receiver and transmitter.}
var
    ch: array [0..0] of char;
begin
{|||}   DotCount := 0;  {|||}
    repeat

        if (not cts) and (not loopbk)  then 
            begin
            writeln ('CARRIER LOST');
            initState;
            sch := done
        end;
        
        if kbstat then
            begin
            unitread (2,ch[0],1,0,0);
            if ch[0] = chr(ATTENCHAR) then
                menu
            else
                begin
                fstKbCh := ch[0];
                kbInterrupt := TRUE;
                end;
            end;
        
        serptr := 0;
        case sch of     {the heart of the system}
            xltb:xmitltb;
            rltb:ltbframer;
            end;
        
   until sch=done;
end;
             
        
             
procedure ltbinit;

{purpose: Initialize LTB values at startup.}
begin
    { Define radix 41 character set. }
    r41 := '(0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ*+-)';
    xmtgen := 0;
    rcvoob := 0;
    xmtoob := 0;
    rexmtcnt := 0;
    serptr:=0;
    if loopbk then
        sch := xltb
    else
        sch := rltb;
end;


procedure modeInit;
begin
    xmitBinary := FALSE;
    recBinary := FALSE;
    recEscSet := FALSE;
    xmitDataSz := 64;
    recBaud := 300;
    xmitBaud := 300;
end;

{-------------------- PPS TRANSMIT  --------------------------}



procedure ppsinit;

{purpose:Initialize PPS tables at startup.}

var 
  i:integer;
begin
    for i:= 0 to MAXPPS do
        begin
        with xppstbl[i] do
            begin
            active := FALSE;
            ppsnum := i;
            err := FALSE;
            end;
        with rppstbl[i] do
            begin
            active := FALSE;
            ppsnum := i;
            err := FALSE;
            end;
        end;
    lstOpenPPS := 0;
    pollpps:=0;
end;



procedure ppsopen (src, dest:integer; var ppsno:bytesz);

{purpose: Open a new xmit PPS, enter the source and the destination process
          numbers in the xmit PPS table. The number of the PPS that is opened
          is returned to the caller.
}
begin
   ppsno := lstOpenPPS;
   repeat
        ppsno := (ppsno+1) mod MAXPPS;
   until not xppstbl[ppsno].active or (ppsno = lstOpenPPS);
   
   if xppstbl[ppsno].active then
      begin
      writeln; writeln('PPS xmit table full');
      end
   else
      begin
      lstOpenPPS := ppsno;
      with xppstbl[ppsno] do
          begin
          active := TRUE;
          err := FALSE;
          srcproc := src;
          destproc := dest;
          pseq := 0;
          fstblk := TRUE;
          lstblk := FALSE;
          fstptr := 0;
          nxtptr := 0;
          if ppsmon then
             begin
             writeln; writeln ('Opening xmit PPS ',ppsno,' source ',src,
                                ' destination ',dest);
             end;
          end;
     end;
end;



procedure ppsclose (ppsno:bytesz);

{purpose: Close the specified xmit PPS number. 
          Note: One more transmission (last block) will occur on this stream.
}
begin
    if xppstbl[ppsno].active = FALSE then
        begin
        if ppsmon then
            begin
            writeln; writeln ('Request to close inactive xmit PPS ',ppsno);
            end
        end
    else
        begin
        xppstbl[ppsno].lstblk := TRUE;
        if ppsmon then
            begin
            writeln; writeln ('Closing xmit PPS ',ppsno);
            end;
        end;
end;


procedure mkpps (ppsno:integer);
{purpose: Build the PPS }
var
   orglen:integer;
begin
   orglen := xdataptr;
   
    with xppstbl[ppsno] do
        begin
        if ppsmon then
            begin
            writeln; 
            write ('Sending PPS ',ppsno,' seq no ',pseq);
            if fstblk then write(' - first block');
            end;
       
        { pps header }
        with  xbuf[xdataptr] do
            begin
            ppsh.fst := fstblk;    
            ppsh.lst := FALSE;
            ppsh.fil := 0; {zero filler}
            ppsh.seq := pseq;
            end;
        
        pseq := (pseq +1) mod 8;
       
        xbuf[xdataptr+1].bte := ppsno;
       
        if fstblk then
            begin
            xbuf[xdataptr+3].bte := srcproc;
            xbuf[xdataptr+4].bte := destproc;
            xdataptr := xdataptr+5;
            fstblk := FALSE;
            end
        else
            begin
            xdataptr := xdataptr+3;
            end;
        
        {move data to pps}
        while (fstptr <> nxtptr) and (xdataptr-orglen < xmitDataSz) do
            begin
            xbuf[xdataptr].ch := buf[fstptr];
            xdataptr := xdataptr+1;
            fstptr := fstptr+1;
            if fstptr = PPSBUFSZ then
                fstptr := 0;
            end;
        
        xbuf[orglen+2].bte := xdataptr-orglen;
        if ppsmon then write (' - length ',(xdataptr-orglen));
        
        {if last block and no more data to send}
        if lstblk  and (fstptr = nxtptr) then
            begin
            active := FALSE;    
            lstblk := FALSE;
            xbuf[orglen].ppsh.lst := TRUE;
            if ppsmon then write (' - last block');
            end;
        end {with};
    if ppsmon then writeln;
end;
             


procedure xpps;

{purpose: Search for an acitive pps with something to send}

var
   dlen:integer;
   ppsno:bytesz;
   done: boolean;
begin
    
    { to simulate multiple processes we poll the process procedures here}
    pollProcesses;
    
    done := FALSE;
    ppsno:= pollpps;    {Continue from last poll + 1}
    repeat  {poll sending processes for out going}
       with xppstbl[ppsno] do
           begin
           if active then
               if (fstptr<>nxtptr) or fstblk or lstblk then
                   if not ctrLock then
                       begin
                       mkpps (ppsno);
                       done := TRUE;
                       end
                   else 
                       if srcproc = CTRL then
                           begin
                           mkpps (ppsno);
                           ctrLock := FALSE;
                           if ppsmon then writeln ('PPS control lock reset');
                           done := TRUE;
                           end;
           end;
       ppsno := (ppsno +1)mod MAXPPS;
    until (ppsno = pollpps) or done;
    pollpps := ppsno;
end;



function statusOtPPS (ppsNum: integer): exception;
var
    tmp: integer;
begin
    statusOtPPS := ERROR;
    if ppsNum <= MAXPPS then
        begin
        with xppstbl[ppsNum] do
            begin
            if active and not err then
                begin
                if lstblk then
                    statusOtPPS := LAST
                else
                    begin
                    tmp := nxtptr+1;
                    if tmp =  PPSBUFSZ then
                        tmp := 0;
                    if tmp <> fstptr then
                        statusOtPPS := OK
                    else
                        statusOtPPS := FULL;
                    end;
                end;
            end;
        end;
end;

    

function ppsWrite (ppsNum: integer; c: char): exception;
var
    tmp: integer;
begin
    {there are several checks that should be made here
     they are not done in this version for efficiency reasons}
    ppsWrite := ERROR;
    with xppstbl[ppsNum] do
        begin
        tmp := nxtptr+1;
        if tmp = PPSBUFSZ then
            tmp := 0;
        if tmp <> fstptr then
            begin
            buf[nxtptr] := c;
            if ppsmon then
                byteprint (c);
            nxtptr := tmp;
            tmp := nxtptr+1;
            if tmp = PPSBUFSZ then
                tmp := 0;
            if tmp = fstptr then
                begin
                ppsWrite := FULL;
                if ppsmon then writeln ('FULL');
                end
            else
                ppsWrite := OK;
            end
        end
end;



{--------- PPS RECEIVER ---------------}

procedure findRecPPS (dest, fstEntry: integer; 
                      VAR slot: integer; VAR ppsNo: integer);
{purpose: find any incomming streams to the specified destanation starting at the 
          specified slot. Returns slot and PPS number if found, NULLPPS 
          otherwise}
var
    i: integer;
    done: boolean;
begin
    done := FALSE;
    ppsNo := NULLPPS; 
    if fstEntry <= MAXPPS then
        begin
        i := fstEntry;
        repeat
            if (rppstbl[i].destproc = dest) and (rppstbl[i].active)  then
                begin
                slot := i;
                ppsNo := rppstbl[i].ppsnum;
                done := TRUE;
                end;
            i := i+1;
        until (i > MAXPPS) or done;
        end;
    if ftpmon and (ppsNo <> NULLPPS) then
        writeln (' Found destination ', dest,  ' ppsNo ', ppsNo, ' in slot ', slot);
end;


procedure rpps; 

{purpose: Check incomming PPS packets and place in buffer}

label
   1;
var
   ppsno:bytesz;
   index: integer;
begin
    ppsno := rbuf[rstrt+1].bte;
    if ppsmon then
        writeln ('Receiving PPS ',ppsno,' length ',rbuf[rstrt+2].bte);
    rcnt := rbuf[rstrt+2].bte - 3;
    
    index := 0;
    while (index<MAXPPS) and ((rppstbl[index].ppsnum<>ppsno) or 
           not rppstbl[index].active ) do index := index + 1;
    
    with rbuf[rstrt].ppsh do
        begin
        if index = MAXPPS then
            begin
            if not fst then
                begin
                writeln ('PPS ERROR - received packet on inactive PPS number ',ppsno);
                end
            else {activate this pps}
                begin
                index := 0;
                while (index<MAXPPS) and rppstbl[index].active do
                    index := index + 1;
                if index = MAXPPS then
                    begin
                    writeln; writeln ('PPS receive table full');
                    goto 1;
                    end
                else
                    begin
                    with rppstbl[index] do
                        begin
                        ppsnum := ppsno;
                        active := TRUE;
                        srcproc := rbuf[rstrt+3].bte;
                        destproc := rbuf[rstrt+4].bte;
                        nxtptr := 0;
                        fstptr := 0;
                        err := FALSE;
                        pseq := 0;
                        if ppsmon then
                            begin
                            writeln ('Receiving new PPS ',ppsnum,' source ',
                                      srcproc,' destination ',destproc,
                                      ' using slot ', index);
                            end;
                        rstrt := rstrt + 2;
                        rcnt := rcnt-2;
                        end
                    end;
                end;
            end
        else { found active pps in table}
            begin
            if fst then
                begin
                writeln ('PPS ERROR - received unexpected first block on ',ppsno);
                rppstbl[index].err := TRUE;
                goto 1;
                end;
            end;
            
   {if we get this far this is an active pps}
        with rppstbl[index] do
            begin
            {update status }
            fstblk := fst;
            lstblk := lst;
            if lstblk and ftpmon then
                begin
                writeln; writeln ('Last block on PPS ', ppsno);
                end;
            if seq <> pseq then
                begin
                writeln;
    writeln ('PPS ERROR - received unexpected sequence number ',seq,' on ',ppsno);
                err := TRUE;
                end
            else
                pseq := (pseq+1) mod 8;
          
            {move data to pps buffer}
            rstrt := rstrt + 3; {skip pps header}
            if ppsmon then
                writeln ('PPS rec buffer =');
            while (rcnt > 0) and not err do
                begin
                buf[nxtptr] := rbuf[rstrt].ch;
                if ppsmon then
                    byteprint (rbuf[rstrt].ch);
                rcnt := rcnt -1;
                rstrt := rstrt+1;
                nxtptr := nxtptr+1;
                if nxtptr = PPSBUFSZ then
                    nxtptr := 0;
                if nxtptr = fstptr then
                    begin
                    writeln ('Receive buffer overflow on PPS ',ppsno);
                    err := TRUE;
                    end;
                end;
            end {with};
        end {with};
1:
end;


procedure rppsredirect (ppsno, newdest:bytesz);

{purpose: Redirect all further packets received on the specified PPS stream to
          the specified destination process.
}
begin
    with rppstbl[ppsno] do
           begin
           destproc:=newdest;
           if ppsmon then
               begin
               writeln;
 writeln ('PPS REC - Redirecting PPS ',ppsnum,' to destination ',destproc);
               end;
           end;
end;


function ppsRead (ppsSlot: integer; VAR c: char): exception;
begin
    {there are several checks that should be made here
     they are not done in this version for efficiency reasons}
    ppsRead := ERROR;
    with rppstbl[ppsSlot] do
        begin
        if not err then
            begin
            if (fstptr <> nxtptr) then
                begin
                c := buf[fstptr];
                fstptr := fstptr+1;
                if fstptr = PPSBUFSZ then
                    fstptr := 0;
                ppsRead:= OK;  
                end
            else
                if not lstblk then
                    begin
                    ppsRead := EMPTY;
                    if ppsmon then writeln ('EMPTY');
                    end
                else
                    begin
                    ppsRead := LAST;
                    if ppsmon then writeln ('LAST');
                    active := FALSE;
                    end
            end
        end
end;



{-------------- PROCESS GENERAL --------------}

procedure pollProcesses;
{purpose: Polls the pseudo processes}
begin
    pCtrl;
    pSinker;
    pListner;
    pFtpSnd;
    pFtpRec;
    pTerm;
    pGetFtp;
end;


{------------------ SINK ----------------------}

procedure pSinker;
{a dummy receiver process to dump unwanted input }
var
    i, ppsno, slot: integer;
    c: char;
begin
    i := 0;
    repeat
        findRecPPS (SINK, i, slot, ppsno);
        if ppsno <> NULLPPS then
            begin
            while ppsRead (slot, c) = OK do;
            i := slot+1;
            end;
    until ppsno = NULLPPS;
end;



{--------------- CONTROL PROCESS ----------------------}

procedure ctrlinit;
begin
   ppsopen (CTRL, CTRL, ctrlOtPPS);
   ctrlState := SNDSYSNAME;
   ctrlInPPS := NULLPPS;
   ctrLock := TRUE;
end;

procedure maxCommonBaud (x, y: byte; VAR max: byte; VAR ibaud: integer);
{purpose: Find highest common baud rate}
begin
    max.bte := 0;
    if x.bd.b4800 and y.bd.b4800 then
        begin
        max.bd.b4800 := TRUE;
        ibaud := 4800;
        end
    else
    if x.bd.b2400 and y.bd.b2400 then
        begin
        max.bd.b2400 := TRUE;
        ibaud := 2400;
        end
    else
    if x.bd.b1200 and y.bd.b1200 then
        begin
        max.bd.b1200 := TRUE;
        ibaud := 1200;
        end
    else
    if x.bd.b600 and y.bd.b600 then
        begin
        max.bd.b600 := TRUE;
        ibaud := 600;
        end
    else
    if x.bd.b450 and y.bd.b450 then
        begin
        max.bd.b450 := TRUE;
        ibaud := 450;
        end
    else
    if x.bd.b300 and y.bd.b300 then
        begin
        max.bd.b300 := TRUE;
        ibaud := 300;
        end
    else
    if x.bd.b150 and y.bd.b150 then
        begin
        max.bd.b150 := TRUE;
        ibaud := 150;
        end
    else
    if x.bd.b110 and y.bd.b110 then
        begin
        max.bd.b110 := TRUE;
        ibaud := 110;
        end
    else
        begin
        writeln ('No compatable baud rates in request.');
        ibaud := 0;
        end;
end;


procedure decodeCtrlMsg;
{purpose: Decode incomming control messages}
var
  c: char;
  x: byte;
  newBaud: integer;
  result: exception;
begin
   result := ppsRead (ctrlInSlot, c);
   x.ch := c;
   if result = OK  then
       begin
       if x.bte = PDPROTO then
           begin
           writeln; write ('Setting ');
           
           {check modes }
           result := ppsRead (ctrlInSlot, c);
           x.ch := c;
           cMode.md.bin :=  x.md.bin and vMode.md.bin;
           recBinary := cMode.md.bin;
           if loopbk then xmitBinary := recBinary;
           if cMode.md.bin then
               begin
               write ('binary ');
               end
           else
               write ('radix 41 ');
           
           cMode.md.full := x.md.full and vMode.md.full;
           recFull := cMode.md.full;
           if cMode.md.full then
               begin
               write ('full duplex ')
               end
           else
               write ('half duplex ');
           
           {check baud rate}
           result := ppsRead (ctrlInSlot, c);
           x.ch := c;
           maxCommonBaud (x, vBaud, cBaud, newBaud);
           write (newBaud, ' baud.');
           recBaud := newBaud;
           writeln;
           {get rmt max ltb size}
           result := ppsRead (ctrlInSlot, c);
           x.ch := c;
           rmtRecDataSz := x.bte;
           writeln ('Max remote receive data size: ',rmtRecDataSz);
           if maxXmitDataSz > rmtRecDataSz then 
               xmitDataSz := rmtRecDataSz
           else
               xmitDataSz := maxXmitDataSz;
           writeln ('Xmit data size: ', xmitDataSz);
           
           {send reply}
           ctrLock := TRUE;
           x.bte := IW+PROTO;
           result := ppsWrite (ctrlOtPPS, x.ch);
           result := ppsWrite (ctrlOtPPS, cMode.ch);
           result := ppsWrite (ctrlOtPPS, cBaud.ch);
           x.bte := recDataSz;
           result := ppsWrite (ctrlOtPPS, x.ch);
           end
       else
       if x.bte = IWPROTO then
           begin
           writeln; write ('Setting  ');
           {set modes}
           result := ppsRead (ctrlInSlot, c);
           cMode.ch := c;
           if cMode.md.bin then
               begin
               recBinary := TRUE;
               xmitBinary := TRUE;
               write ('binary ');
               end
           else
               begin
               recBinary := FALSE;
               xmitBinary := FALSE;
               write ('radix 41 ');
               end;
           
           if cMode.md.full then
               begin
               recFull := TRUE;
               xmitFull := TRUE;
               write ('full duplex ');
               end
           else
               begin
               recFull := FALSE;
               xmitFull := FALSE;
               write ('half duplex ');
               end;
           {set baud}
           result := ppsRead (ctrlInSlot, c);
           x.ch := c;
           maxCommonBaud (x, vBaud, cBaud, newBaud);
           recBaud := newBaud;
           xmitBaud := newBaud;
           writeln (newBaud, ' baud.');
           
           {get rmt max LTB size}
           result := ppsRead (ctrlInSlot, c);
           x.ch := c;
           rmtRecDataSz := x.bte;
           writeln ('Max remote receive data size: ',rmtRecDataSz);
           if maxXmitDataSz > rmtRecDataSz then 
               xmitDataSz := rmtRecDataSz
           else
               xmitDataSz := maxXmitDataSz;
           writeln ('Xmit data size: ', xmitDataSz);
           
           {send reply to complete sequence}
           ctrLock := TRUE;
           x.bte := PDGOPROTO;
           result := ppsWrite (ctrlOtPPS, x.ch);
           end
       else
       if x.bte = PDGOPROTO then
           begin
           xmitBinary := cMode.md.bin;
           xmitFull := cMode.md.full;
           xmitBaud := recBaud;
           writeln ('Mode change complete.');
           end
       else
           begin
           byteprint (x.ch);
           while ppsRead (ctrlInSlot, c) = OK do byteprint (c);
           end;
       end;
end;
                

procedure pCtrl;
{purpose:Control process}
var
  i:integer;
  x: byte;
  sysname: string;
  result: exception;
  sfile: text;
begin
    case ctrlState of
        
        SNDSYSNAME: begin
                    ctrLock := TRUE;
{|||}               WRITELN;            {|||}
                    {$I-}
                    reset (sfile, 'sysname.text');
                    {$I+}
                    if IORESULT <> 0 then
                        begin
                        writeln ('Unable to open sysname.text.');
                        end
                    else
                        begin
                        repeat
                            read (sfile, c);
                            result := ppsWrite(ctrlOtPPS, c);
                        until EOLN(sfile) or (result <> OK);
                        close (sfile);
                        end;
                    if mynode = ORG then
                        ctrlState := REQPROTO       
                    else
                        ctrlState := CIDLE;
                    end;
        REQPROTO  : begin 
                    ctrLock := TRUE;
                    x.bte := PD + PROTO;        {send control code}
                    result := ppsWrite (ctrlOtPPS, x.ch);
                    {send valid modes}
                    result := ppsWrite (ctrlOtPPS, vMode.ch);
                    {send valid bauds}
                    result := ppsWrite (ctrlOtPPS, vBaud.ch);
                    x.bte := recDataSz;       {max amount of data to rec }
                    result := ppsWrite (ctrlOtPPS, x.ch);
                    ctrlState := CIDLE;
                    end;
    end;
    
    if ctrlInPPS = NULLPPS then
        findRecPPS (CTRL, 0, ctrlInSlot, ctrlInPPS);
    
    if ctrlInPPS <> NULLPPS then
        decodeCtrlMsg;
end;



{---------------- FTP MESSAGE PARSER ------------------------}

procedure ftpMsgParser (inSlot: integer; 
           VAR srcname, destname: string; 
           VAR fLength: fileLength);
{purpose: Parse incomming FTP request}
var
    msgLen, i: integer;
    x: byte;
    result: exception;
begin
    result := ppsRead (inSlot, c);
    x.ch := c;
    msgLen := x.bte;
    result := ppsRead (inSlot, c);
    x.ch := c;
    fLength[0] := x.bte; {length of file in bits }
    result := ppsRead (inSlot, c);
    x.ch := c;
    fLength[1] := x.bte; {not used in this version}
    result := ppsRead (inSlot, c);
    x.ch := c;
    fLength[2] := x.bte;
{$R-}
    {get source file name }
    result := ppsRead (inSlot, c);
    x.ch := c;
    i := 1;
    while x.ch <> chr(CR) do
        begin
        srcname[i] := x.ch;
        result := ppsRead (inSlot, c);
        x.ch := c;
        i := i+1;
        end;
    srcname[0]:=chr(i-1);  {See Note 1}
    
    { get destnation name }
    result := ppsRead (inSlot, c);
    x.ch := c;
    i := 1;
    while x.ch <> chr(CR) do
        begin
        destname[i] := x.ch;
        result := ppsRead (inSlot, c);
        x.ch := c;
        i := i+1;
        end;
    destname[0]:=chr(i-1);  {See Note 1}
{$R+}
end;

{--------------- FTP SENDER ---------------------------}

procedure fsndinit;

{purpose: Initialize ftp sender at startup.}

begin
    fsndstate:=idle;
    xfiletype:=0;
    xfilesize.intval:=0;
    xname := ' ';
    destname := ' ';
    fSndInPPS := NULLPPS;
end;


procedure ftpstart;
{purpose: Does setup for file sending when requested locally.}         
var 
  cnt:integer;
begin
    if fsndstate<>idle then
        begin
        {$I-}
        writeln;writeln ('Sender is busy transfering ',xname,' to ',destname);
        write ('Do you wish to abort this transfer ? (Y/N):');
        read (c);
        writeln;
        if c in ['Y','y'] then
            begin {set up conditions that indicate end to sender}
            fsndstate:= localabort;
            menuexit := TRUE;
            end;
        end
    else
        begin
{|||    writeln; |||} writeln; write ('Name of file to be sent: ');
        readln (xname);
{|||    writeln; |||} write ('Name of destination file: ');
        readln (destname);
{|||    writeln; |||}
        reset (xfile, xname);
        if IORESULT <> 0 then 
            begin
            writeln ('Unable to open ',xname);
            end
        else
            begin
               fsndstate:=initiate;
               ppsopen (FTPSND, LSTNER, fSndOtPPS);
               menuexit := TRUE;
           end;
       end;
    {$I+}
end;



function rmtsndstart;

{purpose: Does setup for file sending when requested from remote.}

var
    fLength: fileLength;
begin
    {$I-}
    {$R-}
    if fsndstate<>idle then {already busy}
        rmtsndstart:=FALSE 
    else
        begin
        ftpMsgParser (inSlot, xname, destname, fLength);
        if ftpmon then
            begin
            writeln;writeln ('Remote start opening ',xname,' to ',destname);
            end;
        reset (xfile, xname);
        if IORESULT<>0 then   {could not open file}
            rmtsndstart := false
        else
            begin
            ppsopen (FTPSND, LSTNER, fSndOtPPS);
            fsndstate:=initiate;
            rmtsndstart :=TRUE
            end
       end
{$R+}
{$I+}
end;



procedure ftpSndRec (x: byte);
{purpose: Decode incomming FTP conrol messages}
begin

    case fsndstate of
        request:    begin
                    if x.bte = (IW + RF) then { i will receive file}
                        begin
                        writeln ('accepted');
                        fsndstate:=send;
                        end             
                    else
                        begin
                        writeln ('refused');
                        rppsredirect (fSndInSlot, SINK);
                        fSndInPPS := NULLPPS;
                        ppsclose (fSndOtPPS);
                        close (xfile);
                        fsndstate := idle;
                        end;
                    end;
        ack:        begin
{|||}               WRITELN; {|||}
                    write ('Transfer of ',xname,' to ',rname);
                    if x.bte = (IW + AF) then { i will accept this file}
                        writeln(' completed sucessfully.')
                    else
                        writeln (' refused - code: ', x.bte);
                    rppsredirect (fSndInSlot, SINK);
                    fSndInPPS := NULLPPS;
                    close (xfile);
                    fsndstate := idle;
                    end;
        send:       begin
                    if x.bte = (IWN + AF)  then
                        begin
                        writeln;
                        writeln ('Transfer of ',xname,' to ',rname,' aborted by receiver.');
                        ppsclose (fSndOtPPS);
                        rppsredirect (fSndInSlot, SINK);
                        fSndInPPS := NULLPPS;
                        close (xfile);
                        fsndstate := idle;
                        end;
                    end;
        end;
end;



procedure pFtpSnd;
{purpose: Transmits file contents to FTP receiver.}
label
    1;
var
    result: exception;
    i, cnt:integer;
    x: byte;
    c:char;
    tmpstr:string;
    tmp: integer;
begin
    if fsndstate = idle then
        goto 1;
        
    if fSndInPPS = NULLPPS then
        findRecPPS (FTPSND, 0, fSndInSlot, fSndInPPS);

    if fSndInPPS <> NULLPPS then
        begin
        result := ppsRead (fSndInSlot, c);
        x.ch := c;
        if (result = LAST) or (result = ERROR)  then
            fSndInPPS := NULLPPS
        else
            if result <> EMPTY then
                begin
                ftpSndRec (x);
                end;
        end;
    
            
    case fsndstate of
        request:  ;
        ack:      ;
        idle:     ;
        localabort: begin
                    x.bte := PDN + AF;
                    result := ppsWrite (fSndOtPPS, x.ch);
                    ppsclose (fSndOtPPS);
                    rppsredirect (fSndInSlot, SINK);
                    fSndInPPS := NULLPPS;
                    close (xfile);
                    fsndstate := idle;
                    end;
        send:     begin
                  {$R-}
                  if statusOtPPS (fSndOtPPS) = OK then
                      begin
                      repeat
                          if xbufptr = BLKSZ then        {get next blk from disk}
                              begin
                              if EOF(xfile) then {note: this eof occurred on the previous read}
                                  begin
                                  x.bte := PD + AF;
                                  result := ppsWrite (fSndOtPPS, x.ch);
                                  ppsclose (fSndOtPPS);
                                  fsndstate := ack;
                                  end
                              else
                                  begin
                                  {$I-}
                                  cnt := blockread (xfile, xblk, 1, xfilptr);
                                  {$I+}
                                  xfilptr := xfilptr+1;
                                  if IORESULT <> 0 then
                                      begin
                                      writeln; 
                                      writeln ('File sender I/O error ',IORESULT,' file ',
                                                xname,'...');
                                      x.bte := PDN + AF;
                                      result := ppsWrite (fSndOtPPS, x.ch);
                                      ppsclose (fSndOtPPS);
                                      rppsredirect (fSndInSlot, SINK);
                                      fSndInPPS := NULLPPS;
                                      close (xfile);
                                      fsndstate := idle;
                                      end
                                  else
                                      xbufptr := 0;
                                  end
                              end
                          else
                                begin
                                {for efficency this transfer does not use ppsWrite}
                                with xppstbl[fsndOtPPS] do
                                    begin
                                    buf[nxtptr] := xblk[xbufptr];
                                    nxtptr := nxtptr+1;
                                    if nxtptr = PPSBUFSZ then
                                        nxtptr := 0;
                                    tmp := nxtptr+1;
                                    if tmp = PPSBUFSZ then
                                        tmp := 0;
                                    xbufptr := xbufptr+1;
                                    end;
                                end;
                      until (tmp = xppstbl[fsndOtPPS].fstptr) or (fsndstate <> send);
                      end;
                  end;
                  {$R+}
        initiate: begin
{|||              writeln;      |||}
                  write ('Request to transfer ',xname,' to ',destname);
                  x.bte:= PD + RF;  { please do receive file}
                  result := ppsWrite (fSndOtPPS, x.ch);
                  tmpstr:= concat(xname, acr ,destname, acr);
                  x.bte := length(tmpstr)+5;  {length of this message in bytes }
                  result := ppsWrite (fSndOtPPS, x.ch);
                  x.bte:= 0;  {24 bit length in bits, low byte first }
                              {always zero in this version }
                  result := ppsWrite (fSndOtPPS, x.ch);
                  result := ppsWrite (fSndOtPPS, x.ch);
                  result := ppsWrite (fSndOtPPS, x.ch);
                  
                  for i:= 1 to length(tmpstr) do
                      result := ppsWrite (fSndOtPPS, tmpstr[i]);
                  
                  xeof:= FALSE;
                  xbufptr := BLKSZ;
                  xfilptr:=0;
                  fsndstate:=request;
                  end 
        end;
1:
end;

{------- LISTNER ------------}

{ This process acts as a well known process to setup file transfers.}

procedure pListner;
{purpose: Listner process}

var
    i:integer;
    x: byte;
    result: exception;
begin
{$I-}
    findRecPPS (LSTNER, 0, lsnrInSlot, lsnrInPPS);
    
    if lsnrInPPS <> NULLPPS then
        begin
        result := ppsRead (lsnrInSlot, c);
        x.ch := c;
        if ftpmon then
            begin
            writeln; writeln ('Listener requested to:',x.bte);
            end;
        
        if x.bte= (PD + RF) then { please receive file}
            begin
            ppsopen (LSTNER, rppstbl[lsnrInSlot].srcproc, lsnrOtPPS);
            if frecstart (lsnrInSlot) then {FTP receiver ready}
                begin
                x.bte:= IW + RF;  { i will receive file};
                rppsredirect (lsnrInSlot, FTPREC)
                end
            else {receiver not ready}
                begin
                x.bte := IWN + RF; { i will not receive file}
                rppsredirect (lsnrInSlot, SINK)
                end;
            result := ppsWrite (lsnrOtPPS, x.ch);
            ppsclose (lsnrOtPPS);
            end
        else
            if x.bte= (PD + SF) then { please do send file}
                begin
                ppsopen (LSTNER, rppstbl[lsnrInSlot].srcproc, lsnrOtPPS);
                if rmtsndstart(lsnrInSlot) then 
                    x.bte := IW + SF { i will send file}
                else
                    x.bte := IWN + SF; { i will not send file}
                if ftpmon then
                    begin
                    writeln;
                    write ('LISTENER - remote request to transfer ');
                    if x.bte= (IWN + SF) then
                        writeln(' refused')
                    else
                        writeln(' accepted');
                    end;
                result := ppsWrite (lsnrOtPPS, x.ch);
                ppsclose (lsnrOtPPS);
                end
            else {unknown request}
               if ftpmon then
                   begin
                   writeln;
                   writeln ('LISTENER - Unknown request type ',x.bte)
                   end;
       end;
{$I+}
end;


{------- FTP RECEIVER -------------}

procedure frecinit;

{purpose: Initializes FTP receiver at startup.}

begin
    receiving:=FALSE;
    srcname := ' ';
    rname := ' ';
end;



function frecstart;

{purpose: Setup receiver for a file transfer.}

var
  msgLen: integer;
  fLength: fileLength;
begin
    frecstart:=FALSE;
    if not receiving then 
         begin {initialization for receiver }
         ftpMsgParser (inSlot, srcname, rname, fLength);
{|||}    WRITELN;       {|||}
         write('Request to receive  ',rname,' from ',srcname, '...');
         {$I-}
         reset (rfile,rname);
         if IORESULT=0 then {file already exists}
             begin
{|||         writeln; |||}
             writeln ('local file ',rname,' already exists, transfer refused.');
             close (rfile);
             end
         else
             begin
             rewrite (rfile, rname);
             if IORESULT<>0 then
                 begin
{|||             writeln; |||}
                 writeln ('unable to create local file ',rname,' transfer refused.')
                 end
             else
                begin
                writeln ('accepted.');
                frecInPPS := NULLPPS;
                rfilptr:=0;
                rbufptr := 0;
                receiving := TRUE;
                frecstart:=TRUE;
                firstChar := TRUE;
                end
            end
         end
{$I+}
end;


procedure pftpRec;
{purpose: FTP receiver process}
label
    1;
var
{|||} SpareBlk : Blk;      {|||}
    cnt,i:integer;
    x: byte;
    result: exception;
begin
    if not receiving then goto 1;
    
    if frecInPPS = NULLPPS then
        begin
        findRecPPS (FTPREC, 0, frecInSlot, frecInPPS);
        if frecInPPS = NULLPPS then goto 1;
        end;
    
    if firstChar then
        begin
        result := ppsRead (fRecInSlot, c);
        lastc.ch := c;
        if result = OK then firstChar := FALSE;
        end;
    
    {|||   $R-} {turn off range checking for speed}
    if not firstChar then
        repeat
            result := ppsRead (fRecInSlot, c);
            x.ch := c;
            if result = OK then
                begin
                rblk[rbufptr] := lastc.ch;
                lastc.ch := x.ch;
                rbufptr := rbufptr+1;
                if rbufptr = BLKSZ then
                   begin
{$I-|||}
                   cnt := blockwrite (rfile, rblk, 1, rfilptr);
{|||    Vol Sys Mod     |||}
                   WHILE Cnt = 1 DO BEGIN
                       IF (BLOCKREAD (RFile, SpareBlk, 1, RFilPtr) = 1)
                                              AND (SpareBlk = RBlk)
                           THEN Cnt := 0
                           ELSE Cnt := BLOCKWRITE (RFile, RBlk, 1, RFilPtr)
                       END;
{$I+|||}
                   rfilptr := rfilptr+1;
                   rbufptr := 0;
                   if IORESULT <> 0 then
                      begin
                      ppsopen (FTPREC, rppstbl[frecInSlot].srcproc, fRecOtPPS);
                      x.bte:=IWN + AF; {i will not accept file}
                      ppsclose (fRecOtPPS);
                      rppsredirect (fRecInSlot, SINK);
                      receiving := FALSE;
                      end;
                   end;
                end;
        until result <> OK;
    {|||$R+}

    {$I-}
    if result = LAST then  {last block of a file transfer}
        begin
        receiving := FALSE;
        writeln;
        if lastc.bte= (PDN + AF) then
            begin
            close (rfile);
            writeln ('Received abort request on transfer of ',rname);
            end
        else
            begin
            close (rfile, lock);
            ppsopen (FTPREC, rppstbl[frecInSlot].srcproc, fRecOtPPS);
            if IORESULT <> 0 then
               begin
               writeln ('FTP REC - close error ',IORESULT,' on ',rname);
               x.bte:=IWN + AF;
               end
            else
               begin
               writeln ('FTP REC - transfered ',rfilptr,' blocks to ',rname);
               x.bte:=IW + AF; {i will accept file}
               end;
            result := ppsWrite (fRecOtPPS, x.ch);
            ppsclose (fRecOtPPS);
            receiving := FALSE;
            end
        end
    else
        if result = ERROR then
            begin
            ppsopen (FTPREC, rppstbl[frecInSlot].srcproc, fRecOtPPS);
            x.bte:=IWN + AF;
            result := ppsWrite (fRecOtPPS, x.ch);
            ppsclose (fRecOtPPS);
            rppsredirect (fRecInSlot, SINK);
            receiving := FALSE;
            end;
1:
{$I+}
end;
    

{------------ GET - REQUEST A FILE FROM REMOTE ----------------}

{Local process to request a file from remote node.}

procedure getftp;

{purpose: Get name of remote file from user.}

var
    getFtpOtPPS: integer;
    gname,localname:string;
    x: byte;
    result: exception;
begin
{|||writeln; |||} write ('Transfer remote file: ');
    readln (gname);
{|||writeln;|||}
    write ('To local file: ');
    readln (localname);
{|||writeln;|||}
    write ('Transfer of ',gname,' to ',localname,'...');
    ppsopen (GETFILE, LSTNER, getFtpOtPPS);
    x.bte:= PD + SF;  { please do receive file}
    result := ppsWrite (getFtpOtPPS, x.ch);
    getstr:=concat (gname, acr, localname, acr);
    x.bte := length(getstr)+5;  {length of this message in bytes }
    result := ppsWrite (getFtpOtPPS, x.ch);
    x.bte:= 0;  {24 bit length in bits, low byte first }
                {always zero in this version }
    result := ppsWrite (getFtpOtPPS, x.ch);
    result := ppsWrite (getFtpOtPPS, x.ch);
    result := ppsWrite (getFtpOtPPS, x.ch);
    
    for i:= 1 to length(getstr) do
        result := ppsWrite (getFtpOtPPS, getstr[i]);
    ppsclose (getFtpOtPPS);
    menuexit:=TRUE;
end;


procedure pGetFtp;
{purpose: Get FTP process}
var
    ppsno, slot: integer;
    result: exception;
    x: byte;
begin
    findRecPPS (GETFILE, 0, slot, ppsno);
    if ppsno <> NULLPPS then
        begin
        result := ppsRead (slot, c);
        x.ch := c;
        if result = OK then
            if x.bte = (IW + SF) then
                writeln ('initiated')
            else
                writeln ('refused - code: ', x.bte);
        end;
end;



{----------------- TERMINAL PROCESS --------------------------------}

procedure terminit;

{purpose: Initialize terminal process at setup time.}

begin
    ppsopen (TERM, TERM, termot);
    termInPPS := NULLPPS;
    kbInterrupt := FALSE;
end;


procedure pTerm;
{purpose: PTP terminal process}
var
    c: char;
    chc:packed array[0..0] of char;
    status: exception;
begin
    if termInPPS = NULLPPS then
        findRecPPS (TERM, 0, termInSlot, termInPPS);
    
    if termInPPS <> NULLPPS then
        while ppsRead (termInSlot, c) = OK do
            write (c);
    
    { check for key board character}
    if kbInterrupt then 
        begin
        kbInterrupt := FALSE;
        writeln;
        write ('> ');
        write (fstKbCh);
        if ppsWrite (termot, fstKbCh) = OK then
            repeat
                unitread (2,chc[0], 1,0,0);
                status := ppsWrite (termot, chc[0]);
                write (chc[0]);
                if status <> OK then writeln (' status not ok');
            until (chc[0] = chr(13)) or (status <> OK);
        end;
end;
    
{-------- PTP START --------------------}

procedure ptpinit;
{purpose: Initialize PTP }
begin
    modeInit;
    ltbinit;
    ppsinit;
    ctrlinit;
    terminit;
    frecinit;
    fsndinit;
end;


procedure firstptpinit;
{purpose: Initialization required before first PTP invocation}
begin
    trace := FALSE;
    ppsmon := FALSE;
    ftpmon := FALSE;
    loopbk := FALSE;
    ansbrkt := '[';
    orgbrkt := ']';
    ptpinit;
end;


procedure ptprun;
{purpose: Start PTP}
begin
    mynode := modemMode;
    if mynode = ANS then
        timeout := ANSTIMEOUT
    else
        timeout := ORGTIMEOUT;
    ptpinit;
    if mynode = ANS then
{|||}   BEGIN Delay (10);       {|||}
        endxmit;                {send turn around }
{|||}   END;                    {|||}
    sched;
end;
    
    
{--------------------- PTP MENU ---------------------------}
    
procedure monitor;

{purpose: Allows the user to control tracing for debugging.}

begin
    repeat
        writeln;
        write('Trace LTB ? (Y/N)');
        read(c);
        case c of
        'y','Y': trace := TRUE;
        'n','N': trace :=FALSE;
        end;
    until c in ['y','Y','n','N'];
    repeat
        writeln;
        write('Trace PPS ? (Y/N)');
        read(c);
        case c of
        'y','Y': ppsmon := TRUE;
        'n','N': ppsmon :=FALSE;
        end;
    until c in ['y','Y','n','N'];
    repeat
        writeln;
        write('Trace FTP ? (Y/N)');
        read(c);
        case c of
        'y','Y': ftpmon := TRUE;
        'n','N': ftpmon :=FALSE;
        end;
    until c in ['y','Y','n','N'];
    repeat
        writeln;
        write('Local loopback test ? (Y/N)');
        read(c);
        case c of
        'y','Y': begin
                     ansbrkt:=']'; orgbrkt:=']';
                     loopbk := TRUE;
                 end;
        'n','N': begin
                     ansbrkt:='['; orgbrkt:=']';
                     loopbk := FALSE;
                 end
        end;
    until c in ['y','Y','n','N'];
{|||writeln; |||}
end;

procedure setModes;
{purpose: Sets the valid PTP modes and baud rates}
begin
{|||writeln; |||}
    vMode.bte := 0;
    repeat
        writeln;
        write('Binary mode? (Y/N)');
        read(c);
        case c of
        'y','Y': vMode.md.bin := TRUE;
        'n','N': vMode.md.bin := FALSE;
        end;
    until c in ['y','Y','n','N'];
    
    vBaud.bte := 0;
{|||
    while vBaud.bte = 0 do
        begin
        writeln;
        writeln ('Enter valid baud rates (y/n)');
        write ('4800:');
        read (c);
        if (c = 'y') or (c = 'Y') then
            vBaud.bd.b4800 := TRUE;
        write (' 2400:');
        read (c);
        if (c = 'y') or (c = 'Y') then
            vBaud.bd.b2400 := TRUE;
        write (' 1200:');
        read (c);
        if (c = 'y') or (c = 'Y') then
            vBaud.bd.b1200 := TRUE;
        write (' 600:');
        read (c);
        if (c = 'y') or (c = 'Y') then
            vBaud.bd.b600 := TRUE;
        write (' 450:');
        read (c);
        if (c = 'y') or (c = 'Y') then
            vBaud.bd.b450 := TRUE;
        write (' 300:');
        read (c);
        if (c = 'y') or (c = 'Y') then
            vBaud.bd.b300 := TRUE;
        write (' 150:');
        read (c);
        if (c = 'y') or (c = 'Y') then
            vBaud.bd.b150 := TRUE;
        write (' 110:');
        read (c);
        if (c = 'y') or (c = 'Y') then
            vBaud.bd.b110 := TRUE;
        if vBaud.bte = 0 then
            begin
            writeln; writeln ('Please enter at least one valid baud rate.');
            end;
        end;
    writeln; 
|||}
    WITH vBaud.Bd DO BEGIN
        b_300 := TRUE;
        b1200 := TRUE;
        WRITELN;
        WRITELN ('Baud Rates : 300, 1200')
        END;
{|||}
    {$I-}
    repeat
{|||
        write ('Enter recever data size (32-'); write (MAXLTBSZ-15);
        write ('): ');
        readln (recDataSz);
|||}
        RecDataSz := MaxLtbSz-18;
        WRITELN ('Receiver Data Size - ', RecDataSz)
{|||}
    until (IORESULT = 0) and (recDataSz >= 32) and (recDataSz <= (MAXLTBSZ-15));
    
    repeat
{|||
        write ('Enter xmitter data size (32-'); write (MAXLTBSZ-15);
        write ('): ');
        readln (maxXmitDataSz);
|||}
        MaxXmitDataSz := MaxLtbSz-18;
        WRITELN ('Tansmitter Data Size - ', MaxXmitDataSz)
{|||}
    until (IORESULT = 0) and (maxXmitDataSz >= 32) 
          and (maxXmitDataSz <= (MAXLTBSZ-15));
{|||writeln; |||}
    {$I+}
    
    ctrlState := REQPROTO;
end;
    
    
procedure exiter;

{purpose : Terminates PTP program after warning user if transfers are in progress.}

var
   c:char;
begin
   {$I-}
   if receiving or (fsndstate <> idle) then
      begin
      writeln; 
      write('Currently engaged in file transfer.');
      writeln; write ('Are you sure you want to exit? (Y/N): ');
      read (c);
      if (c='Y') or (c='y') then
          begin
          close (rfile,lock);
          close (xfile);
          sch := done;
          menuexit := true;
          end;
      end
   else
      begin
      sch := done;
      menuexit := true;
      end;
{$I+}
end;

      
procedure menu;

{purpose: PTP menu loop.}

begin
    menuexit := FALSE;
    repeat
        writeln;
        write ('G(et S(end M(ode T(race I(nitialize E(xit: ');
        read (c);
        case c of
            'S','s':ftpstart;
            'E','e':exiter;
            'M','m': setModes;
            'T','t':monitor;
            'I','i':ptpinit;
            'G','g':getftp;
            end;
    until eoln or menuexit;
    writeln;
end;



{------------ RAW TERMINAL  ---------------}

{Process which allows raw data typed on the terminal to be sent over
 the serial line, used for debugging. Also used to allow login to timesharing
 systems.
 }

procedure rawterm;
var 
   c: char;
   termdone:boolean;
   ch:packed array [0..0] of char;
begin
    termdone:=FALSE;
    repeat
        if not cts then
            begin
            writeln;
            writeln ('CARRIER LOST');
            termdone := true;
            end;
        if kbstat then
            begin
            unitread (2,ch[0],1,0,0);
            if ch[0]=chr(ATTENCHAR) then 
               termdone:=TRUE
            else 
               begin
               if halfduplex then write(ch[0]);
               putserial(ch[0])
               end
            end;
        if mrecstat then
            begin
            c:=mread;
            if c <> chr(LF) then write (c);   
            end;
   until termdone=TRUE;
end;

procedure initrawterm;
begin
    halfduplex := false;
end;

{--------------------- MODEM CONTROL ---------------------------}

procedure hangitup;
{purpose: Hangup phone and wait for loss of carrier}
begin
    hangup;
    while cts do;
end;

procedure progStart;
{purpose: Start the selected program}
begin
    case progSelect of
        PT: ptprun;
        RT: rawterm;
        end;
end;

function estconnection: boolean;
{purpose: Establish modem connection}
var
    i: integer;
    cd: boolean;
begin
    delay (10);
    
    {turn dtr on sh off }
    dtron;                           
{|||
    write ('waiting for carrier... ');
|||}
    WRITELN ('Modem Switch may be needed to Engage Carriers.');
    WRITE ('Waiting 60 seconds for Carrier... ');
{|||}
    
    { set baud rate and mode}
    delay (1); {.10 seconds }
    baud;                 
    
    {wait for carrier }
    i := 0;               {Pascal for this might be                           }
    repeat                { WHILE (NOT (Cts OR KbStat)) AND (I<200) DO BEGIN  } 
        cd :=cts;         {    I := I + 1;                                    }
        if cd = false then{    Delay (10)                                     }
            delay (10);   {    END;                                           }
        i := i+1;
(*|||   Vol Sys Mod
    until cd or (i = 200) or kbstat;           { 20 seconds to answer }
|||*)
    until cd or (i = 60) or kbstat;           { 60 seconds to answer }
{|||}
    if cd = false then    { IF NOT Cd THEN                                    }
        begin
{|||
        writeln ('no answer, phone on hook');
|||}
        WRITELN ('Never got their Carrier.');
{|||}
        hangitup;
        end
    else
        begin
        writeln ('carrier detected');
        progStart;
        end;
    estconnection := cd;
end;


procedure go;
{purpose: Used when modem connection may already be established}
var
    result: boolean;
begin
    if modemMode = ANS then
        ri
    else
        sh;
    result := estconnection;
end;


procedure dialnum;
{purpose: Get dial tone and dial number}
var
    i, j: integer;
    result: boolean;
begin
    modemMode := ORG;
    result := true;
    { hangup }
    hangitup;
    {go off hook }
    sh;
    {wait for dial tone }
    i := 0;
    repeat
        result := dtonedet;
        if not result then
            delay (5); {.5 seconds }
        i := i+1;
    until result or (i = 10);                 { 5 seconds for dial tone }
    
    if not result then
        writeln ('no dial tone')
    else
        { dial number }
        begin
        delay (3);        { delay .3 seconds }
        writeln;
        write ('DIALING: ');
        i := 1;  
        while (i <= length(telnum)) and result do
            begin
            write (telnum[i]);
            if (telnum[i] >= '0') and (telnum[i] <= '9') then
                dialer (telnum[i])
            else
                if telnum[i] = '*' then
                    begin
                    {wait for dial tone }
                    j := 0;
                    repeat
                        result := dtonedet;
                        if not result then
(*|||
                            delay (50); {.5 seconds }
|||*)
                            Delay (5); {.5 seconds }
{|||}
                        j := j+1;
                    until dtonedet or (i = 10);     { 5 seconds for dial tone }
                    if not result then
                        writeln ('no dial tone')
                    end;
            i:= i+1;     
            end;
       writeln;
       if result then
           result := estconnection;
    end;
end;
       
procedure dial;
{purpose: Get number to be dialed, and call dialer}
var
    ready: boolean;
begin
    writeln;
    write ('Enter number to be dialed: ');
    readln (telnum);
    dialnum;
end;
    
procedure contRedial;
{purpose: Redail continuely}
var
    ready: boolean;
    kbrdy: boolean;
begin
    repeat
        dialnum;
        kbrdy := kbstat;
        if not ready and not kbrdy then
            delay (30);           { wait 30 seconds}
        kbrdy := kbstat;
    until ready or kbrdy;
end;


function autoanswer: boolean;
begin
    initState;
    progSelect := PT;
    modemMode := ANS;
    autoanswer := false;
    writeln;
    write ('Waiting for call...');
    repeat
    until ringing or kbstat;
{|||    Vol Sys Mod
    if ringing then
        delay (10);                     
    if ringing then
        begin
        ri;
        autoanswer := estconnection;
        end;
|||}
    IF NOT KbStat THEN BEGIN   {Only test Ringing once}
        DtrOn;
        Delay (10);
        Ri;
        AutoAnswer := EstConnection;
        UartCmd (FALSE)  {can't hangitup cause might be unattended}
        END
{|||}
end;


procedure uattended;
{purpose: Unattended autoanswer mode}
begin
    repeat
        if autoanswer then
{|||
            progStart;
|||         ; {autoanswer will have done it   |||}
    until kbstat;
end;


procedure changeBaud;
{purpose: Change to specified baud rate}
const
    baudFac = 15625;        {used to calculate baud rate for PMMI modem only}
begin
    currentBaud := rate;
{|||
    baudrate := baudFac div rate;
|||}
    BaudRate := Rate;
{|||}
    baud;
end;


procedure setBaud;
{purpose: Set PTP receiver and xmitter baud rates and set baud rate}
begin
    xmitBaud := rate;
    recBaud := rate;
    changeBaud (rate);
end;

procedure getBaud;
{purpose: Get user requested baud rate and set}
var
    rate: integer;
begin
    {$I-}
    repeat
        writeln;
        write ('Enter baud rate (110-4800): ');
        readln (rate);
    until (IORESULT = 0) and (rate >=110) and (rate <= 4800);
    {$I+}
    setBaud (rate);
end;


procedure options;
{purpose: Call specified option setting routine}
begin
    writeln;
    write (
'P(TP M(ode T(race O(rg A(ns / R(awTerm B(aud F(ullduplex H(alfduplex: ');
    read (c);
    case c of 
        'P','p': progSelect := PT;
        'R','r': progSelect := RT;
        'B','b': getBaud;
        'F','f': halfduplex := false;
        'H','h': halfduplex := true;
        'T','t': monitor;
        'M','m': setModes;
{|||}   
        'O','o': ModemMode := Org;
        'A','a': ModemMode := Ans;
{|||}
    end;
end;


procedure modemMenu;
{purpose: Display modem menu}
var
    c: char;
    ready: boolean;
begin
    repeat
        writeln;
{$I-|||}
        CLOSE (RFile, LOCK);
        CLOSE (XFile, LOCK);
{$I+|||}
        case progSelect of
{|||        Vol Sys Mod         |||}
            PT: BEGIN
                WRITE ('PTP Mode-');
                IF ModemMode = Org 
                    THEN WRITE ('ORG')
                    ELSE IF ModemMode = Ans
                        THEN WRITE ('ANS');
                WRITE (' Xmit-');
                IF XmitBinary 
                    THEN WRITE ('Bin')
                    ELSE WRITE ('R41');
                WRITE (' Recv-');
                IF RecBinary
                    THEN WRITE ('Bin')
                    ELSE WRITE ('R41')
                END;
            RT: BEGIN
                write ('RAW ');
                IF HalfDuplex
                    THEN WRITE ('Half')
                    ELSE WRITE ('Full');
                WRITE ('Duplex')
                END;
{|||}
        end;
        write (' ',currentBaud,' baud ');
{|||}   if cts or loopbk then
            begin
            writeln (' Carrier');
{|||        writeln;    |||}
            write ('E(xit G(o H(angup O(ptions U(nattended: ');
            read (c);
            case c of 
                'H','h': hangitup;
                'G','g': progStart;
                'O','o': options;
                'U','u': uattended;
                end;
            end
        else
            begin
            writeln (' OnHook');
{|||
            writeln;
|||}
write (
   'A(utoans C(ntdial D(ial E(xit G(o H(angup O(ptions R(edial U(nattended : ');
            read (c);
            case c of 
                'D','d': dial;
                'R','r': dialnum;
                'C','c': contRedial;
                'A','a': ready := autoanswer;
                'O','o': options;
                'G','g': go;
                'H','h': hangitup;
                'U','u': uattended;
               end;
        end;
   until (c = 'E') or (c = 'e');
end;

procedure initState;
{purpose: Initial modem state}
    begin
    setBaud (300);
    cBaud.bte := 0;
    cBaud.bd.b300 := TRUE;
    recBinary := FALSE;
    xmitBinary := FALSE;
    recFull := FALSE;
    xmitFull := FALSE;
end;

procedure modInit;
{purpose: Initial state at starup}
begin
    progSelect := RT;
    unattended := false;
    initState;
    modemInit;
end;


{------------------- INITIALIZATION  -----------------}

procedure init;

{purpose: Calls individual initialization procedures.}

begin
    {init a CR string}
    {$R-}
    acr[0] := chr(1);
    acr[1] := chr(CR);
    {$R+}
{|||}
    ModemMode := ORG;
{|||}
    mynode := ORG;
    initrawterm;
    firstptpinit;
    modInit;
end;

begin {main}
    
{|||}
    PAGE (OUTPUT);
    writeln;
    writeln (title);
    writeln;
    writeln (version);
{|||}
    
    writeln;
    setModes;
    init;
    modemMenu;
    hangitup;
end.

========================================================================================
DOCUMENT :usus Folder:VOL06:ri.a.text
========================================================================================

        .PROC   RI,0 
        .PRIVATE RETADDR
        
TPORT   .EQU    0C0H            ;UART CONTROL PORT
RPORT   .EQU    TPORT+2         ;RATE PORT
RIBT    .EQU    02H             ;RI (MODEM WILL BE IN ANSWER MODE)
TRATE   .EQU    250             ;TIMER RATE FOR .1 DELAY
TMPUL   .EQU    80H             ;TIME MASK

        POP     HL
        LD      (RETADDR),HL
        LD      A,RIBT          
        OUT     (TPORT),A
; DELAY REQUIRED FOR OFF HOOK        
        LD      A,TRATE
        OUT     (RPORT),A
TIMES   IN      A,(RPORT)
        AND     TMPUL
        JP      Z,TIMES
TIMEE   IN      A,(RPORT)
        AND     TMPUL
        JP      NZ,TIMEE
; RETURN
        LD      HL,(RETADDR)
        JP      (HL)
        .END


========================================================================================
DOCUMENT :usus Folder:VOL06:ringing.a.text
========================================================================================

        .FUNC   RINGING,0
        .PRIVATE RETADDR
STAT    .EQU    0C2H
RING    .EQU    2H
        POP     HL
        LD      (RETADDR),HL
        POP     HL              ;CORRECT STACK
        POP     HL
        LD      HL,0            ;FALSE
        IN      A,(STAT)        ;READ STATUS
        AND     RING            ;CHECK FOR RINGING
        JP      NZ,DONE          
        LD      HL,1            ;TRUE 
DONE    PUSH    HL
        LD      HL,(RETADDR)
        JP      (HL)
        .END


========================================================================================
DOCUMENT :usus Folder:VOL06:sh.a.text
========================================================================================

        .PROC   SH,0 
        .PRIVATE RETADDR
        
TPORT   .EQU    0C0H            ;UART CONTROL PORT
RPORT   .EQU    TPORT+2         ;RATE PORT
SHBT    .EQU    01H             ;SH (MODEM WILL BE IN ORGINATE MODE)
TRATE   .EQU    250             ;TIMER RATE FOR .1 DELAY
TMPUL   .EQU    80H             ;TIME MASK

        POP     HL
        LD      (RETADDR),HL
        LD      A,SHBT          
        OUT     (TPORT),A
; DELAY REQUIRED FOR OFF HOOK        
        LD      A,TRATE
        OUT     (RPORT),A
TIMES   IN      A,(RPORT)
        AND     TMPUL
        JP      Z,TIMES
TIMEE   IN      A,(RPORT)
        AND     TMPUL
        JP      NZ,TIMEE
; RETURN
        LD      HL,(RETADDR)
        JP      (HL)
        .END


========================================================================================
DOCUMENT :usus Folder:VOL06:sysname.text
========================================================================================

37.17N121.52W408-267-4913/URNAME


========================================================================================
DOCUMENT :usus Folder:VOL07:catalog.7.text
========================================================================================

                                VOLUME 7 CATALOG
                             USUS SOFTWARE LIBRARY
                             
         Macro precompiler and several Pascal source cross-referencers.
   
   Filename     Blocks                          Description
   
FASTREAD.TEXT      8      Dan Dorrough's unit (used in MAP) that speeds up
                           Readln for strings by a factor of about 10.

MAP.TEXT          38      The precompiler from PUG News #17 that allows Pascal
MAP-A.TEXT        42       macros, fancy constant expressions, nested INCLUDE
MAP-B.TEXT        32       files, conditional compilation, and more, converted
                           by Dan Dorrough of PCD Systems.
MAP.DOC.TEXT      18      Documentation from PUG News.

PRXREF.TEXT       30      David Lewis' superb Pascal cross-referencer and source
PRXREF.TBL.TEXT   34       lister with several nice features:  follows INCLUDE
PRXREF.OPT.TEXT   24       files, adds line numbers that match those of the UCSD
PRXREF.INI.TEXT   24       compiler, and marks procedures/functions in the xref
PRXREF.UTL.TEXT   28       list.  Request:  someone please add the ability to
PRXREF.PFI.TEXT   38       pull in a UNIT interface declaration, with line 
                           numbers matching the compiler's weird system.
KEYHIT.TEXT        4      Assembly language keyboard poller (from USUS)
PRX.DOC.TEXT      68      Clear and thorough (!) documentation for PRXREF.

PROC.REF1.TEXT    44      Procedure/function cross-referencer from PUG News #17.
                           It died when I tried it on a large program with many
                           cross-references, but works fine with smaller
                           sources.  Use is obvious.  Help me find the bug!
PROC.REF2.TEXT    22      Pat Horton's own procedure cross-referencer.

NOTE:  USUS Library material may be used only in accordance with policy outlined
elsewhere.  In particular, these programs may not be given to nonmembers of 
USUS, nor may commercial use be made of them, without the written permission of
the authors.

Apple and other versions are the same as noted above.  Keep an eye on the USUS
newsletter for corrections and updates.



========================================================================================
DOCUMENT :usus Folder:VOL07:fastread.text
========================================================================================


{ FASTREAD - fast text file string read for UCSD pascal. }
{            dhd - PCD Systems, Inc.                     }

unit fastread;
  interface

{ file control block }
  
const
  bufsiz = 1024;
  linemax = 255;

type
  lineindex =   0..linemax;
  longstring =  string[linemax];
  ffile =       file;
  fcb = 
    record
      inlfn:    string[30];     { input file name }
      line:     longstring;     { current text line }
      bpos:     integer;        { buffer position }
      endfile:  boolean;        { true when end of file }
      buf:      packed array[0..bufsiz] of char;
      blknr:    integer;
    end;
  
  procedure getstring(var phyle: fcb; var infile: ffile; var s: longstring);
  procedure openfile(var phyle: fcb; var infile: ffile; var lfn: string);
    
implementation
  const
    cr = 13;
  
  procedure openfile{var phyle: fcb; var infile: ffile; var lfn: string};
  begin { openfile }
    with phyle do
      begin
        reset(infile, lfn);
        inlfn := lfn;
        line := '';
        bpos := bufsiz + 1;
        endfile := false;
        blknr := 2;
      end;
  end;  { openfile }
  
  procedure getstring{var phyle: fcb; var infile: ffile; var s: longstring};
    const
      dle = 16;
    var bcnt, chg: integer;
  begin { getstring } {$R- disable string range checks }
    with phyle do
      repeat
        if bpos >= bufsiz then { time for next buffer }
          begin bcnt := blockread(infile, buf[0], 2, blknr);
            bpos := 0; blknr := blknr + bcnt;
            if bcnt < 2 then { eof }
              begin endfile := true; EXIT(getstring) end;
          end;
        chg := scan(bufsiz-bpos, =chr(cr), buf[bpos]);
        if (bpos + chg) < bufsiz then { found a carriage return }
          begin moveleft(buf[bpos], S[1], chg);    { copy string except CR }
            S[0] := chr(chg); bpos := bpos + chg + 1;
          end
        else
          begin chg := scan(bufsiz-bpos, =chr(0), buf[bpos]); { look for null }
            if (bpos + chg) < bufsiz then
              begin moveleft(buf[bpos], S[1], chg-1); 
                S[0] := chr(chg); bpos := bufsiz;
              end;
          end;
      until chg > 0;
    if length(s) > 2 then
      if s[1] = chr(dle) then { insert leading blanks }
        begin chg := ord(s[2])-32;
          if chg > 2 then
            moveright(s[3], s[chg+1], length(s)-2)
          else
            moveleft (s[3], s[chg+1], length(s)-2);
          fillchar(s[1], chg, ' ');
          s[0] := chr(length(s)+chg-2);
        end;
  end;  { getstring } {$R+}
  
end. { of unit }
  

========================================================================================
DOCUMENT :usus Folder:VOL07:keyhit.text
========================================================================================

;  THIS FUNCTION CALLS THE CP/M CONSOLE READY ENTRY POINT AND RETURNS
;  A BOOLEAN VALUE (TRUE OR FALSE). CODE WILL OPERATE ON EITHER 8080 OR Z80
;

        .FUNC   KEYHIT          ;TESTS CONSOLE CHAR READY AND RETURNS T ! F
        POP     DE              ;RETURN ADDR
        POP     HL
        POP     HL              ;ZEROS
        LD      L,06H           ;CP/M CONSOLE READY ENTRY POINT
        CALL    BIOS
        LD      L,A
        PUSH    HL              ;BOOLEAN RESULT TO STACK
        EX      DE,HL           ;RETURN ADDR TO HL
HERE:   JP      (HL)            ;EXIT
BIOS:   LD      A,(0002H)       ;PAGE NO IN LOCATION 02H
        LD      H,A
        JP      (HL)
        .END



========================================================================================
DOCUMENT :usus Folder:VOL07:map-a.text
========================================================================================


{ MAP-A }

(*
PROCEDURE DEBUG(N: INTEGER);
  VAR INCH: CHAR; CHT: PACKED ARRAY[0..0] OF CHAR;
BEGIN { DEBUG }
  IF DEBUGON THEN
    IF N IN DEBUGSET THEN
      BEGIN WRITELN('*** ', N, ', CH=', CH, ', ORD(CH)=', ORD(CH),
          ', NEXT=', NEXT, ', LAST=', LAST, ', LEXTYP=', 
          ORD(LEXTYP), ', LEXLEN=', LEXLEN);
        WRITELN('LEXSTR=', LEXSTR:LEXLEN);
        REPEAT
          UNITREAD(2, CHT[0], 1); INCH := CHT[0];
          IF INCH = 'X' THEN
            DEBUGON := FALSE
          ELSE IF INCH = 'Q' THEN
            EXIT(MAP)
          ELSE IF INCH = 'R' THEN
            BEGIN WRITE('REMOVE WHICH BREAKPOINT: '); READLN(N);
              DEBUGSET := DEBUGSET - [N]
            END
          ELSE IF INCH = 'L' THEN
            WRITELN(INLINE:LAST)
          ELSE IF INCH = 'B' THEN { set breakpoint }
            BEGIN WRITE('SET WHICH BREAKPOINT: '); READLN(N);
              DEBUGSET := DEBUGSET + [N]
            END
          ELSE IF INCH = 'T' THEN
            WITH CTAB[CTOP] DO
              BEGIN WRITE('CNAME: ', CNAME);
                CASE CTYP OF
                  TIN: WRITE(', INTEGER: ', CI);
                  TRE: WRITE(', REAL:    ', CR);
                  TCH: BEGIN 
                         WRITELN(', STRING : CFIRST=', CFIRST, ', CLEN=',CLEN);
                         FOR N := CFIRST TO CFIRST+CLEN-1 DO
                           WRITE(CSTR[N]);
                       END;
                  TBL: IF CB THEN
                         WRITE(', BOOLEAN: TRUE')
                       ELSE
                         WRITE(', BOOLEAN: FALSE');
                  TOT: WRITE(', TOT:     ', CO);
                END { CASE };
                WRITELN;
              END;
        UNTIL INCH = 'G';
      END;
END;  { DEBUG }
*)

procedure arith;
  var
    op  : lex;
begin { arith }
  term;
  if (lextyp in [lexor,lexadd,lexsub]) and (not typeis([terr])) then
    if ((lextyp = lexor) and typeis([tbl])) 
        or ((lextyp in [lexadd,lexsub]) and typeis([tin,tre])) then
      begin over(ctop, maxcons);
        while lextyp in [lexor,lexadd,lexsub] do
          begin ctop := ctop + 1; op := lextyp; getkey; term;
            if (op = lexor) and typeis([tbl]) then
              with ctab[ctop-1] do
                cb := cb or ctab[ctop].cb
            else
              if (op in [lexadd,lexsub]) and typeis([tin,tre]) then
                with ctab[ctop-1] do
                  if (ctyp = tin) and (ctab[ctop].ctyp = tin) then
                    case op of
                      lexadd: ci := ci + ctab[ctop].ci;
                      lexsub: ci := ci - ctab[ctop].ci
                    end
                  else
                    begin forcereal;
                      case op of
                        lexadd: cr := cr + ctab[ctop].cr;
                        lexsub: cr := cr - ctab[ctop].cr
                      end
                    end
              else
                if ctab[ctop].ctyp <> terr then 
                  experror('arith-  bad type');
            ctop := ctop - 1;
          end
      end
end;  { arith }

procedure ckformal{name: alfa; var found: boolean};
  var
    a   : aptr;
begin { ckformal }
  found := false;
  if mtop > 0 then
    begin a := mstack[mtop].margs;
      while (a <> nil) and (not found) do
        begin
          with a^ do
            if aform = name then
              begin found := true; pushback; mtop := mtop + 1;
                with mstack[mtop] do
                  begin margs := nil; mnext := afirst; mlast := alast;
                    matop := atop;
                  end;
                getch;
              end;
          a := a^.anext;
        end;
      if found then gettok
    end
end;  { ckformal }

procedure ckmacro{name: alfa; var found: boolean};
  var
    d   : drng; { index to defined macros }
begin { ckmacro }
  d := dtop; defs[0].dname := name;
  while defs[d].dname <> name do d := d - 1;
  if d > 0 then
    begin found := true;
      if d <= nsysmac then dosysmac(d)
      else
        begin over(mtop, maxcalls);
          with mstack[mtop+1], defs[d] do
            begin margs := nil; mnext := dfirst; mlast := dlast;
              matop := atop; while ch = blank do getch;
              if ch = lparen then
                begin getch; getactuals(dargs, margs);
                  if ch <> rparen then
                    error('ckmacro-  right paren expected');
                end
              else error('ckmacro-  left paren expected')
            end;
          mtop := mtop + 1; getch;
        end;
      gettok;
    end;
end;  { ckmacro }

procedure closefile;
begin { close }
  close(infile);
  ftop := ftop - 1;
  if ftop >= 0 then
    with fstack[ftop] do
      openfile(ffcb, infile, ffcb.inlfn);
end;  { close }

procedure convrt;
  var
    i   : integer;
    c   : char;
    sign: boolean;
    xxx : packed array[1..5] of char;
    temp: string[36];
begin { convrt }
  with ctab[ctop] do
    case ctyp of
      tin:
        begin str(ci, temp); lexlen := length(temp);
          moveleft(temp[1], lexstr[1], lexlen);
          lextyp := lexint; 
        end;
      terr:;
      tot:
        begin moveleft(co[1], lexstr[1], alfaleng); lextyp := lexalpha;
          while lexstr[lexlen] = blank do lexlen := lexlen - 1;
        end;
      tch:
        begin lextyp := lexst; lexstr[1] := quote;
          moveleft(cstr[cfirst], lexstr[2], clen);
          lexlen := clen + 2; lexstr[lexlen] := quote
        end;
      tbl:
        begin lextyp := lexalpha;
          if cb then
            begin xxx := 'TRUE ';moveleft(xxx[1], lexstr[1], 4);lexlen := 4 end
          else 
            begin xxx := 'FALSE';moveleft(xxx[1], lexstr[1], 5);lexlen := 5 end
        end;
      tre:
        begin error('convrt-  real conversion not implemented');
        end;
    end;
end;  { convrt }

procedure convrti;
  var
    i   : integer;
    l   : lnrng;
begin { convrti }
  with ctab[ctop] do
    begin ctyp := tin; ci := 0;
      for l := 1 to lexlen do
        ci := 10 * ci + ord(lexstr[l])-ord(zero);
    end;
end;  { convrti }

procedure convrtr;
  var
    i   : lnrng;
begin { convrtr }
(* reset(dummy);
  for i := 1 to lexlen do write(dummy, lexstr[i]);
  writeln(dummy, blank);
  reset(dummy);
  with ctab[ctop] do
    begin ctyp := tre; read(dummy, cr) end; *)
  error('convrtr - not implemented');
end;  { convrtr }

procedure convrts;
  var
    l   : lnrng;
begin { convrts }
  with ctab[ctop] do
    begin ctyp := tch; clen := lexlen-2; cfirst := cstop + 1;
      over(cstop+clen,maxcstr);
      moveleft(lexstr[2], cstr[cfirst], clen);
      cstop := cstop + clen;
    end;
end;  { convrts }

procedure docodeif;
  var
    a   : dsrng;        { save area for dtop upon entry }
    ctr : integer;      { left parent count }
begin { docodeif }
  getkey; over(ctop,maxcons); ctop := ctop + 1; expression;
  ctop := ctop - 1; a := atop;
  if lextyp <> lexcomma then
    experror('docodeif-  comma expected')
  else
    with ctab[ctop+1] do
      if ctyp = tbl then
        if cb then
          begin over(mtop, maxcalls);
            with mstack[mtop+1] do
              begin margs := nil; mlast := atop - 1; getcdparm;
                mnext := atop; matop := a;
              end;
            mtop := mtop + 1; getch
          end
        else
          begin ctr := 1;
            while ctr > 0 do
              begin
                if ch = newline then
                  begin
                    if (mtop = 0) and (ftop = 0) and 
                        (fstack[0].ffcb.endfile) then
                      begin error('docodeif-  unexpected end of file');
                        exit(map)
                      end
                  end
                else
                  if ch = rparen then ctr := ctr - 1
                  else if ch = lparen then ctr := ctr + 1;
                getch
              end
          end
      else
        if ctyp <> terr then
          error('docodeif-  type error. boolean needed.')
end;  { docodeif }

procedure dodefine;
begin { dodefine }
  gettok;
  if lextyp <> lexalpha then
    error('dodefine-  name expected')
  else
    begin over(dtop, maxdefs); dtop := dtop + 1;
      with defs[dtop] do
        begin dname[1] := dollar; moveleft(lexstr[1], dname[2], alfaleng-1);
          dfirst := dstop + 1; dlast := dstop; gettok;
          if lextyp = lexlparen then
            begin gettok; getformals(dargs); gettok end
          else dargs := nil
        end;
      if lextyp <> lexcomma then
        begin error('dodefine-  missing comma'); dtop := dtop - 1 end
      else
        getbody;
    end;
end;  { dodefine }

procedure doinclude;
  var
    name: lfnstring;
begin { doinclude }
  {$R- disable string range checks }
  getbsu;
  if lextyp <> lexalpha then error('doinclude-  bad file name')
  else
    begin lexstr[0] := chr(lexlen);
      moveleft(lexstr[1], name[1], lexlen);
      getkey;
      if lextyp <> lexrparen then
        error('doinclude-  right paren expected');
      open(name)
    end;
end;  { doinclude }

procedure doindex;
  var
    i   : lnrng;
begin { doindex }
  over(ctop, maxcons);
  ctop := ctop + 1;
  getkey;
  if lextyp = lexrparen then
    with ctab[ctop] do
      begin ctyp := tin; ci := 0 end
  else expression;
  if lextyp <> lexrparen then error('doindex-  right paren expected')
  else
    begin pushback;
      with ctab[ctop] do
        if not (ctyp in [terr,tin]) then 
          error('doindex-  type error. integer needed')
        else if ctyp = tin then
          begin index := index + 1; ci := ci + index; convrt;
            over(mtop, maxcalls); mtop := mtop + 1;
            with mstack[mtop] do
              begin margs := nil; mnext := atop; mlast := atop - 1;
                matop := atop;
                for i := lexlen downto 1 do
                  begin mnext := mnext - 1;
                    defstr[mnext] := lexstr[i];
                  end;
                getch
              end
          end
    end;
  ctop := ctop - 1;
end;  { doindex }

procedure dooptions;
  var
    i   : integer;
begin { dooptions }
  gettok;
  while not (lextyp in [lexrparen,lexeof]) do
    begin
      if lextyp = lexalpha then
        if toupper(lexstr[1]) in ['R', 'P', 'N', 'L', 'E'] then
          case lexstr[1] of
            'P', 'R':
              begin
                while not (ch in ['0'..'9', ')']) do getch;
                i := 0;
                while ch in ['0'..'9'] do
                  begin i := 10 * i + ord(ch) - ord('0'); getch end;
                if (mincol <= i) and (i <= maxcol) then
                  case toupper(lexstr[1]) of
                    'P': prcopt := i;
                    'R': rcopt := i
                  end { case };
              end;
            'N':
              if lexlen >= 3 then
                if toupper(lexstr[3]) = 'L' then listopt := false
                else if toupper(lexstr[3]) = 'E' then expropt := false;
            'L': listopt := true;
            'E': expropt := true
          end
        else error('dooptions-  error in option list')
      else if lextyp <> lexcomma then error('dooptions-  comma expected');
      gettok
    end;
end;  { dooptions }

procedure dosysmac{d: drng}; { which macro }
begin { dosysmac }
  gettok;
  if lextyp <> lexlparen then error('dosysmac-  left paren expected')
  else
    case d of
      sysinc:    doinclude;
      syscodeif: docodeif;
      sysindex:  doindex;
      sysdefine: dodefine;
      sysoption: dooptions;
    end
end;  { dosysmac }

procedure error{err: errmsg};
  var i: lnrng;
begin { error }
  need(2);
  if listopt then
    writeln(space, errflag, space:next-1, arrow)
  else
    writeln(' AT LINE:', line:2, ' (pascal line:', pline:2, ')');
  writeln(space, errprefix, err); nerrors := nerrors + 1;
end;  { error }

procedure evalfns{f: fns};
begin { evalfns }
  case f of
    fabs: evalabs;
    fatn: evalatn;
    fchr: evalchr;
    fcos: evalcos;
    fexp: evalexp;
    flen: evallen;
    fln:  evalln;
    fodd: evalodd;
    ford: evalord;
    frou: evalrou;
    fsin: evalsin;
    fsqr: evalsqr;
    fstr: evalstr;
    ftru: evaltru
  end { case };
end;  { evalfns }

procedure evalabs;
begin { evalabs }
  with ctab[ctop] do
    if typeis([tre,tin]) then
      case ctyp of
        tin: ci := abs(ci);
        tre: cr := abs(cr);
      end
    else
      experror('evalabs-  type error. Number needed.');
end;  { evalabs }

procedure evalatn;
begin { evalatn }
  writeln('--UNIMP--17');
end;  { evalatn }

procedure evalchr;
  var
    i   : integer;
begin { evalchr }
  with ctab[ctop] do
    if ctyp = tin then
      begin i := ci; ctyp := tch; over(cstop, atop);
        cstop := cstop + 1; clen := 1; cstr[cstop] := chr(i);
        cfirst := cstop
      end
    else experror('evalchr- type error. Number needed.');
end;  { evalchr }

procedure evalcos;
begin { evalcos }
  writeln('--UNIMP--19');
end;  { evalcos }

procedure evalexp;
begin { evalexp }
  writeln('--UNIMP--20');
end;  { evalexp }

procedure evallen;
  var
    i   : integer;
begin { evallen }
  with ctab[ctop] do
    if ctyp = tch then
      begin i := clen; cstop := cfirst - 1; ctyp := tin; ci := i end
    else experror('evallen-  type error. String needed.');
end;  { evallen }

procedure evalln;
begin { evalln }
  writeln('--UNIMP--22');
end;  { evalln }

procedure evalodd;
  var
    i   : integer;
begin { evalodd }
 with ctab[ctop] do
   if ctyp = tin then
     begin i := ci; ctyp := tbl; cb := odd(i) end
   else
     error('evalodd-  type error. Number expected');
end;  { evalodd }

procedure evalord;
  var
    c   : char;
begin { evalord }
  with ctab[ctop] do
    if ctyp = tch then
      if clen = 1 then
        begin c := cstr[cfirst]; ctyp := tin; ci := ord(c) end
      else experror('evalord-  ord requires 1 char arg')
    else experror('evalord-  type error. Char needed');
end;  { evalord }

procedure evalrou;
  var
    r   : real;
begin { evalrou }
  with ctab[ctop] do
    if ctyp = tre then
      begin  r := cr; ctyp := tin; ci := round(r) end
    else
      error('evalrou-  type error. Real number expected');
end;  { evalrou }

procedure evalsin;
begin { evalsin }
  writeln('--UNIMP--26');
end;  { evalsin }

procedure evalsqr;
begin { evalsqr }
  with ctab[ctop] do
    if typeis([tre,tin]) then
      case ctyp of
        tin: ci := sqr(ci);
        tre: cr := sqr(cr);
      end { case }
    else experror('evalsqr-  type error. Number needed');
end;  { evalsqr }

procedure evalstr;
  var astring: string[10];
begin { evalstr }
  with ctab[ctop] do
    if ctyp <> tin then experror('evalstr-  type error. Integer needed')
    else
      begin ctyp := tch; str(ci, astring);
        clen := length(astring); cfirst := cstop + 1;
        over(cfirst+clen, atop);
        moveleft(astring[1], cstr[cfirst], clen);
        cstop := cstop + clen;
      end;
end;  { evalstr }

procedure evaltru;
  var
    r   : real;
begin { evaltru }
  with ctab[ctop] do
    if ctyp = tre then
      begin r := cr; ctyp := tin; ci := trunc(r) end
    else experror('evaltru- type error. Real needed');
end;  { evaltru }

procedure experror{err: errmsg};
begin { experror }
  error(err); ctab[ctop].ctyp := terr; flush;
end;  { experror }

procedure expression;
begin { expression }
  relate;
  if typeis([tch]) then
    begin over(ctop, maxcons); ctop := ctop + 1;
      while lextyp in [lexst,lexalpha] do
        begin relate;
          if typeis([tch]) then
            with ctab[ctop-1] do
              clen := clen + ctab[ctop].clen
          else if not typeis([terr]) then
            experror('expression-  invalid operand type')
        end;
      ctop := ctop - 1;
    end;
end;  { expression }

procedure factor;
  var
    op  : lex;
begin { factor }
  if lextyp in [lexnot,lexsub] then
    begin op := lextyp; getkey; factor;
      with ctab[ctop] do
        if typeis([tbl]) and (op = lexnot) then
          cb := not cb
        else
          if typeis([tin,tre]) and (op = lexsub) then
            case ctyp of
              tin: ci := -ci;
              tre: cr := -cr;
            end
          else
            if ctyp <> terr then
              begin ctyp := terr; error('factor-  type conflict') end
      end
    else
      if lextyp = lexlparen then
        begin getkey; expression;
          if not typeis([terr]) then
            if lextyp <> lexrparen then
              experror('factor-  right paren expected')
            else getkey
        end
      else
        variable
end;  { factor }

procedure findcon{name: alfa; var found: boolean};
  var
    c   : crng;
    i, f   : integer;
begin { findcon }
  c := cvalid; ctab[0].cname := name;
  while ctab[c].cname <> name do c := c - 1;
  if c > 0 then
    begin ctab[ctop] := ctab[c];
      with ctab[ctop] do
        if ctyp = tch then
          begin over(cstop+clen, maxcstr); cfirst := cstop + 1;
            f := ctab[c].cfirst;
            for i := 0 to clen-1 do
              begin cstop := cstop + 1;
                cstr[cstop] := cstr[f + i]
              end
          end;
      found := true
    end;
end;  { findcon }

procedure flookup{name: alfa; var fun: fns; var found: boolean};
  var
    f   : fnrng;
begin { flookup }
  funct[0].fnnme := name; f := maxfns;
  while funct[f].fnnme <> name do f := f - 1;
  found := f <> 0;
  if found then
    fun := funct[f].fntyp;
end;  { flookup }

procedure flush;
begin { flush }
  while not (lextyp in [lexeof,lexsemi]) do getkey;
end;  { flush }

procedure forcereal;
  var
    i   : integer;
begin { forcereal }
  with ctab[ctop] do
    if ctyp = tin then begin i := ci; ctyp := tre; cr := i end;
  with ctab[ctop-1] do
    if ctyp = tin then begin i := ci; ctyp := tre; cr := i end;
end;  { forcereal }

procedure getactuals{f: fptr; var act: aptr};
begin { getactuals }
  if f = nil then { if no formals then no actuals }
  else
    begin new(act);
      with act^, f^ do
        begin aform := fname; alast := atop - 1; getparm;
          afirst := atop; if ch = comma then getch;
          getactuals(fnext, anext)
        end;
    end;
end;  { getactuals }

procedure getbody;
  var
    ctr : integer;      { left paren counter }
begin { getbody }
  if ch = rparen then
    with defs[dtop] do
      begin getch; dlast := dstop; dfirst := dstop + 1 end
  else
    begin ctr := 1;
      with defs[dtop] do
        begin
          while ctr > 0 do
            begin over(dstop, atop); dstop := dstop + 1;
              defstr[dstop] := ch; dlast := dstop;
              if ch = rparen then ctr := ctr - 1
              else
                if ch = lparen then ctr := ctr + 1
                else
                  if (ch = newline) and (ftop = 0) and
                      fstack[0].ffcb.endfile then
                    begin error('getbody-  unexpected eof'); exit(map) end;
              getch
            end;
          defstr[dlast] := blank { replace trailing ")" }
        end
    end
end;  { getbody }

procedure getbsu;
  var
    name        : alfa;
    found       : boolean;
begin { getbsu }
  gettok;
  while lextyp = lexmac do
    begin moveleft(lexstr[1], name[1], alfaleng);
      ckformal(name, found);
      if not found then
        begin ckmacro(name, found);
          if not found then
            begin error('getbsu-  undefined macro call'); gettok end
        end;
    end;
end;  { getbsu }

procedure getcdparm;
  var
    ctr : integer;
    d   : dsrng;
begin { getcdparm }
  d := dstop; ctr := 0;
  while (ctr > 0) or (ch <> rparen) do
    begin over(d, atop); d := d + 1; defstr[d] := ch;
      if ch = lparen then ctr := ctr + 1
      else if ch = rparen then ctr := ctr - 1;
      getch
    end;
  if d > dstop then
    begin over(d, atop); d := d + 1; defstr[d] := blank;
      while d > dstop do
        begin atop := atop - 1; defstr[atop] := defstr[d]; d := d - 1;
        end
    end;
end;  { getcdparm }

procedure getch;
begin { getch }
  if mtop > 0 then
    while (mstack[mtop].mnext > mstack[mtop].mlast) and (mtop > 0) do
      begin atop := mstack[mtop].matop; mtop := mtop - 1 end;
  if mtop > 0 then
    with mstack[mtop] do
      begin ch := defstr[mnext]; mnext := mnext + 1 end
  else
    begin
      if next > last then getline;
      ch := inline[next]; next := next + 1;
    end;
end;  { getch }

procedure getformals{var f: fptr};
begin { getformals }
  if lextyp <> lexalpha then f := nil
  else
    begin new(f); 
      with f^ do
        begin fname[1] := dollar; 
          moveleft(lexstr[1], fname[2], alfaleng-1);
          gettok;
          if lextyp = lexcomma then
            begin gettok; getformals(fnext) end
          else fnext := nil
        end;
    end
end;  { getformals }

procedure getkey;
  var
        name    : alfa; { name of constant }
        k       : krng; { pointer to keywords }
begin { getkey }
  getbsu;
  if lextyp = lexalpha then
    begin moveleft(lexstr[1], name[1], alfaleng);
      keywd[0].kname := name; k := maxkeys;
      while keywd[k].kname <> name do k := k - 1;
      if k > 0 then lextyp := keywd[k].klex
    end;
end;  { getkey }

procedure getline;
  var
    i           : integer;
    mode        : (skipping,nonblank,endline,endfile);
begin { getline }
  while fstack[ftop].ffcb.endfile and (ftop > 0) do closefile;
  {$R- disable string range checks }
  if fstack[ftop].ffcb.endfile then
    begin next := 1; last := 0; inline[next] := newline; 
      inline[0] := chr(next)
    end
  else
    with fstack[ftop] do
      begin if listopt then
          begin
            writeln('UNIMP');
          end
        else
          repeat
            if not ffcb.endfile then
              begin getstring(ffcb, infile, inline);
                if not onscreen then
                  begin
                    if (line mod 50) = 0 then
                      begin writeln; write('<', line:4, '> ') end;
                    write('.');
                  end;
                line := line + 1; fline := fline + 1;
                next := 1; insert(blank, inline, length(inline)+1);
                last := length(inline);
                mode := skipping;
                repeat
                  if next > last then
                    mode := endline
                  else if inline[next] <> blank then
                    mode := nonblank
                  else next := next + 1;
                until mode <> skipping;
              end
            else
              begin next := 1; last := 0; inline[next] := newline; 
                inline[0] := chr(next); mode := endfile;
              end;
          until mode <> endline;
        inline[last+1] := newline; {$R+}
      end;
end;  { getline }

procedure getparm;
  var
    ctr : integer;
    d   : dsrng;
begin { getparm }
  d := dstop; ctr := 0;
  while (ctr > 0) or not (ch in [comma,rparen]) do
    begin over(d, atop); d := d + 1; defstr[d] := ch;
      if ch = lparen then ctr := ctr + 1
      else if ch = rparen then ctr := ctr - 1;
      getch;
    end;
  if d > dstop then
    begin over(d, atop); d := d + 1; defstr[d] := blank;
      while d > dstop do
        begin { move parm to right }
          atop := atop - 1; defstr[atop] := defstr[d]; d := d - 1
        end;
    end;
end;  { getparm }


========================================================================================
DOCUMENT :usus Folder:VOL07:map-b.text
========================================================================================


{ MAP-B }

procedure gettok;

  procedure readname;
  begin { readname }
    getch; ch := toupper(ch); lextyp := lexalpha; 
    fillchar(lexstr[2], alfaleng, space);
    while ch in ['A'..'Z', '0'..'9'] do
      begin putc(ch); getch; ch := toupper(ch) end;
    if lexlen > alfaleng then lexlen := alfaleng;
  end;  { readname }
  
  procedure readnumber;
  begin { readnumber }
    getch; lextyp := lexint;
    while ch in ['0'..'9'] do
      begin putc(ch); getch end;
    if ch = period then
      begin getch;
        if ch = period then pushback
        else
          begin lextyp := lexreal; putc(period);
            while ch in ['0'..'9'] do
              begin putc(ch); getch end
          end
      end;
    ch := toupper(ch);
    if ch = lettere then
      begin lextyp := lexreal; putc(ch); getch;
        if ch in [plus,minus] then
          begin putc(ch); getch end;
        while ch in ['0'..'9'] do
          begin putc(ch); getch end;
      end;
  end;  { readnumber }
  
  procedure readc1;
    { handle comment }
  begin { readc1 }
    getch;
    if ch = dollar then
      begin lexlen := 0; putc('('); putc('*'); putc('$');
        repeat
          repeat
            getch; putc(ch);
          until ch = star;
          getch; putc(ch);
        until ch = rparen;
        getch;
      end
    else
      begin lexlen := 0;
        repeat
          while ch <> star do getch;
          getch;
        until ch = rparen;
        getch
      end
  end;  { readc1 }
  
  procedure readc2;
    { handle comment }
  begin { readc2 }
    getch;
    if ch = dollar then
      begin lexlen := 0; putc('{'); putc(dollar);
        repeat
          getch; putc(ch);
        until ch = '}';
        getch;
      end
    else
      begin lexlen := 0;
        repeat
          getch;
        until ch = '}';
        getch;
      end;
  end;  { readc2 }
  
  procedure readmacro;
  begin { readmacro }
    getch; ch := toupper(ch);
    if not (ch in ['A'..'Z']) then
      begin error('readmacro-  illegal macro name'); lexlen := 0 end
    else
      begin lextyp := lexmac; 
        fillchar(lexstr[lexlen+1], alfaleng-lexlen, space);
        while ch in ['A'..'Z', '0'..'9'] do
          begin putc(ch);
            getch; ch := toupper(ch);
          end;
        if lexlen > alfaleng then lexlen := alfaleng;
      end;
  end;  { readmacro }
  
  procedure readstring;
  begin { readstring }
    lexlen := 0;
    repeat
      over(lexlen, maxline); putc(ch);
      repeat
        getch;
        if ch = newline then
          begin error('readstring-  string exceeds source line'); pushback;
            ch := quote { supply missing quote }
          end;
        over(lexlen, maxline); putc(ch)
      until lexstr[lexlen] = quote;
      getch;
    until ch <> quote;
    lextyp := lexst;
  end;  { readstring }
  
  procedure readlop;
  begin { readlop }
    getch;
    if ch = equal then
      begin lexlen := 2; lexstr[2] := equal; lextyp := lexle; getch end
    else if ch = greater then
      begin lexlen := 2; lexstr[2] := greater; lextyp := lexne; getch end
    else lextyp := lexlt
  end;  { readlop }
  
  procedure readgop;
  begin { readgop }
    getch;
    if ch = equal then
      begin lexlen := 2; lexstr[2] := equal; lextyp := lexge; getch end
    else lextyp := lexgt
  end;  { readgop }
  
begin { gettok }
  lexlen := 0;
  while lexlen = 0 do
    begin
      while ch = blank do getch;
      ch := toupper(ch); lexlen := 1; lextyp := lexother;
      lexstr[1] := ch;
      if ch = newline then
        if (ftop = 0) and (fstack[ftop].ffcb.endfile) then
          lextyp := lexeof
        else begin getch; ch := toupper(ch); lexlen := 0 end
      else if ch in ['A'..'Z'] then
        readname
      else if ch in ['0'..'9'] then
        readnumber
      else
        case ch of
          '+': begin lextyp := lexadd; getch end;
          '-': begin lextyp := lexsub; getch end;
          '*': begin lextyp := lexmult; getch end;
          '/': begin lextyp := lexdvd; getch end;
          '(': begin getch;
                 if ch <> star then lextyp := lexlparen
                 else
                   readc1;
               end;
          '{': readc2;
          ')': begin lextyp := lexrparen; getch; end;
          '$': readmacro;
          '=': begin lextyp := lexeq; getch end;
          ',': begin lextyp := lexcommac; getch end;
          '.': begin getch;
                 if ch = period then
                   begin lexstr[2] := period; lexlen := 2; getch end;
               end;
          '''': readstring;
          ':': begin
                 getch;
                 if ch = equal then
                   begin putc('='); getch end
               end;
          '<': readlop;
          '>': readgop;
          ';': begin lextyp := lexsemi; getch end;
          '[', ']', '^', '_', '?': getch { all other characters }
       end;
   end;
end;  { gettok }

procedure need{L: pgrng};
begin { need }
  if (linectr + 1) > pagesize then
    begin linectr := 1; newpg end
  else linectr := linectr + l;
end;  { need }

procedure newpg;
begin { newpg }
end;  { newpg }

procedure open{name: lfnstring}; { file name to open }
  var
    f   : flrng;
begin { open }
  over(ftop, maxfiles);
  fstack[ftop+1].ffcb.inlfn := name;
  f := 0;
  while fstack[f].ffcb.inlfn <> name do f := f + 1;
  if f <= ftop then error('open- recursive includes ignored')
  else
    begin
      ftop := ftop + 1;
      with fstack[ftop] do
        begin
          openfile(ffcb, infile, name);
          fline := 0;
          last := 0;
          next := 1;
          inline := ' ';
          inline[next] := newline;
          mtop := 0;
          getch
        end
    end;
end;  { open }

procedure over{i: integer; maxval: integer};
begin { over }
  if i >= maxval then
    begin error('over-  table overflow'); exit(map) end;
end;  { over }

procedure parse{top: crng; tok: lex};
begin { parse }
  getkey;
  while not (lextyp in [lexeof,lexend,lexfwd]) do
    if lextyp in [lexrec,lexfun,lexproc,lexcon,lexmcon,lexbeg,lexcas] then
      case lextyp of
        lexbeg:
          begin
            puttok;
            if tok in [lexproc,lexfun] then
              begin tok := lexbeg; getkey; end
            else parse(ctop, lexbeg)
          end;
        lexcas:
          begin puttok;
            if tok = lexrec then getkey else parse(ctop, lexcas)
          end;
        lexcon:
          begin puttok; if expropt then parsecon else getkey end;
        lexfun:
          begin puttok; scanheader; parse(ctop, lexfun) end;
        lexmcon: parsemcon;
        lexproc:
          begin puttok; scanheader; parse(ctop, lexproc) end;
        lexrec: begin puttok; parse(ctop, lextyp) end;
      end { case }
    else begin puttok; getkey end;
    puttok;
    if (lextyp = lexeof) and (tok <> lexeof) then
      begin error('parse-  unexpected end of file'); exit(map) end
    else
      if (lextyp = lexend) and not (tok in [lexbeg,lexcas,lexrec]) then
        error('parse-  unmatched end')
      else
        if (lextyp = lexfwd) and not (tok in [lexproc,lexfun]) then
          error('parse- unmatched forward');
    if lextyp <> lexeof then getkey;
    ctop := top; cvalid := top
end;  { parse }

procedure parsecon;
  var 
    savtyp      : lex;
    savstr      : strng;
    savlen      : lnrng;
    svalid      : boolean;
    consnam     : alfa;
begin { parsecon }
  getkey;
  while lextyp = lexalpha do
    begin puttok; over(ctop,maxcons); ctop := ctop + 1;
      moveleft(lexstr[1], consnam[1], alfaleng);
      getkey;
      if lextyp <> lexeq then
        begin error('parsecon-  equal sign needed');
          ctab[ctop].ctyp := terr; flush; getkey;
        end
      else
        begin puttok; getkey; while ch = blank do getch;
          if (ch = semi) and (lextyp in [lexint,lexreal,lexother]) then
            begin savstr := lexstr; savlen := lexlen; savtyp := lextyp;
              svalid := true
            end
          else svalid := false;
          expression;
          if (lextyp <> lexsemi) and (not typeis([terr])) then
            begin experror('parsecon-  semi colon expected');
              ctab[ctop].ctyp := terr
            end;
          if ctab[ctop].ctyp <> terr then
            begin
              if svalid then
                begin lexstr := savstr; lextyp := savtyp;
                  lexlen := savlen
                end
              else convrt;
              puttok; lextyp := lexsemi; lexstr[1] := semi;
              lexlen := 1; puttok;
              ctab[ctop].cname := consnam;
              cvalid := ctop;
            end
          else
            begin lexstr[1] := zero; lexstr[2] := semi;
              lextyp := lexst; lexlen := 2; puttok;
            end
        end;
      if ctab[ctop].ctyp in [terr,tot] then ctop := ctop - 1;
      getkey
    end
end;  { parsecon }

procedure parsemcon;
  var
    consnam     : alfa;
begin { parsemcon }
  getkey;
  while lextyp = lexalpha do
    begin over(ctop, maxcons); ctop := ctop + 1;
      moveleft(lexstr[1], consnam, alfaleng);
      getkey;
      if lextyp <> lexeq then
        begin error('parsemcon-  equal sign needed');
          ctab[ctop].ctyp := terr; flush;
          getkey
        end
      else
        begin getkey; while ch = blank do getch;
          expression;
          if (lextyp <> lexsemi) and (not typeis([terr])) then
            begin error('parsemcon-  semi colon expected');
              ctab[ctop].ctyp := terr
            end;
          if ctab[ctop].ctyp <> terr then
            begin ctab[ctop].cname := consnam; cvalid := ctop end;
        end;
      if ctab[ctop].ctyp in [terr,tot] then ctop := ctop - 1;
      getkey
    end
end;  { parsemcon }

procedure pushback;
begin { pushback }
  if mtop > 0 then
    with mstack[mtop] do mnext := mnext - 1
  else next := next - 1
end;  { pushback }

procedure putc{ch: char};
begin { putc }
  lexlen := lexlen + 1; lexstr[lexlen] := ch
end;  { putc }

procedure puttok;
begin { puttok }
  if (lastlex in confl) and (lextyp in confl) then
    begin write(psource, blank); outpos := outpos + 1 end;
  if lextyp = lexeof then
    begin writeln(psource); outpos := 0 end
  else
    begin
      if (outpos+lexlen) > prcopt then
        begin pline := pline + 1; writeln(psource); outpos := 0;
          if lexlen > prcopt then
            begin error('puttok-  token too large'); lexlen := prcopt end
        end;
      write(psource, lexstr:lexlen);
      outpos := outpos + lexlen; lastlex := lextyp
    end;
end;  { puttok }

procedure relate;
  var
    op  : lex;
    i   : integer;
    r   : real;
    c1,
    c2  : csrng;
begin { relate }
  arith;
  while (lextyp in [lexlt..lexne]) and (not typeis([terr])) do
    begin over(ctop, maxcons); ctop := ctop + 1; op := lextyp;
      getkey; arith;
      if typesmatch then
        with ctab[ctop-1] do
          case ctyp of
            tin:
              begin i := ci; ctyp := tbl;
                case op of
                  lexlt: cb := i <  ctab[ctop].ci;
                  lexle: cb := i <= ctab[ctop].ci;
                  lexeq: cb := i =  ctab[ctop].ci;
                  lexge: cb := i >= ctab[ctop].ci;
                  lexgt: cb := i >  ctab[ctop].ci;
                  lexne: cb := i <> ctab[ctop].ci;
                end;
              end;
            tre:
              begin r := cr; ctyp := tbl;
                case op of
                  lexlt: cb := r <  ctab[ctop].cr;
                  lexle: cb := r <= ctab[ctop].cr;
                  lexeq: cb := r =  ctab[ctop].cr;
                  lexge: cb := r >= ctab[ctop].cr;
                  lexgt: cb := r >  ctab[ctop].cr;
                  lexne: cb := r <> ctab[ctop].cr;
                end;
              end;
            tbl:
              begin
                case op of
                  lexlt: cb := cb <  ctab[ctop].cb;
                  lexle: cb := cb <= ctab[ctop].cb;
                  lexeq: cb := cb =  ctab[ctop].cb;
                  lexge: cb := cb >= ctab[ctop].cb;
                  lexgt: cb := cb >  ctab[ctop].cb;
                  lexne: cb := cb <> ctab[ctop].cb;
                end;
              end;
            tot:
              begin experror('relate-  illegal type for rel. op');
                ctyp := terr
              end;
            tch:
              begin
                c1 := cfirst; c2 := ctab[ctop].cfirst; i := 1;
                while (i < clen) and (cstr[c1] = cstr[c2]) do
                  begin i := i + 1; c1 := c1 + 1; c2 := c2 + 1 end;
                cstop := cstop - clen - ctab[ctop].clen;
                ctyp := tbl;
                case op of
                  lexlt: cb := cstr[c1] <  cstr[c2];
                  lexle: cb := cstr[c1] <= cstr[c2];
                  lexeq: cb := cstr[c1] =  cstr[c2];
                  lexge: cb := cstr[c1] >= cstr[c2];
                  lexgt: cb := cstr[c1] >  cstr[c2];
                  lexne: cb := cstr[c1] <> cstr[c2];
                end;
              end;
          end
      else
        if ctab[ctop].ctyp <> terr then
          begin experror('relate-  type conflict in relation');
            ctab[ctop].ctyp := terr
          end;
      ctop := ctop - 1;
    end;
end;  { relate }

procedure scanheader;
  var
    ctr : integer;
begin { scanheader }
  getkey { get name }; puttok;
  getkey { get paren if parameters };
  if lextyp <> lexlparen then puttok
  else
    begin ctr := 1; puttok;
      repeat
        getkey; if lextyp = lexlparen then ctr := ctr + 1;
        if lextyp = lexrparen then ctr := ctr - 1; puttok;
      until ctr = 0;
    end;
end;  { scanheader }

procedure term;
 var
   op   : lex;
begin { term }
 factor;
 if (lextyp in [lexand..lexmod]) and (not typeis([terr])) then
   if (typeis([tbl]) and (lextyp = lexand)) or
       (typeis([tre]) and (lextyp in [lexmult..lexmax])) or
       (typeis([tin]) and (lextyp in [lexmult..lexmod])) then
     while lextyp in [lexand..lexmod] do
       begin ctop := ctop + 1; op := lextyp; getkey; factor;
         with ctab[ctop-1] do
           if (op = lexand) and (ctyp = tbl) then
             cb := cb and ctab[ctop].cb
           else
             if (op in [lexdiv..lexmod]) and (ctyp = tin) then
               case op of
                 lexdiv: ci := ci div ctab[ctop].ci;
                 lexmod: ci := ci mod ctab[ctop].ci;
               end { case }
             else
               if (op in [lexmult..lexmax]) and typeis([tin,tre]) then
                 begin
                   if (ctyp = tin) and (typeis([tin])) and (op <> lexdvd) then
                     case op of
                       lexmult: ci := ci * ctab[ctop].ci;
                       lexmin:
                         if ctab[ctop].ci < ci then
                           ci := ctab[ctop].ci;
                       lexmax:
                         if ctab[ctop].ci > ci then
                           ci := ctab[ctop].ci;
                     end { case }
                   else
                     begin forcereal;
                       case op of
                         lexmult: cr := cr * ctab[ctop].cr;
                         lexdvd:  cr := cr / ctab[ctop].cr;
                         lexmin:
                           if ctab[ctop].cr < cr then
                             cr := ctab[ctop].cr;
                         lexmax:
                           if ctab[ctop].cr > cr then
                             cr := ctab[ctop].cr;
                       end { case }
                     end
                 end
               else
                 if ctab[ctop].ctyp <> terr then
                   experror('term-  invalid operand type');
          ctop := ctop - 1;
        end
    else error('term-  invalid operand type');
end;  { term }

procedure terminate;
begin { terminate }
  close(psource, lock);
end;  { terminate }

function toupper{ch: char): char};
begin { toupper }
  if (ch >= 'a') then
    if (ch <= 'z') then
      toupper := chr(ord(ch)-ord('a')+ord('A'))
    else toupper := ch
  else toupper := ch;
end;  { toupper }

function typeis{c: cset): boolean};
begin { typeis }
 typeis := ctab[ctop].ctyp in c
end;  { typeis }

function typesmatch{: boolean};
begin { typesmatch }
  typesmatch := false;
  with ctab[ctop-1] do
    if ctyp = ctab[ctop].ctyp then
      if ctyp <> tch then typesmatch := true
      else if clen = ctab[ctop].clen then typesmatch := true
end;  { typesmatch }

procedure variable;
  var
    name        : alfa;
    found       : boolean;
    fun         : fns;
begin { variable }
  if not (lextyp in [lexalpha,lexint,lexreal,lexst]) then
    begin experror('variable-  value or name expected');
      ctab[ctop].ctyp := terr
    end
  else
    case lextyp of
      lexint:   begin convrti; getkey end;
      lexreal:  begin convrtr; getkey end;
      lexst:    begin convrts; getkey end;
      lexalpha:
                begin moveleft(lexstr[1], name[1], alfaleng); getkey;
                  found := false;
                  if lextyp <> lexlparen then
                    begin findcon(name,found);
                      if not found then
                        with ctab[ctop] do
                          begin ctyp := tot; co := name end
                     end
                   else
                     begin flookup(name, fun, found); { function call }
                       if not found then
                         experror('variable-  unknown function. 0 used')
                       else
                         begin getkey; expression;
                           if lextyp <> lexrparen then
                             experror('variable-  right paren expected')
                           else
                             begin getkey; evalfns(fun) end
                         end
                     end
                end
    end { case };
end;  { variable }



========================================================================================
DOCUMENT :usus Folder:VOL07:map.doc.text
========================================================================================

          DOCUMENTATION FOR MAP - from the Pascal User Group News #17
          
     MAP provides four basic functions to Pascal: constant expression evalu-
ation, source file inclusion, parameterized macro substitution, and condition-
al compilation.  This section discusses each of these facilities.

     MAP evaluates constant expressions (expressions where operands are 
constants or previously defined symbolic constants) on the right-hand side of 
CONST declarations.  Expressions may contain the following operators (listed 
in descending precedence):

     function:          name (arguments)
     negating:          NOT -
     multiplying:       AND * / DIV MOD MIN MAX
     adding:            OR +
     relating:          < <= = <> >= >
     concatenating:     (one or more blanks)

     All standard operators have the same meaning as in Pascal, and strong 
typing is observed.  The operators MIN and MAX require operators of type 
INTEGER or REAL and return the smaller and larger of their operands,
respectively.  Concatenation requires operands of type PACKED ARRAY OF CHAR, 
and returns a PACKED ARRAY OF CHAR which is their concatenation (the type CHAR 
is assumed to be a packed array of one character for concatenation).

     MAP recognizes the standard Pascal functions ABS, SQR, CHR, ORD, ROUND, 
TRUNC, as well as two nonstandard functions, LENGTH and STRINGOF.  LENGTH 
requires an argument of type PACKED ARRAY OF CHAR or CHAR, and returns the 
number of characters in it.  STRINGOF requires an integer argument, and 
returns a PACKED ARRAY OF CHAR consisting of its decimal representation.

     Operands in CONST expressions may be constants or previously defined 
CONST names.  Of course, Pascal scope rules apply to defined names.  MAP also 
provides several predefined symbolic constants which may be used in CONST 
expressions.  Two especially useful predefined names, TIME and DATE, give the 
time and date on which the compilation was performed.  These predefined 
constants help when writing production programs that must be time and date 
stamped.  For example, in a production program a heading is usually printed 
whenever the program runs:

     'PROGRAM XYZ COMPILED ON mm/dd/yy AT hh:mm:ss'

     Such a heading may provide the only link between an object version of a 
program and its source.  Unfortunately, a programmer may fail to update the 
heading when making changes to the program.  Using the predefined constants in 
MAP to create the heading relieves the programmer of the updating task and 
guarantees the heading will always be accurate:

     CONST
        READING = 'PROGRAM XYZ COMPILED ON' DATE 'AT' TIME;

     In addition to constant expression evaluation, MAP supplies a macro 
substitution facility.  A macro, which may have zero or more formal 
parameters, may be defined anywhere in the source program using the syntax:

     $DEFINE(name(formals),value)

where 'name' is a valid Pascal identifier, 'formals' is a list of identifiers 
separated by commas, and 'value' is a sequence of Pascal tokens which is well 
balanced with respect to parentheses.  Once a macro has been defined, it can 
be called by coding:

     $name(actuals)

where 'name' is the name of the macro, and 'actuals' is a list of actual 
parameters separated by commas.  Each actual parameter must be a sequence of 
Pascal tokens which is well balanced with respect to parentheses.

     In addition to the user-defined macros, MAP recognizes several system 
macros.  Definition of a new macro, as shown above, requires the use of one 
such system macro, DEFINE.  Another system macro, INCLUDE, provides for source 
file inclusion.  When MAP encounters a call:

     $INCLUDE(file name)

it opens the named file, and continues processing, reading input from the new 
file.  Upon encountering an end-of-file condition, MAP closes the included 
file, and resumes processing the original file.  Includes may be nested, but 
they may not be recursive (even though there is a way to prevent infinite 
recursion).

     One may think of 'include' as a macro whose body is an entire file.  This 
view, however, does not reflect the fact that the user also expects included 
text to be listed like standard input rather than like the body of a macro.  
While macro expansions are not usually displayed in the source listing, 
included files are.  Therefore, INCLUDE has a special status among macros.

     One other system macro, CODEIF, is provided to support the conditional 
compilation of code.  The syntax of CODEIF is:

     $CODEIF(constant Boolean expression,code)

where the 'constant Boolean expression' follows the rules for CONST
expressions outlined previously, and 'code' represents a sequence of Pascal 
tokens which is well balanced with respect to parentheses.  If the Boolean 
expression evaluates to 'true', the code is compiled; if the expression 
evaluates to 'false', the code is skipped.


                                   REFERENCE

D. Comer, 'A Pascal Macro Preprocessor for Large Program Development', 
Software Practice and Experience, Vol. 9, 203-209, 1979.



========================================================================================
DOCUMENT :usus Folder:VOL07:map.text
========================================================================================

{
{  MAP - Pascal macro preprocessor
{        written by Doug Comer, Purdue University Computing Center
{
{       from Pascal News #17
{
{  Copyright (C) 1978. Permission to copy, modify and distribute,
{                       but not for profit, is hereby granted,
{                       provided that this not is included.
{       Jul 1980 -      Modifications for UCSD Pascal - dhd     }

{$S+ permit compiler to swap }
program map;
  uses fastread;

  const
    alfaleng    = 10;
    arrow       = '^';
    blank       = ' ';
    break       = '      ';
    comma       = ',';
    defexpr     = true; { default for expression evaluation }
    deflist     = false;{ default for listing }
    defprc      = 71;   { default right column for Pascal }
    defrc       = 140;  { default right column for map input }
    dollar      = '$';
    double      = '0';  { double space carriage control }
    equal       = '=';
    errprefix   = '---> error ';
    errlen      = 40;   { length of error messages }
    errflag     = ' ';
    greater     = '>';
    letterb     = 'B';
    lettere     = 'E';
    lparen      = '(';
    maxcalls    = 15;   { max macro call depth }
    maxcons     = 200;  { max active const defns }
    maxcol      = 120;  { max right col for input/output }
    maxcstr     = 1000; { max const string area }
    maxdefs     = 100;  { max defined macros }
    maxdefstr   = 4000; { max macro string area }
    maxfiles    = 1;    { max included file depth }
    maxfns      = 14;   { max recognized functions }
    maxkeys     = 21;   { max recognized language keywords }
    maxline     = 140;  { max characters / input line }
    mincol      = 70;   { min right column for input/output }
    minus       = '-';
    ndefconst   = 9;    { number of pre-defined constants }
    
    nsysmac     = 5;    { number of system macros }
    pagesize    = 55;   { lines/page not counting heading }
    period      = '.';
    plus        = '+';
    quote       = '''';
    rparen      = ')';
    semi        = ';';
    space       = ' ';
    star        = '*';
    sysinc      = 1;    { codes for system macros }
    syscodeif   = 2;
    sysindex    = 3;
    sysdefine   = 4;
    sysoption   = 5;
(*
    title       = ' M A P  (vers 2.0p of 4/30/79)';
    title1a     = '                    run on ';
    title1b     = ' at ';
    title2      = '        include    pascal';
    title3      = ' line  file     line    line         source';
    title4      = ' ----  -------------   ------  ------------';
    title5      = '------------------------------------------------';
    title6      = '-----'; 
*)
    zero        = '0';
    
  type
    alfa        = packed array[1..alfaleng] of char;
    crng        = 0..maxcons;   { constant expression stack }
    csrng       = 0..maxcstr;   { constant expression string area }
    drng        = 0..maxdefs;   { macro defination stack }
    dsrng       = 0..maxdefstr; { macro def string area }
    flrng       = 0..maxfiles;  { included file stack }
    fnrng       = 0..maxfns;    { built-in functions }
    krng        = 0..maxkeys;   { keywords }
    lnrng       = 0..maxline;   { input line }
    mrng        = 0..maxcalls;  { macro call stack }
    pgrng       = 0..pagesize;  { listing page }
    
    msg         = packed array[1..140] of char;

    fptr        = ^formal;
    
    formal      = record
                    fname: alfa;        { name of formal parameter }
                    fnext: fptr
                  end;
    
    fns         = (fabs,fatn,fchr,fcos,fexp,    { built-in functions }
                   flen,fln,fodd,ford,frou,fsin,fsqr,fstr,ftru);
                   
    lex         = (lexadd,lexsub,       { order dependent }
                  lexand,lexmult,lexdvd,lexmin,lexmax,lexdiv,lexmod,
                  lexalpha,lexint,lexreal,lexst,lexmac,
                  lexbeg,lexcas,lexend,lexrec,lexfun,lexproc,lexcon,
                  lexmcon,
                  lextpe,lexvar,lexfwd,
                  lexor,lexnot,
                  lexlt,lexle,lexeq,lexgt,lexge,lexne,
                  lexsemi,lexother,
                  lexlparen,lexrparen,
                  lexcomma,lexeof);
                  
    aptr        = ^arg;
    
    arg         = record        { actual arg list }
                    aform: alfa;        { formal name }
                    afirst: dsrng;      { start of actual in dstr }
                    alast:  dsrng;
                    anext: aptr
                  end;
                  
    constyp     = (tbl,tch,terr,tin,tot,tre);   { type of const expr }
    
    cset        = set of constyp;
    
    strng       = packed array[1..maxline] of char;
    
    errmsg      = string[errlen];
    
    lfnstring   = string[30];
  
  var
    (*
    DEBUGON     : BOOLEAN;
    DEBUGSET    : SET OF 0..100; *)
    ftop        : -1..maxfiles;
    ctop,                       { current top of ctab and last const }
    cvalid      : crng;         { last non-temporary constant }
    mtop        : mrng;         { top of called macro stack }
    dtop        : drng;
    cstop       : csrng;
    newline     : char;         { newline character }
    dstop       : dsrng;        { top of definition string area }
    last,
    next        : lnrng;        { last char and next char in inline }
    ch          : char;         { next char from getch }
    line        : integer;      { last line number }
    pline       : integer;      { next pascal output line number }
    atop        : dsrng;        { actual arguments saved in top of defstr }
    linectr     : integer;      { lines so far on this page }
    nerrors     : integer;      { number of erros found }
    lexlen      : lnrng;        { number of chars in lexstr }
    lextyp      : lex;          { type of token in lexstr }
    index       : integer;      { for $index macro }
    onscreen    : boolean;      { if listing to screen }
    
    ctab        : array[crng] of        { constant table }
                    record
                      cname: alfa;
                      case ctyp: constyp of
                        tin: (ci: integer);
                        tre: (cr: real);
                        tch: (cfirst: csrng; clen: csrng);
                        tbl: (cb: boolean);
                        tot: (co: alfa)
                    end;
                      
  cstr          : packed array[csrng] of char; { string const storage }
  infile        : ffile; { input file }
  
  fstack        : array[flrng] of       { included file stack }
                    record
                      ffcb : fcb;       { file control block }
                      fline: integer
                    end;
                    
  keywd         : array[0..maxkeys] of { language keywords }
                    record
                      kname: alfa;      { keyword name }
                      klex:  lex
                    end;
                    
  mstack        : array[mrng] of        { macros calls }
                    record
                      margs: aptr;      { list of args }
                      mnext: dsrng;     { next char to read }
                      mlast: dsrng;     { last char in this macro }
                      matop: dsrng;     { actual top upon call }
                    end;
                    
  defs          : array[drng] of        { macro definitions }
                    record
                      dname: alfa;      { macro name }
                      dfirst: dsrng;    { first char in this macro }
                      dlast: dsrng;     { last char in this macro }
                      dargs: fptr       { list of formals }
                    end;
                    
  defstr        : array[dsrng] of char; { macro definition bodies }
  
  funct         : array[fnrng] of       { list of built in functions }
                    record
                      fnnme: alfa;
                      fntyp: fns
                    end;
                    
  blankalfa     : alfa;
  
  inline        : longstring;
  tme,                          { time of day from system }
  dte           : alfa;         { date from system }
  timein        : integer;      { clock value at start of run }
  tottme        : integer;      { total time used in ms }
  
  psource       : text;         { output file }
  (* 
  dummy         : text;         { dummy used for real number conversion }*)
  
  rcopt,
  prcopt        : lnrng;        { right column on input/output }
  listopt       : boolean;      { list on or off }
  expropt       : boolean;      { recognize expressions on or off }
  
  lastlex       : lex;          { last token type put by puttok }
  outpos        : lnrng;        { last column pos used by puttok }
  
  lexstr        : strng;        { lexical string }
  confl         : set of lex;   { set of tokens needing blank between }
  
{ MAP-FPROCS }

procedure arith;        forward;
procedure ckformal(name: alfa; var found: boolean);
                        forward;
procedure ckmacro(name: alfa; { macro name } var found: boolean);
                        forward;
procedure closefile;    forward;
procedure convrt;       forward;
procedure convrti;      forward;
procedure convrtr;      forward;
procedure convrts;      forward;
procedure docodeif;     forward;
procedure dodefine;     forward;
procedure doinclude;    forward;
procedure doindex;      forward;
procedure dooptions;    forward;
procedure dosysmac(d: drng); { which macro }
                        forward;
procedure error(err: errmsg);
                        forward;
procedure evalfns(f: fns);
                        forward;
procedure evalabs;      forward;
procedure evalatn;      forward;
procedure evalchr;      forward;
procedure evalcos;      forward;
procedure evalexp;      forward;
procedure evallen;      forward;
procedure evalln;       forward;
procedure evalodd;      forward;
procedure evalord;      forward;
procedure evalrou;      forward;
procedure evalsin;      forward;
procedure evalsqr;      forward;
procedure evalstr;      forward;
procedure evaltru;      forward;
procedure experror(err: errmsg);
                        forward;
procedure expression;   forward;
procedure factor;       forward;
procedure findcon(name: alfa; var found: boolean);
                        forward;
procedure flookup(name: alfa; var fun: fns; var found: boolean);
                        forward;
procedure flush;        forward;
procedure forcereal;    forward;
procedure getactuals(f: fptr; var act: aptr);
                        forward;
procedure getbody;      forward;
procedure getbsu;       forward;
procedure getcdparm;    forward;
procedure getch;        forward;
procedure getformals(var f: fptr);
                        forward;
procedure getkey;       forward;
procedure getline;      forward;
procedure getparm;      forward;
procedure gettok;       forward;
procedure need(L: pgrng);
                        forward;
procedure newpg;        forward;
procedure open(name: lfnstring); { file name to open }
                        forward;
procedure over(i: integer; maxval: integer);
                        forward;
procedure parse(top: crng; tok: lex);
                        forward;
procedure parsecon;     forward;
procedure parsemcon;    forward;
procedure pushback;     forward;
procedure putc(ch: char);
                        forward;
procedure puttok;       forward;
procedure relate;       forward;
procedure scanheader;   forward;
procedure term;         forward;
procedure terminate;    forward;
function toupper(ch: char): char;
                        forward;
function typeis(c: cset): boolean;
                        forward;
function typesmatch: boolean;
                        forward;
procedure variable;     forward;

segment procedure initialize;
  var 
    i           : integer;
    valid       : boolean;
    ilfn, olfn  : string[30];

  procedure timedate;
    const
      backspace = 8;
    var i, l: integer;
        xstr: packed array[1..16] of char;
        date, time: string[alfaleng];
  begin { timedate }
    xstr := 'MM/DD/YYHH:MM:SS';
    tme := '*TIME*    ';
    dte := '*DATE*    ';
    repeat
      write('Enter date in form MM/DD/YY'); 
      for i := 1 to 8 do write(chr(backspace));
      readln(date);
      l := length(date);
    until (l = 8) or (l = 0);
    if l > 0 then
      begin moveleft(date[1], xstr[1], 8); 
        moveleft(date[1], dte[1], 8) 
      end;
    repeat
      write('Enter time in form HH:MM:SS'); 
      for i := 1 to 8 do write(chr(backspace));
      readln(time);
      l := length(time);
    until (l = 8) or (l = 0);
    if l > 0 then
      begin moveleft(time[1], xstr[9], 8); 
        moveleft(time[1], tme[1], 8) 
      end;
    moveleft(xstr[1], cstr[1], 16);
    cstop := 16;
  end;  { timedate }

procedure initctab;
  begin { initctab }
    with ctab[1] do
      begin cname := 'MM        '; ctyp := tch; clen := 2; cfirst := 1 end;
    with ctab[2] do
      begin cname := 'DD        '; ctyp := tch; clen := 2; cfirst := 4 end;
    with ctab[3] do
      begin cname := 'YY        '; ctyp := tch; clen := 2; cfirst := 7 end;
    with ctab[4] do
      begin cname := 'TIME      '; ctyp := tch; clen := 8; cfirst := 9 end;
    with ctab[5] do
      begin cname := 'DATE      '; ctyp := tch; clen := 8; cfirst := 1 end;
    with ctab[6] do
      begin cname := 'TRUE      '; ctyp := tbl; cb := true end;
    with ctab[7] do
      begin cname := 'FALSE     '; ctyp := tbl; cb := false end;
    with ctab[8] do
      begin cname := 'MAXINT    '; ctyp := tre; cr := maxint end;
    with ctab[9] do
      begin cname := 'MININT    '; ctyp := tre; cr := -maxint end;
    ctop := ndefconst;
    cvalid := ndefconst;
  end;  { initctab }
  
  procedure initkeywd;
  begin { initkeywd }
    { keywords are in order of decreasing frequency of access }
    with keywd[16] do begin kname := 'AND       '; klex := lexand   end;
    with keywd[20] do begin kname := 'BEGIN     '; klex := lexbeg   end;
    with keywd[14] do begin kname := 'CASE      '; klex := lexcas   end;
    with keywd[10] do begin kname := 'CONST     '; klex := lexcon   end;
    with keywd[11] do begin kname := 'DIV       '; klex := lexdiv   end;
    with keywd[21] do begin kname := 'END       '; klex := lexend   end;
    with keywd[ 8] do begin kname := 'EXTERNAL  '; klex := lexfwd   end;
    with keywd[ 2] do begin kname := 'FORTRAN   '; klex := lexfwd   end;
    with keywd[15] do begin kname := 'FORWARD   '; klex := lexfwd   end;
    with keywd[ 9] do begin kname := 'FUNCTION  '; klex := lexfun   end;
    with keywd[ 4] do begin kname := 'MAX       '; klex := lexmax   end;
    with keywd[ 3] do begin kname := 'MCONST    '; klex := lexmcon  end;
    with keywd[ 5] do begin kname := 'MIN       '; klex := lexmin   end;
    with keywd[ 6] do begin kname := 'MOD       '; klex := lexmod   end;
    with keywd[17] do begin kname := 'NOT       '; klex := lexnot   end;
    with keywd[12] do begin kname := 'OR        '; klex := lexor    end;
    with keywd[19] do begin kname := 'PROCEDURE '; klex := lexproc  end;
    with keywd[13] do begin kname := 'RECORD    '; klex := lexrec   end;
    with keywd[ 1] do begin kname := 'RUN       '; klex := lexfwd   end;
    with keywd[ 7] do begin kname := 'TYPE      '; klex := lextpe   end;
    with keywd[18] do begin kname := 'VAR       '; klex := lexvar   end;
    mtop := 0; dstop := 0; 
  end;  { initkeywd }
  
  procedure initdefs;
  begin { initdefs }
    defs[sysinc   ].dname := '$INCLUDE  ';
    defs[sysdefine].dname := '$DEFINE   ';
    defs[sysindex ].dname := '$INDEX    ';
    defs[sysoption].dname := '$OPTIONS  ';
    defs[syscodeif].dname := '$CODEIF   ';
    dtop := nsysmac; atop := maxdefstr;
  end;  { initdefs }

  procedure initfuncts;
  begin { initfuncts }
    with funct[ 01] do begin fnnme :=  'ABS       '; fntyp :=   fabs   end;
    with funct[ 02] do begin fnnme :=  'ARCTAN    '; fntyp :=   fatn   end;
    with funct[ 03] do begin fnnme :=  'CHR       '; fntyp :=   fchr   end;
    with funct[ 04] do begin fnnme :=  'COS       '; fntyp :=   fcos   end;
    with funct[ 05] do begin fnnme :=  'EXP       '; fntyp :=   fexp   end;
    with funct[ 06] do begin fnnme :=  'LENGTH    '; fntyp :=   flen   end;
    with funct[ 07] do begin fnnme :=  'LN        '; fntyp :=   fln    end;
    with funct[ 08] do begin fnnme :=  'ODD       '; fntyp :=   fodd   end;
    with funct[ 09] do begin fnnme :=  'ORD       '; fntyp :=   ford   end;
    with funct[ 10] do begin fnnme :=  'ROUND     '; fntyp :=   frou   end;
    with funct[ 11] do begin fnnme :=  'SIN       '; fntyp :=   fsin   end;
    with funct[ 12] do begin fnnme :=  'SQR       '; fntyp :=   fsqr   end;
    with funct[ 13] do begin fnnme :=  'STRINGOF  '; fntyp :=   fstr   end;
    with funct[ 14] do begin fnnme :=  'TRUNC     '; fntyp :=   ftru   end;
  end;  { initfuncts }
  
begin { initialize }
  timedate;
  initctab;
  initkeywd;
  initdefs;
  initfuncts;
  line := 0;    { last line number for listing }
  pline := 1;   { next, not last, pascal line number }
  rcopt := defrc;
  prcopt := defprc;
  listopt := deflist;
  expropt := defexpr;   { parse const expressions }
  outpos := 0;          { last output position used }
  lastlex := lexeof;    { last token type output }
  nerrors := 0;
  index := 0;
  confl := [lexalpha,lexreal,lexint,lexand,lexor,lexnot,lexmin,
                lexmax,lexdiv,lexmod,lexbeg,lexcas,lexend,lexrec,lexfun,
                lexproc,lexcon,lextpe,lexvar];
  linectr := pagesize;  { force newpage on listing }
  newline := chr(10);
  blankalfa := '          ';
  ftop := -1; { no open files }
  lexlen := 0; ch := ' '; lextyp := lexeof;
  {$R- disable string range checks }
  inline[0] := chr(sizeof(inline)); fillchar(inline[1], sizeof(inline), space);
  {$R+}
(* DEBUGON := FALSE; *)
  repeat
    write('Input file name: '); readln(ilfn);
    if ilfn <> '' then
      begin
        for i := 1 to length(ilfn) do
          ilfn[i] := toupper(ilfn[i]);
        if pos('.TEXT', ilfn) <= 0 then
          ilfn := concat(ilfn, '.TEXT');
      end
    else
      ilfn := '*SYSTEM.WRK.TEXT';
    write('Output file name: '); readln(olfn);
    if olfn <> '' then
      begin
        for i := 1 to length(olfn) do
          olfn[i] := toupper(olfn[i]);
        onscreen := (olfn = '#1:') or (olfn = 'CONSOLE:');
        if not onscreen then
          begin
            if pos('.TEXT', olfn) <= 0 then
              olfn := concat(olfn, '.TEXT');
          end;
      end
    else
      olfn := '*SYSTEM.WRK.TEXT';
    valid := ilfn <> olfn;
    if not valid then
      writeln('Input file same as output file');
  until valid;
  open(ilfn);
  rewrite(psource, olfn);
  (*
  rewrite(dummy, 'dummy');
  DEBUGON := TRUE;
  DEBUGSET := [];
  REPEAT
    WRITE('SET WHICH BREAKPOINT: '); READLN(I);
    IF I > 0 THEN
      DEBUGSET := DEBUGSET + [I];
  UNTIL I <= 0; *)
end;  { initialize }

{$I MAP-A}
{$I MAP-B}
  
begin { map }
  initialize;
  parse(ctop, lexeof);
  terminate
end.  { map }


========================================================================================
DOCUMENT :usus Folder:VOL07:proc.ref1.text
========================================================================================

{
        program referencer
        Copyright (C) 1979
        A.H. Sale
        Southhamptom, England
        
        See Pascal News #17
        
        Permission is granted to copy this program, store it in 
        a computer system, and distribute it provided that this
        header comment is retained in all copies
}
{$S+ allow compiler to swap }
program refrencer;
const
  
  sigcharlimit = 10;
  setlimit = 09;
  uclcdisplacement = 32;
  linelimit = 200;
  linewidth = 80;
  indentation = 4;
  
  bufsiz = 1024;
  cr = 13;    { carriage return }
  
  sprogram =    'program';
  sprocedure =  'procedure';
  sfunction =   'function';
  slabel =      'label';
  sconst =      'const';
  stype =       'type';
  svar =        'var';
  sbegin =      'begin';
  scase =       'case';
  send =        'end';
  sforward =    'forward';
  suses =       'uses';
  ssegment =    'segment';
  spaces =      '';
  
type
  natural       = 0..maxint;
  positive      = 1..maxint;
  
  sixchars      = packed array[1..6] of char;
  
  sigcharrange  = 1..sigcharlimit;
  setrange      = 0..setlimit;
  
  pseudostring  = string[sigcharlimit];
  stringcases   = set of setrange;
  
  linesize      = 1..linelimit;
  lineindex     = 0..linelimit;
  
  setofchar     = set of char;
  
  prockind      = (fwdhalf,allfwd,shortform,formal,outside,notproc);
  
  ptrtoentry    = ^entry;
  
  listofusages  = ^usagecell;
  
  ptrtostackcell = ^stackcell;
  
  tokentype     = (othersy,namesy,lparensy,rparensy,colonsy,
                   semicolsy,periodsy,assignsy,subrangesy);
                   
  entry =
        record
          procname:     pseudostring;
          caseset:      stringcases;
          linenumber:   natural;
          startofbody:  natural;
          left,right:   ptrtoentry;
          before,after: ptrtoentry;
          calls:        listofusages;
          localtree:    ptrtoentry;
          case status: prockind of
            fwdhalf,shortform,formal,outside,notproc:
              ();
            allfwd:
              (forwardblock: natural);
        end;
        
  usagecell =
        record
          what: ptrtoentry;
          next: listofusages
        end;
        
  stackcell =
        record
          current: ptrtoentry;
          scopetree: ptrtoentry;
          substack: ptrtostackcell;
        end;
  
  longstring = STRING[255];

var
  lineno:       natural;
  depth:        natural;
  level:        -1..maxint;
  pretty:       natural;
  onscreen:     boolean;
  
  adjustment:   (first,other);
  movement:     integer;
  
  printflag:    boolean;
  errorflag:    boolean;
  
  ch:           char;
  
  token:        tokentype;
  
  symbol:       pseudostring;
  symbolcase:   stringcase;
  
  savesymbol:   pseudostring;
  
  superroot:    ptrtoentry;
  
  stack:        ptrtostackcell;
  
  alphabet:     set of char;
  alphanums:    setofchar;
  uppercase:    setofchar;
  
  digits:       setofchar;
  
  usefulchars:  setofchar;
  
  namesperline: positive;
  
  outlfn:       string[30];
  outfile:      text;
  
  { include file stuff }
  
  including:    integer;        { include file nest level }
  
  { file control block }
  
  infile:       file;           { input file }
  
  fcb: array[0..1] of
    record
      chno:     lineindex;      { current char index }
      inlfn:    string[30];     { input file name }
      line:     longstring;     { current text line }
      bpos:     integer;        { buffer position }
      endfile:  boolean;        { true when end of file }
      buf:      packed array[0..bufsiz] of char;
      blknr:    integer;
    end;
    
  procedure getstring(VAR S: longstring);
    const
      dle = 16;
    var bcnt, chg: integer;
  begin { getstring } {$R- disable string range checks }
    with fcb[including] do
      repeat
        if bpos >= bufsiz then { time for next buffer }
          begin bcnt := blockread(infile, buf[0], 2, blknr);
            bpos := 0; blknr := blknr + bcnt;
            if bcnt < 2 then { eof }
              begin endfile := true; EXIT(getstring) end;
          end;
        chg := scan(bufsiz-bpos, =chr(CR), buf[bpos]);
        if (bpos + chg) < bufsiz then { found a carriage return }
          begin moveleft(buf[bpos], S[1], chg);    { copy string except CR }
            S[0] := chr(chg); bpos := bpos + chg + 1;
          end
        else
          begin chg := scan(1024-bpos, =chr(0), buf[bpos]);   { look for null }
            if (bpos + chg) < bufsiz then
              begin moveleft(buf[bpos], S[1], chg-1); 
                S[0] := chr(chg); bpos := 1024;
              end;
          end;
      until chg > 0;
    if s[1] = chr(dle) then
      begin s[1] := ' '; s[2] := ' ' end;
  end;  { getstring } {$R+}
  
procedure printline;
    var i: linesize;
  begin { printline }
    write(outfile, lineno:5, '   '); i := 1;
    with fcb[including] do
      if adjustment = first then
        begin
          while (i < length(line)) and (line[i] = ' ') do
            i := succ(i);
          movement := (level * indentation) - (i - 1);
          adjustment := other;
          if level > 0 then
            write(outfile, ' ':(level*indentation));
        end
      else
        begin
          if movement > 0 then
            write(outfile, ' ': movement)
          else if movement < 0 then
            while (i < length(line)) and (line[i] = ' ') and (i <= -movement) do
              i := succ(i);
        end;
    with fcb[including] do
      while i < length(line) do
        begin write(outfile, line[i]); i := succ(i); end;
    writeln(outfile);
  end;  { printline }
  
  procedure error(e: positive );
  begin { error }
    errorflag := true;
    write(outfile, 'FATAL ERROR - ');
    case e of
      1: write(outfile, 'no "program" word');
      2: write(outfile, 'no identifier after prog/proc/func');
      3: write(outfile, 'token after heading unexpected');
      4: write(outfile, 'lost "." check begin/case/ends');
      5: write(outfile, 'same name, but not forward declared');
      6: write(outfile, 'cannot nest include files');
      7: write(outfile, 'file not found');
    end;
    writeln(outfile, ' - at following line');
    adjustment := first;
    printline;
    writeln(outfile, 'Last symbol: "', symbol, '"');
  end;  { error }
  
  procedure nextch;
  begin { nextch }
    with fcb[including] do
      if (including > 0) and endfile then
        begin close(infile); including := including -1; 
          with fcb[including] do
            begin reset(infile, inlfn);
              writeln('--- re-opening ', inlfn)
            end;
        end;
    with fcb[including] do
      if chno = length(line) then
        begin if printflag then printline;
          getstring(line); line := concat(line, ' ');
          lineno := lineno + 1; chno := 1; ch := line[1];
          if not onscreen then write('.');
        end
      else
        begin chno := succ(chno); ch := line[chno]; end;
  end;  { nextch }
  
  procedure push(newscope: ptrtoentry);
    var
      newlevel: ptrtostackcell;
  begin { push }
    new(newlevel);
    newlevel^.current := newscope;
    newlevel^.scopetree := nil;
    newlevel^.substack := stack;
    stack := newlevel;
    level := level + 1;
  end;  { push }
  
  procedure pop;
    var oldcell: ptrtostackcell;
  begin { pop }
    stack^.current^.localtree := stack^.scopetree;
    oldcell := stack;
    stack := oldcell^.substack;
    level := level - 1;
  end;  { pop }
  
  procedure findnode(var match: boolean;
                     var follow: ptrtoentry;
                         thisnode: ptrtoentry);
  begin { findnode }
    match := false;
    while (thisnode <> nil) and not match do
      begin
        follow := thisnode;
        if savesymbol < thisnode^.procname then
          thisnode := thisnode^.left
        else if savesymbol > thisnode^.procname then
          thisnode := thisnode^.right
        else
          match := true;
      end;
  end;
  
  function makeentry(mainprog: boolean;
                     proc: boolean): ptrtoentry;
    var
      newentry, node: ptrtoentry;
      located: boolean;
      
    procedure puttosupertree(newnode: ptrtoentry);
      var 
        place: ptrtoentry;
        
      procedure findleaf;
        var
          subroot: ptrtoentry;
      begin { findleaf }
        subroot := superroot;
        while subroot <> nil do
          begin
            place := subroot;
            if savesymbol < subroot^.procname then
              subroot := subroot^.before
            else
              subroot := subroot^.after
          end;
      end;  { findleaf }
      
    begin { puttosupertree }
      if superroot = nil then
        superroot := newnode
      else
        begin
          findleaf;
          with place^ do
            begin
              if savesymbol < procname then
                before := newnode
              else
                after := newnode
            end
        end
    end;  { puttosupertree }
    
  begin { makeentry }
    located := false;
    savesymbol := symbol;
    if mainprog then new(newentry)
    else
      if stack^.scopetree = nil then
        begin new(newentry); stack^.scopetree := newentry; end
      else
        begin findnode(located, node, stack^.scopetree);
          if not located then
            begin new(newentry);
              with node^ do
                if symbol < procname then
                  left := newentry
                else
                  right := newentry
            end
        end;
    if not located then
      begin
        with newentry^ do
          begin procname := symbol; caseset := symbolcase;
            linenumber := lineno; startofbody := 0;
            if proc then status := shortform
            else status := notproc;
            left := nil; right := nil;
            before := nil; after := nil;
            calls := nil; localtree := nil;
          end;
        makeentry := newentry;
        if proc then
          begin puttosupertree(newentry); push(newentry); end;
      end
    else
      begin makeentry := node; push(node);
        if node^.status = fwdhalf then
          begin stack^.scopetree := node^.localtree;
            node^.status := allfwd; node^.forwardblock := lineno;
          end
        else
          error(5)
      end
  end;  { makeentry }
  
  procedure printtree(root: ptrtoentry);
    var
      thiscell: listofusages;
      count: natural;
      
    procedure conditionalwrite(n: natural;
                               substitute: sixchars);
    begin { conditionalwrite }
      if n = 0 then
        write(outfile, substitute)
      else
        write(outfile, n:6);
    end;  { conditionalwrite }
  
    procedure namewrite(p: ptrtoentry);
      var len: integer; s: setrange;
    begin { namewrite }
      with p^ do
        begin len := length(procname);
          for s := 0 to len-1 do
            if s in caseset then
              write(outfile, chr(ord(procname[s+1])-uclcdisplacement))
            else
              write(outfile, procname[s+1]);
          end;
      if len < sigcharlimit then
        write(outfile, ' ':sigcharlimit-len);
    end;  { namewrite }
    
  begin { printtree }
    if root <> nil then
      with root^ do
        begin printtree(before); writeln(outfile);
          write(outfile, linenumber: 5); conditionalwrite(startofbody, '      ');
          case status of
            fwdhalf,notproc:
              write(outfile, '   eh?');
            formal:
              write(outfile, '   fml');
            outside:
              write(outfile, '   ext');
            shortform:
              write(outfile, '      ');
            allfwd:
              write(outfile, forwardblock:6);
          end;
          write(outfile, '  '); namewrite(root); write(outfile, ' :'); 
          thiscell := calls;
          count := 0;
          while thiscell <> nil do
            begin
              if ((count mod namesperline) = 0) and (count <> 0) then
                begin writeln(outfile); 
                  write(outfile, ' ':sigcharlimit+19, ' :'); 
                end;
              write(outfile, ' ');
              namewrite(thiscell^.what);
              thiscell := thiscell^.next;
              count := count + 1;
            end;
          writeln(outfile);
          
          printtree(after);
        end;
  end;  { printtree }
  
  procedure nexttoken;
  
    procedure ignorecomment(tail: string);
    
      procedure getdirective;
        var i: integer; found: boolean; inclfn: string[30];
      begin { getdirective }
        {$R- disable range checks }
        nextch;
        if ch = 'I' then { include }
          begin nextch;
            if ch = ' ' then
              begin nextch; i := 0; 
                while ch <> '}' do
                  begin i := i + 1;
                    inclfn[i] := ch;
                    nextch;
                  end;
                inclfn[0] := chr(i);    { set string length }
                {$I- disable IO checks }
                including := including + 1;
                with fcb[including] do
                  begin close(infile); reset(infile, inclfn);
                    found := ioresult = 0;
                    if not found  then { found the file }
                      begin inclfn := concat(inclfn, '.text');
                        reset(infile, inclfn); found := ioresult = 0;
                      end;
                    {$I+}
                    if found then
                      begin writeln('---opening: ', inclfn);
                        inlfn := inclfn; chno := 0; line := '';
                        bpos := bufsiz; endfile := false; blknr := 2;
                      end
                    else
                      begin writeln('---cannot find: ', inclfn);
                        close(infile);
                        including := including - 1;
                        with fcb[including] do
                          reset(infile, inlfn);
                      end;
                  end;
                end;
          end;
        {$R+}
      end;  { getdirective }
      
    begin { ignorecomment }
      nextch;
      if ch = '$' then
        getdirective;
      repeat
        while (ch <> tail[1]) do
          nextch;
        if ch = '*' then
          nextch;
      until (ch = tail[length(tail)]);
      nextch;
    end;  { ignorecomment }
    
    procedure ignorenumbers;
    begin { ignorenumbers }
      while ch in digits do
        nextch;
      with fcb[including] do
        if ch = '.' then
          begin
            if (line[chno+1] in digits) then
              begin nextch;
                while ch in digits do nextch;
              end;
          end;
      if (ch = 'E') or (ch = 'e') then
        begin nextch;
          if (ch = '+') or (ch = '-') then nextch;
          while ch in digits do nextch;
        end;
    end;  { ignorenumbers }
    
    procedure readident;
      var j: integer;
    begin { readident }
      {$R- disable range check to store string length }
      token := namesy; symbol := spaces; symbolcase := []; j := 0;
      while (j < sigcharlimit) and (ch in alphanums) do
        begin j := j + 1;
          if ch in uppercase then
            begin symbol[j] := chr(ord(ch)+uclcdisplacement);
              symbolcase := symbolcase + [j-1];
            end
          else symbol[j] := ch;
          nextch;
        end;
      symbol[0] := chr(j);
      {$R+}
      while ch in alphanums do
        nextch;
    end;  { readident }
    
  begin { nexttoken }
    token := othersy;
    repeat
      if ch in usefulchars then
        begin
          case ch of
            ')':
              begin nextch; token := rparensy; end;
            
            '(':
              begin nextch;
                if ch = '*' then ignorecomment('*)')
                else token := lparensy;
              end;
            
            '{':
              ignorecomment('}');
            
            '''':
              begin nextch;
                while ch <> '''' do nextch; nextch;
              end;
            
            '0', '1', '2', '3', '4', '5', '6', '7', '8', '9':
              ignorenumbers;
            
            ':':
              begin nextch;
                if ch = '=' then
                  begin token := assignsy; nextch; end
                else
                  token := colonsy;
              end;
            
            '.':
              begin nextch;
                if ch <> '.' then token := periodsy
                else begin token := subrangesy; nextch; end;
              end;
            
            ';':
              begin nextch; token := semicolsy; end;
            
            'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', 'K', 'L', 'M',
            'N', 'O', 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W', 'X', 'Y', 'Z',
            'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm',
            'n', 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', 'y', 'z':
              readident;
          end
        end
      else
        nextch
    until token <> othersy;
  end;  { nexttoken }
  
  procedure processunit(programid: boolean);
    var at: ptrtoentry;
  
    function nameisinscope: boolean;
      var
        llevel:         ptrtostackcell;
        discovered:     boolean;
        where:          ptrtoentry;
    begin { nameisinscope }
      llevel := stack;
      discovered := false;
      savesymbol := symbol;
      while (llevel <> nil) and not discovered do
        begin
          findnode(discovered, where, llevel^.scopetree);
          if not discovered then
            llevel := llevel^.substack;
        end;
      if discovered then
        nameisinscope := (where^.status <> notproc)
      else
        nameisinscope := false;
    end;  { nameisinscope }
  
    procedure processblock;
      var
        address:        ptrtoentry;
        
      procedure crossreferencer;
        var
          newcell:      listofusages;
          ptr:          listofusages;
          home:         ptrtoentry;
          slevel:       ptrtostackcell;
          found:        boolean;
        
        procedure findcell;
          var
            nextptr:    listofusages;
        begin { findcell }
          found := false;
          nextptr := stack^.current^.calls;
          if nextptr <> nil then
            repeat
              ptr := nextptr;
              found := (ptr^.what^.procname = savesymbol);
              nextptr := ptr^.next;
            until found or (nextptr = nil)
          else
            ptr := nil;
        end;  { findcell }
      
      begin { crossreferencer }
        slevel := stack; found := false;
        while (slevel <> nil) and not found do
          begin findnode(found, home, slevel^.scopetree);
            if not found then
              slevel := slevel^.substack
          end;
        if found then
          begin
            if home^.status <> notproc then
              begin findcell;
                if not found then
                  begin new(newcell);
                    if ptr <> nil then
                      ptr^.next := newcell
                    else
                      stack^.current^.calls := newcell;
                    newcell^.what := home;
                    newcell^.next := nil;
                  end;
              end;
          end;
      end;  { crossreferencer }
      
      procedure scanforname;
      begin { scanforname }
        nexttoken;
        while token <> namesy do
          nexttoken;
      end;  { scanforname }
      
  begin { processblock }
    while (symbol <> sbegin) do
      begin
        while (symbol <> sbegin) and (symbol <> sprocedure) and
              (symbol <> sfunction) and (symbol <> ssegment) do
          begin 
            scanforname;
            if nameisinscope then
              begin address := makeentry(false, false); end;
          end;
        if symbol <> sbegin then
          begin 
            if symbol = ssegment then
              nexttoken;
            processunit(false); scanforname; 
          end;
      end;
    depth := 1;
    stack^.current^.startofbody := lineno;
    nexttoken;
    while depth <> 0 do
      begin
        if token <> namesy then
          nexttoken
        else
          if (symbol = sbegin) or (symbol = scase) then
            begin depth := depth + 1; nexttoken end
          else
            if (symbol = send) then
              begin depth := depth - 1; nexttoken; end
            else
              begin savesymbol := symbol; nexttoken;
                if token <> assignsy then
                  crossreferencer
                else
                  nexttoken
              end;
      end;
  end;  { processblock }
  
  procedure scanparameters;
    var
      which: ptrtoentry;
      
    procedure scantillclose;
    begin { scantillclose }
      nexttoken;
      while token <> rparensy do
        begin
          if token = lparensy then
            scantillclose;
          nexttoken;
        end;
   end;  { scantillclose }
   
 begin { scanparameters }
   nexttoken;
   while token <> rparensy do
     begin
       if (token = namesy) then
         begin
           if (symbol = sprocedure) or (symbol = sfunction) then
             begin nexttoken;
               if token = namesy then
                 begin which := makeentry(false, true);
                   which^.status := formal; pop; nexttoken;
                   if token = lparensy then
                     scantillclose;
                 end
               else
                 begin error(2); nexttoken; end;
             end
           else
             begin
               if nameisinscope then
                 which := makeentry(false, false);
               nexttoken;
             end;
         end
       else
         nexttoken;
     end;
     nexttoken;
   end;  { scanparameters }
 
  begin { processunit }
    printflag := true;
    adjustment := first;
    nexttoken;
    if token <> namesy then
      error(2)
    else
      begin at := makeentry(programid, true);
        while not (token in [lparensy,semicolsy,colonsy]) do
          nexttoken;
        if token = lparensy then
          scanparameters;
        while token <> semicolsy do
          nexttoken;
        printline;
        printflag := false;
        writeln(outfile);
        nexttoken;
        if token <> namesy then
          error(3)
        else
          begin
            if (symbol <> slabel) and (symbol <> sconst) and (symbol <> stype)
                and (symbol <> sprocedure) and (symbol <> sfunction)
                and (symbol <> svar) and (symbol <> sbegin) 
                and (symbol <> suses) and (symbol <> ssegment) then
              begin
                if symbol = sforward then
                  at^.status := fwdhalf
                else
                  at^.status := outside;
                pop
              end
            else
              begin processblock; pop end
          end
      end;
  end;  { processunit }
  
  procedure printheading;
  begin { printheading }
    writeln(outfile, 'procedural cross-refrencer - version s-02.01');
    writeln(outfile, '============================================');
    writeln(outfile);
  end;  { printheading }
  
begin { refrencer }
  including := 0;
  with fcb[including] do
    begin chno := 0; 
      bpos := bufsiz; blknr := 2; line := ''; endfile := false;
      write('Input file name: '); readln(inlfn); 
      if inlfn = '' then exit(refrencer);
      {$I- disable system IO checks }
      reset(infile, inlfn);
      if ioresult <> 0 then
        begin inlfn := concat(inlfn, '.text');
          reset(infile, inlfn);
          if ioresult <> 0 then
            begin error(7); exit(refrencer); end;
        end;
      {$I+}
      onscreen := (inlfn = '#1:') or (inlfn = 'CONSOLE:') or 
        (inlfn = 'console:');
    end;
  write('Output file name: '); readln(outlfn); 
  if outlfn = '' then outlfn := 'CONSOLE:';
  rewrite(outfile, outlfn);
  superroot := nil;
  new(stack);
  with stack^ do
    begin current := nil; scopetree := nil; substack := nil; end;
    
  printflag := false;
  
  uppercase := ['A'..'Z'];
  alphabet := uppercase + ['a'..'z'];
  digits := ['0'..'9'];
  alphanums := alphabet + digits + ['_'];
  usefulchars := alphabet + digits + ['(', ')', '{', '.', ':', ';', ''''];
  
  namesperline := (linewidth - (sigcharlimit + 21)) div
                    (sigcharlimit + 1);
                    
  lineno := 0;
  level := -1;
  errorflag := false;
   
  page(outfile);
  
  printheading;
  writeln(outfile, ' line   program/procedure/function heading');
  for pretty := 1 to 43 do
    write(outfile, '-');
  writeln(outfile);
  writeln(outfile);
  
  nexttoken;
  if token <> namesy then
    error(1)
  else if symbol <> sprogram then
    error(1)
  else
    begin
      processunit(true);
      if not errorflag then
        begin
          if (token <> periodsy) and (token <> subrangesy) then
            error(4)
          else
            begin
              adjustment := first;
              printline;
            end
        end
      end;
    if not errorflag then
      begin
        page(outfile);
        printheading;
        writeln(outfile, ' head  body  notes ',
                ' ':sigcharlimit,
                '   call made to');
        for pretty := 1 to (sigcharlimit+37) do
          write(outfile, '-');
        writeln(outfile);
        printtree(superroot);
        writeln(outfile);
      end;
  close(outfile, lock);
end.  { refrencer }
  


========================================================================================
DOCUMENT :usus Folder:VOL07:proc.ref2.text
========================================================================================

{                                       

Program Xref2 : Pascal procedural cross reference program

Date          : July 10, 1980.

Programmer    : Patrick R. Horton

Copyright  (c)  1980  -  Associated Computer Industries - All rights reserved 

}

PROGRAM Xref2;                                
 TYPE fwrdrec = RECORD
                 procname : STRING;
                 link     : ^fwrdrec;
                 segnum   : INTEGER;
                 proc     : INTEGER;
                END; 
 VAR ifile1,ifile2,ofile : TEXT; 
     lproc,incname, 
     ifilename,ofilename : STRING;  
     line                : STRING[255]; 
     highseg,
     linenum,nesting, 
     temp,seg            : INTEGER;   
     prseg,
     inseg,gotprog,   
     iflg,ln,needready,   
     includefile         : BOOLEAN; 
     tneed               : ARRAY[1..16] OF INTEGER; 
     procnum             : ARRAY[1..16] OF INTEGER;   
     first,ptr,tptr,fnd  : ^fwrdrec;
 
 PROCEDURE Chkline;
  BEGIN
   linenum := linenum + 1;
   IF linenum MOD 50 = 0 THEN
    BEGIN
     WRITELN;
     WRITE(linenum:6);
    END;
   WRITE('.');
  END;  
     
 PROCEDURE Writeincludefile;  
  BEGIN
   IF ln THEN WRITELN(ofile);       
   ln := FALSE;
   WRITELN(ofile);
   WRITELN(ofile,incname);   
   WRITELN(ofile,'-------------------------------------');
  END;
   
 PROCEDURE Uppercase(VAR line : STRING);
  BEGIN 
   WHILE POS(' ',line) = 1 DO DELETE(line,1,1);
   FOR temp := 1 TO LENGTH(line) DO  
    IF (ORD(line[temp])<123) AND (ORD(line[temp])>96) THEN
     line[temp] := CHR(ORD(line[temp])-32);
  END;
 
 PROCEDURE Paline;      
  VAR ch : CHAR;
      token : STRING;
 
 FUNCTION Notfwrdproc: BOOLEAN; 
  BEGIN
   Notfwrdproc := TRUE; 
   tptr := first;
   WHILE tptr <> NIL DO  
    BEGIN
     IF tptr^.procname = token THEN                  
      BEGIN
       fnd := tptr;
       tptr := nil; 
       Notfwrdproc := FALSE;                 
      END
     ELSE tptr := tptr^.link;
    END;
  END;
 
 PROCEDURE Bypassc1;
  BEGIN
   DELETE(line,1,1);  
   IF (POS('$U',line) =1) OR (POS('$u',line) =1) THEN highseg := 0;  
   REPEAT  
    IF LENGTH(line)=0 THEN
     REPEAT
      IF includefile THEN READLN(ifile2,line) 
                     ELSE READLN(ifile1,line);  
      Chkline;
      Uppercase(line); 
     UNTIL LENGTH(line)<>0;
    WHILE (LENGTH(line)>0) AND (POS('}',line)<>1) DO     
     DELETE(line,1,1);  
   UNTIL POS('}',line)=1;
   DELETE(line,1,1);  
  END;
 
 PROCEDURE Bypassc2;
  BEGIN
   DELETE(line,1,2);    
   IF (POS('$U',line) =1) OR (POS('$u',line) =1) THEN highseg := 0;    
   REPEAT  
    IF LENGTH(line)=0 THEN
     REPEAT
      IF includefile THEN READLN(ifile2,line)   
                     ELSE READLN(ifile1,line);
      Chkline;
      Uppercase(line); 
     UNTIL LENGTH(line)>0;
    WHILE (LENGTH(line)>0) AND (POS('*)',line)<>1) DO        
     DELETE(line,1,1);
    UNTIL POS('*)',line)=1;
   DELETE(line,1,2);  
  END;
  
 PROCEDURE Getoken;      
  VAR out : BOOLEAN;
  BEGIN 
   out := FALSE;
   WHILE (LENGTH(line)>0) AND (NOT out) DO  
     IF POS('{',line)=1 THEN Bypassc1 ELSE 
     IF POS('(*',line)=1 THEN Bypassc2 ELSE                     
     IF line[1] ='''' THEN             
      BEGIN
       DELETE(line,1,1);
       REPEAT
        IF LENGTH(line)=0 THEN 
         BEGIN       
          IF includefile THEN READLN(ifile2,line)      
                         ELSE READLN(ifile1,line);  
          Chkline;
          Uppercase(line);   
         END;
        IF line[1]<>'''' THEN DELETE(line,1,1);      
       UNTIL line[1] = '''';     
       DELETE(line,1,1);  
      END
     ELSE   
      IF NOT(line[1] IN ['0'..'9','_','-','A'..'Z'])
       THEN DELETE(line,1,1)     
       ELSE out := TRUE;      
    token := '';      
    out := FALSE;
    WHILE (LENGTH(line)>0) AND (NOT out) DO    
     IF line[1] IN ['0'..'9','_','-','A'..'Z'] THEN  
      BEGIN
       token := CONCAT(token,COPY(line,1,1));  
       DELETE(line,1,1);
      END
     ELSE out := TRUE; 
  END;     
    
  PROCEDURE Doprog;
   BEGIN
    Getoken;
    IF NOT iflg THEN Writeincludfile;
    iflg := TRUE;
    WRITELN(ofile,'PROGRAM ',token,';');   
    gotprog := TRUE;
   END;
  
  PROCEDURE Doseg;  
   BEGIN
    IF ln THEN WRITELN(ofile);  
    IF NOT iflg THEN Writeincludfile;
    prseg := TRUE;
    iflg := TRUE;     
    inseg := TRUE; 
    ln := FALSE; 
    highseg := highseg + 1;  
    seg := highseg;   
    tneed[seg] := 0;    
    procnum[seg] := 0;  
    needready := FALSE;        
   END;    
   
  PROCEDURE Docas;      
   BEGIN
    IF ln THEN WRITELN(ofile);  
    ln := FALSE;    
    tneed[seg] := tneed[seg] + 1;
    needready := TRUE; 
   END; 
   
  PROCEDURE Dorec;  
   BEGIN
    IF ln THEN WRITELN(ofile);
    ln := FALSE;          
    tneed[seg] := tneed[seg] + 1; 
    needready := TRUE; 
    nesting := nesting + 1;
   END;   
     
  PROCEDURE Doproc;
   BEGIN
    IF ln THEN WRITELN(ofile);
    ln := FALSE;
    IF NOT iflg THEN Writeincludfile;
    iflg := TRUE;
    tneed[seg] := tneed[seg] + 1;  
    needready := FALSE;  
    Getoken;
    ln := TRUE;
    IF Notfwrdproc THEN
     BEGIN
      procnum[seg] := procnum[seg] + 1;
      WRITE(ofile,linenum:4,' ',
                  seg:4,' ',procnum[seg]:4); 
      IF prseg THEN WRITE(ofile,'  SEGMENT');
      prseg := FALSE;
      WRITE(ofile,'  PROCEDURE ',token,';',' ':20-LENGTH(token));     
     END
    ELSE 
     BEGIN
      WRITE(ofile,linenum:4,' ',fnd^.segnum:4,' ',fnd^.proc:4);
      IF prseg THEN WRITE(ofile,'  SEGMENT');
      prseg := FALSE;
      WRITE(ofile,'  PROCEDURE ',token,';',     
                     ' ':20-LENGTH(token),'PREVIOUSLY DECLARED;');         
     END;
    lproc := token;    
   END; 
   
  PROCEDURE Dofun;
   BEGIN
    IF ln THEN WRITELN(ofile);
    ln := FALSE;
    IF NOT iflg THEN Writeincludfile;
    iflg := TRUE;
    tneed[seg] := tneed[seg] + 1; 
    needready := FALSE;      
    Getoken;    
    ln := TRUE;
    IF Notfwrdproc THEN
     BEGIN
      procnum[seg] := procnum[seg] + 1;
      WRITE(ofile,linenum:4,' ',  
                  seg:4,' ',procnum[seg]:4,          
                  '  FUNCTION  ',token,';',' ':20-LENGTH(token));           
     END
    ELSE WRITE(ofile,linenum:4,' ',  
                     fnd^.segnum:4,' ',     
                     fnd^.proc:4,'  FUNCTION  ',token,';',
                     ' ':20-LENGTH(token),'PREVIOUSLY DECLARED;');   
    lproc := token;  
   END;    
   
  PROCEDURE Dofor;  
   BEGIN
    NEW(ptr);
    ptr^.procname := lproc;
    ptr^.link := first;
    ptr^.segnum := seg;
    ptr^.proc := procnum[seg];
    first := ptr; 
    tneed[seg] := tneed[seg] - 1;
    WRITE(ofile,' FORWARD;');     
   END;
   
  PROCEDURE Dobeg;   
   BEGIN
    IF ln THEN WRITELN(ofile);     
    ln := FALSE;
    needready := TRUE;        
    nesting := nesting + 1;  
   END;
    
  PROCEDURE Doend;
   BEGIN
    IF ln THEN WRITELN(ofile);  
    ln := FALSE;
    nesting := nesting - 1;  
    IF (nesting<=0) AND needready THEN        
     BEGIN  
      tneed[seg] := tneed[seg] - 1;
      IF tneed[seg] = 0 THEN 
       BEGIN
        inseg := FALSE;
        seg := 1;   
       END;
      nesting := 0;          
     END;   
   END;           
   
  BEGIN       
   WHILE LENGTH(line)>0 DO    
    BEGIN    
     Getoken;
     IF LENGTH(token)<>0 THEN  
      BEGIN
       IF NOT gotprog THEN IF token = 'PROGRAM'   THEN Doprog ;  
          
       IF token = 'SEGMENT' THEN Doseg       
       ELSE IF token = 'PROCEDURE' THEN Doproc  
       ELSE IF token = 'FUNCTION'  THEN Dofun   
       ELSE IF token = 'FORWARD'   THEN Dofor;  
       
       IF inseg THEN IF token = 'CASE' THEN Docas    
       ELSE IF token = 'RECORD'    THEN Dorec    
       ELSE IF token = 'BEGIN'     THEN Dobeg      
       ELSE IF token = 'END'       THEN Doend;   
      END;
    END; 
  END;       
  
 
 PROCEDURE Pafile;                      
  BEGIN
   WHILE NOT EOF(ifile2) DO   
    BEGIN
     READLN(ifile2,line); 
     Chkline;
     Uppercase(line);     
     Paline;  
    END;
   CLOSE(ifile2);    
   incname := ifilename;
   iflg := FALSE;
  END;   
    
 PROCEDURE Processfiles;   
  BEGIN 
   incname := ifilename; 
   WHILE NOT EOF(ifile1) DO       
    BEGIN
     includefile := FALSE;
     READLN(ifile1,line);  
     Chkline;
     Uppercase(line);       
     temp := POS('{$I ',line);   
     IF temp  = 1 THEN             
      BEGIN 
       incname := COPY(line,temp+4,POS('}',line)-temp-4); 
       Uppercase(incname);
       IF POS('.TEXT',incname)=0 THEN incname := CONCAT(incname,'.TEXT');
       RESET(ifile2,incname);          
       iflg := FALSE;
       includefile := TRUE; 
       Pafile;   
      END;   
     IF temp  = 0 THEN 
      BEGIN
       temp := POS('(*$I ',line);
       IF temp =1 THEN 
        BEGIN
         incname := COPY(line,temp+5,POS('*)',line)-temp-5);   
         Uppercase(incname);
         IF POS('.TEXT',incname)=0 THEN incname := CONCAT(incname,'.TEXT');
         iflg := FALSE; 
         RESET(ifile2,COPY(line,temp+5,POS('*)',line)-temp-5));              
         includefile := TRUE; 
         Pafile;      
        END  
       ELSE Paline;       
      END;       
    END { ifile1 };
   CLOSE(ifile1);  
  END;
    
 BEGIN  
  WRITE(CHR(27),'*',CHR(0),CHR(0),CHR(0),CHR(0));        
  {$I-} 
  REPEAT   
   WRITE('enter input file name ---->');
   READLN(ifilename);
   Uppercase(ifilename);
   IF POS('.TEXT',ifilename)=0 THEN ifilename := CONCAT(ifilename,'.TEXT');
   RESET(ifile1,ifilename);       
  UNTIL IORESULT=0;   
  REPEAT
   WRITE('enter output file name --->');     
   READLN(ofilename);
   REWRITE(ofile,ofilename); 
  UNTIL IORESULT=0;   
  {$I+}
  
  WRITELN('Processing Program Text ');
  WRITE(0:6);
  linenum    := 0;   
  nesting    := 0; 
  seg        := 1;     
  tneed[1]   := 1; 
  procnum[1] := 1;
  highseg    := 9;   
  first      := NIL;
  ln         := FALSE; 
  iflg       := FALSE;
  prseg      := FALSE;   
  inseg      := FALSE;    
  gotprog    := FALSE;
  needready  := FALSE;
  
  Processfiles;
  WRITELN(ofile);WRITELN(ofile);
  WRITELN(ofile,'END OF PROGRAM');
  CLOSE(ofile,lock); 
 END. 
  

========================================================================================
DOCUMENT :usus Folder:VOL07:prx.doc.text
========================================================================================






                                PRXref
           A Pascal Program Print/Cross-reference Processor
                             Users Manual
                       version 2.0 -- July 1980

                    program and manual written by
                            David J. Lewis

                    Digicomp Research Corporation
                             Terrace Hill
                       Ithaca, New York  14850
                             607-273-5900

                                 and

                      Department of Mathematics
                            Ithaca College
                       Ithaca, New York  14850
                             607-274-3108

                          program and manual
                  Copyright (C) 1980, David J. Lewis


Permission is granted to use and copy this program and its
documentation under the terms of the UCSD Pascal System Users'
Society.  Use or copying under any other circumstances or terms is
prohibited without the prior, written consent of the author.  In
particular, any resale or distribution for profit is prohibited.



                         GENERAL DESCRIPTION

PRXref is a processor for printing and cross-referencing Pascal
programs.  It runs under the UCSD Pascal (TM) system, versions I.5,
II.0 and III.0.

In its program printing function (which can be applied to any file,
not just a Pascal program) PRXref provides line and page skipping,
line numbering, standard or user-specified headers, the UCSD Pascal
include-file mechanism, multiple line spacing, multiple copies and
direction of output to any volume or file.

For its cross-reference function, PRXref lists all occurrences of
identifiers defined by the programmer with their line numbers.
Procedure and function definitions are specially flagged.  As with
printing, files may be included.  This, plus a very large space for
cross-reference tables via disk, makes PRXref especially suitable for
handling large Pascal programs.


Note: "UCSD Pascal" is a registered trademark of the Regents of the
University of California.









PRXEF MANUAL, July 1980 -- General Usage                   page 2


I. GENERAL USAGE INSTRUCTIONS.

   A. INVOCATION.  PRXref is invoked by X(ecution from the UCSD Pascal
      command level.  This will result in a brief initialization and
      then display of the user option menu.
      
   B. DISPLAY REQUIREMENTS.  Options are shown in a vertical menu on
      on the system display console.  The display is presently
      organized for 18 lines of 64 or more characters.  It may be
      squeezed into 16 lines as described in section IV.F.  The screen
      must have XY-cursor addressing (embodied in the user's GOTOXY
      procedure) and erase-to-end-of-line and -screen functions.
      PRXref will automatically adjust to the user's screen
      environment by reading the SYSTEM.MISCINFO file and report any
      deficiencies.
      
   C. PRINTER REQUIREMENTS.  PRXref itself uses 80 columns across the
      printer carriage for headers and cross-reference.  Generally,
      the user wants each program line to fit on a single printer
      line, so she/he should maintain the horizontal size of the
      program within the bounds of their own print device.  Certain
      constants in PRXref control the size of line that can be
      handled.  This is more fully described in sections II.F and
      IV.B.
      
   D. OPTION SPECIFICATION.  Default options are shown with the menu.
      To change any user option type the first letter of the option,
      upper or lower case.  One may continue altering options until
      printing begins with <etx> as described in section I.E.  The
      function of each option is described in section II.D.
      
      There are four data types for options:
      
      1. Yes/No.  Type "Y" or "N" (upper or lower case).  Other
         characters are ignored.  PRXref will respond to the single
         character with no carriage return required, echoing the full
         "Yes" or "No".
         
      2. String.  Type a string followed by a carriage return.  Upper
         and lower case are irrelevant.  Any typable character but a
         carriage return or end-of-file sequence may be entered.  As
         usual, <backspace> and <delete> (or <rub out>) serve to edit
         strings.
         
      3. Integer.  Type an integer, terminating with a space or a
         carriage return.  Illegal characters are ignored.  Type
         <backspace> to undo one or more characters.  The maximum is
         four digits, and any subsequent digits are ignored.
         Individual options have differing requirements for range.
         
      4. Character.  Type the single character.  No carriage return is
         required.
         
   E. INITIATION OF PRINTING.  Type <etx> (usually control-c) to
      initiate printing and/or cross-referencing.  However, both a








PRXEF MANUAL, July 1980 -- General Usage                   page 3


      valid input file (F(ilename option) and output file/volume
      (O(utput file option) must be specified before printing can
      begin.  If either is not present (missing or showing an error
      message), the <etx> is ignored.
      
      If output is directed to the printer (see II.C below), then the
      printhead should be positioned at the physical top-of-form
      before initiating printing.  The volume containing the PRXref
      code file must remain mounted during execution, as it uses
      segment procedures.
      
   F. ESCAPING FROM EXECUTION.  Anytime during printing or cross-
      referencing, hitting any key (but <escape>) will suspend
      execution until another key hit. <escape> will give options to
      terminate: either the entire program (another <escape>) or just
      the file being processed (any other key).
      
   G. REPETITION.  After printing is complete, all options remain the
      same, except for the number of copies, which is set to 1.  The
      user may reselect options and initiate processing of another
      file.
      
   H. QUITTING.  Instead of selecting an option, type "Q" to quit
      PRXREF at any time.
      
      





































PRXREF MANUAL, July 1980 -- Printing Function              page 4


II. PRINTING FUNCTION.
   
   A. GENERAL FEATURES.  When the P(rint option is "Yes," the input
      file is printed line-for-line. If V(ertical formatting is "Yes,"
      then PRXref will perform line and page skipping and header
      specification under control of directives in the user's file.
      
      PRXref performs no filling, concatenation, indentation or other
      horizontal formatting functions.  (The one exception is that a
      line is broken when it does not fit into a print line.)  In
      short, PRXref assumes that the user has arranged the program as
      it should look when printed.  If that is not true, one may use a
      program pretty-printer such as those published by the UCSD
      Pascal System Users Society (software library, volume 1) or the
      Pascal News (#13, pages 34-58).
      
   B. INPUT FILE.  The input file is selected with the "F(ilename"
      option.  This must be a .TEXT file, though the ".TEXT" may be
      omitted from the filename.  Lowercase letters in the filename
      are translated to uppercase.  Specification of an illegal
      filename or a file not present will result in an error message.
      Volume prefixes (#5:, #VOL:, etc) may be used, and the default
      volume prefix set by the UCSD filer is effective.
      
      If SYSTEM.WRK.TEXT is present, this will be the default input
      filename when PRXref is initialized, though the user may alter
      it.  If SYSTEM.WRK.TEXT is not present, there is no default, and
      the input file must be specified before printing.
      
   C. OUTPUT FILE/VOLUME.  The output destination is selected with the
      "O(utput file" option.  This may be either a file on a block-
      structured volume or a non-block-structured volume.  In both
      cases, lowercase letters are translated to uppercase.
      
      Output files on block-structured volumes must be specified in
      full; ".TEXT" is not assumed.  Volume prefixes may be used, and
      the default volume prefix is effective.
      
   D. OPTIONS.  The basic option "P(rint :Yes" must be set.  If
      "X(ref :Yes" is also set, cross-referencing will occur in
      addition to printing.  See section III for a description of
      cross-referencing.  Other options for printing are:
      
      1. I(nclude. (Yes/No, default: Yes).  If "Yes," file-include
         directives intended for the UCSD Pascal compiler will be
         respected, resulting in inclusion of the named files (for
         example, {$I OTHER.STUFF.TEXT}) .  If "No," then include
         directives will be printed like ordinary lines, causing no
         file inclusion.
         
         An include directive in the file being printed must stand
         alone on a line, possibly indented but without other
         directives or text.  Other than this, all variants of include
         directives are recognized by PRXref, including both kinds of
         comment delimiters, upper and lower case and omission of








PRXREF MANUAL, July 1980 -- Printing Function              page 5


         ".TEXT".
         
         Included files may themselves contain include directives,
         nested to any reasonable depth.  However, the UCSD Pascal
         compiler does not support such nesting.
         
         When line numbers are printed (see the "N(umbering" option
         below) and files are included, line numbers will correspond
         exactly to those on listing output from the the UCSD Pascal
         compiler (using the (*$L...*) compiler directive).
         
      2. V(ertical formatting. (Yes/No, default: Yes).  Setting this
         option causes PRXref to recognize special vertical formatting
         directives in the user's file.  These provide for line
         skipping, page skipping and header specification.  See
         section II.E for details.  If the V option is "No," such
         directives are treated as ordinary text and printed.
         
      3. C(ommand char. (character, default: #).  This is the
         character used in the printed file to identify formatting
         directives.  See section II.E.
         
      4. S(kip page. (Yes/No, default: Yes). If "Yes," then a page
         skip is performed over the perforations of each page.  The
         values currently set to describe the page are discussed in
         section II.F.  If the S option is "No," then page skipping is
         not performed, and the listing will run over the
         perforations.  If S is "No" and H is "Yes," then a header
         will be printed after the usual number of text lines for a
         page, but there will be no skipping over the perforations.
         
         Presently, page skipping is performed by printing the
         appropriate number of empty lines, but a top-of-form
         character may be used for a printer that recognizes it; see
         section IV.B.
         
      5. N(umbering. (Yes/No, default: Yes).  If "Yes," then line
         numbers appear to the left of each printed line, in a field
         of width five.  Line numbers begin at 1 and go up to 32767.
         Turning on the X(ref option automatically turns on line
         numbering, though it may not show on the options list.
         
         PRXref numbers lines exactly the same as the UCSD Pascal
         compiler, even in the face of included files.  Thus, a
         compiler listing and its line numbers will correspond to a
         cross-reference produced by PRXref from the same source
         program.  In view of this, the user may sometimes want to
         produce a listing with the compiler to obtain code file
         information.  The cross-reference may then be obtained from
         PRXref, turning the P option off.  In doing so, be careful to
         leave the (*$L...*) compiler directive in the file for cross-
         referencing so line numbers will not change.
         
      6. L(ine spacing. (integer, default: 1).  This is the spacing
         for the printed output: 1 is single spacing, 2 is double








PRXREF MANUAL, July 1980 -- Printing Function              page 6


         spacing, etc.  The range is 1 to 8.  When the format
         directive {#S...}  is used in the file to skip lines, the
         skip value is multiplied by the current line spacing factor.
         
      7. E(ject on incl.  (Yes/No, default: Yes).  If "Yes," then the
         beginning and end of an included file causes a page ejection.
         Thus, each included file occupies its own unique pages in the
         listing, and the file titles in standard headers are
         unambiguous.
         
         If E is "No," then the listing will run continuously across
         included files.  In this case, the title header may not
         accurately reflect the included source file until the next
         regular page ejection.  The same general effect as the E
         option may be achieved with the (*#H...*) and (*#P*) format
         directives described in II.E.
         
      8. #( of copies. (integer, default: 1).  The entire print and
         cross-reference process will be repeated this many times with
         the same options before returning to the user for reselection
         of options.  Upon completing the repetitions, all options
         will remain the same except this one, which is reset to 1.
         The range for # is zero to 9999.
         
   E. VERTICAL FORMATTING DIRECTIVES. These are directives embedded in
      the file being printed to control vertical formatting of the
      listing under PRXref.
      
      The general syntax of vertical formatting directives is a Pascal
      comment beginning with a special character, called the command
      character and another character, called the directive character,
      indicating the operation.  This is similar to compiler
      directives in Pascal, but with a different command character
      than the "$" (usually "#").  For example, the "P" directive may
      be written {#P}.  Format directives must stand alone on lines of
      the file, without other directives or text.
      
      The default command character is "#", though the user may alter
      this with the "C(ommand char" option.  Directive characters are
      "S", "P" and "H", with lower case acceptable as well.  Some
      directives require a following operand, and PRXref is tolerant
      of leading and trailing blanks in such operands except where
      noted.  Format directives are:
      
      1. Line skipping: "S <number>" or "S".  This causes a skip of
         <number> lines, or one line if <number> is omitted.  <number>
         may be up to the size of a physical page.  Examples:
         (*#S 2*), {#S}, {#s10}.
         
      2. Page ejection: "P".  Examples: {#p}, (*#P *).  This causes
         immediate page ejection.
         
      3. Header specification: "H+", "H-", "H <header text>. "H+"
         installs the standard header with file titles.  "H-"
         suppresses all headers.  For these, the "+" and "-" must








PRXREF MANUAL, July 1980 -- Printing Function              page 7


         stand next to the "H".
         
         The standard header, selected by (*H+*), is the default in
         case the user's file contains no H directives.  It contains
         the name of the file being printed, the page number for the
         entire listing and a separator line including the date from
         the catalog of the booted volume.  If a file is being
         included, then the name of that file and the page number
         within it are also printed in the standard title header.
         
         "H <header text>" installs <header text> as the header for
         subsequent page ejections, whether caused by {#P} or page
         overflow.  A single space between "H" and <header text> is
         optional and is deleted if present.  The remainder of
         <header text> is taken literally, including leading and
         trailing spaces.  When <header text> is printed at the top of
         a page, it will be followed immediately by the listing page
         number.  An example of a header to capitalize on this feature
         is:
         
            (*#H The Perils of Pauline.     Page *)
         
         User-supplied headers are also followed by a separator line
         with the date.
         
         The H directive does not in itself cause page ejection, but
         becomes effective upon the next page ejection ocurring
         naturally or through the P directive.
         
   F. PRINTING DIMENSIONS.  The page and other printing dimensions are
      fixed at these values: 66 physical lines per page; 2 lines of
      margin above the header; 1 line of margin below the header; 4
      lines of margin at the page bottom; 80 columns in the header and
      header separator lines; 5 columns for line numbers, if selected;
      130 columns across the page; zero nulls sent to "PRINTER:" upon
      carriage return; 14 references per line in the cross-reference
      printout (at 5 columns per reference).
      
      For information on changing these, see section IV.B.
      























PRXEF MANUAL, July 1980 -- Cross-reference Function        page 8


III. CROSS-REFERENCING.
   
   A. GENERAL FEATURES.  When the X(ref option is "Yes," the input is
      assumed to be a Pascal program, and all identifiers in the
      program but keywords (Pascal reserved words plus some other
      identifiers) are listed in the cross-reference with every line
      number on which they occur.  This listing is sorted
      lexicographically and is numbered and headed separately.
      
   B. IDENTIFIER NORMALIZATION.  Identifiers are normalized in the
      following ways for processing by X(ref:
      
      1. Identifiers are truncated at length eight.
         
      2. Lower case letters are mapped to upper case.
         
      3. The underscore is ignored and not printed in the cross-
         reference listing.
         
   C. KEYWORDS.  Pascal reserved words and some other standard
      identifiers are omitted from the cross-reference.  Keywords
      include:
      
      1. All the bold-face (or underlined) reserved words appearing in
         the Pascal grammar or syntax diagrams (such as BEGIN,
         PROGRAM, END, DO, etc.);
         
      2. The standard simple type identifiers: CHAR, BOOLEAN, INTEGER,
         REAL; the type identifier TEXT; the type identifiers STRING
         and INTERACTIVE added to UCSD Pascal;
         
      3. The standard boolean constants: TRUE, FALSE.
         
      4. The standard file names: INPUT and OUTPUT;
         
      5. The intrinsic procedure and function names: WRITE, WRITELN,
         READ, READLN, PAGE, PUT, GET, RESET, REWRITE, CHR, ORD, SUCC,
         PRED, NEW, DISPOSE, MARK, TRUNC, ROUND, EOF, EOLN, ODD.
         
      Many of these can be redefined by the programmer, but since that
      practice is questionable, they have been included as keywords.
      The list of keywords may be altered by a simple change to the
      source program.  See section IV.E for details.
      
D. PROCEDURE AND FUNCTION NAMES.  Every occurrence of a identifier
   immediately following the reserved words PROCEDURE or FUNCTION is
   flagged in the cross-reference with a left-pointing arrow.  This
   facilitates finding the body of a forward-declared procedure or
   function, as both the original definition and the body will be
   flagged.
   
E. LARGE PROGRAMS AND OVERFLOW TO DISK.  A large input program can
   create a cross-reference table too large to be held in main memory.
   In this case, PRXref will automatically utilize disk to store the
   table.  This allows for programs of tens of thousands of lines to








PRXEF MANUAL, July 1980 -- Cross-reference Function        page 9


   be handled, even by a single-density, eight-inch floppy disk.
   
   The occurence of disk overflow is automatic and need not concern
   the user, except that sufficient space must be allowed on disk to
   contain the overflow if it occurs.  The amount of disk required
   depends on the number of identifiers and references in a program,
   which bears no exact relationship to its size in lines or blocks.
   One example of a 3500 line program required 45 disk blocks for
   cross-reference overflow; another of 3900 lines fit into 64K
   without need for disk.  Once overflow occurs, disk space required
   does not vary with main memory size; the entire table is ultimately
   written to disk.
   
   PRXref uses the largest contiguous empty disk region during cross-
   referencing.  If this becomes exhausted, PRXref will display which
   line and block of the files it was processing.  From this
   information, the user may judge roughly how much more space is
   needed to finish.  Also, if the file is being printed (P(rint: Yes)
   when disk is exhausted, printing will continue with cross-reference
   suppressed.
   
   









































PRXEF MANUAL, July 1980 -- Program Internals              page 10


IV. Here are some notes on the structure and methods of the program to
   aid the user in making modifications.  They are not intended to be
   comprehensive internal documentation.
   
   A. I/O PROCESSING.  To improve processing speed, PRXref uses
      BLOCKREAD for all input and (as indicated by Boolean UNITOUT)
      UNITWRITE for output directed to the printer and terminal.  READ
      and WRITE are avoided where possible, and most processing is
      done directly in the input/output buffer INCBUFF by PFILE and
      its subprocedures.
      
      That is why the routines GETLINE and PUTLINE appear more complex
      than necessary.  GETLINE ensures that a complete line of the
      file always appears in the buffer for PUTLINE.  The current
      input line is communicated by GETLINE with buffer pointer TPTR
      and length TLENGTH.
      
      The size of the buffer INCBUFF is the constant BUFFMAX.  To
      allow a complete line to be present at all times, BUFFMAX (647)
      is set to the size of a block (512) plus the maximum size of an
      input line (132) plus 2 for indent codes plus 1 for the carriage
      return.  There is little harm in leaving BUFFMAX at this figure,
      even if input lines are all shorter, but if longer input lines
      are expected, BUFFMAX as well as LINELENGTH should be increased.
      
   B. THE PRINTER.  The printer dimensions discussed in section II.F
      are set in the first block of constants of the main program,
      where they are fully commented.  The user may alter them, with
      the understanding that few such changes have been tested by the
      author.
      
      Many printers require some nulls on carriage return (or a two-
      way conversation about buffer filling).  If this is not handled
      in your low-level printer drivers, then change the constant
      NUMPRNULLS from zero to however many nulls are necessary.
      
      Also, if your printer responds to a form-feed character (usually
      Ascii FF, decimal equivalent 12), then change PRFORMFEED to its
      decimal equivalent.  Leaving PRFORMFEED at zero induces PRXref
      to insert blank lines for page skipping on direct output to the
      printer.
      
   C. CROSS-REFERENCE TABLE.  The cross-reference table is maintained
      as demonstrated by Wirth in "Algorithms + Data Structures =
      Programs," (Prentice Hall, 1976, pages 164-274).  This is
      scatter storage (hashing) with quadratic probing for collision
      resolution.
      
      
      Procedure SEARCH does the work.  It searches for an identifier
      (IDX), and adds a reference with the global LINENUMBER.  A hash
      table T of size P contains all identifiers in the table along
      with pointers to dynamic variables (ITEMs) containing
      references.  Each ITEM is an array of NUMREFS references plus a
      COUNT of references in the ITEM or a pointer (PTR) to the next








PRXEF MANUAL, July 1980 -- Program Internals              page 11


      ITEM for this identifier.  NUMREFS is now set to five, and that
      seems about right, since there are tend to be around that many
      references per symbol in large programs.
      
      The hash function SEARCH is the sum of the four integers
      constituting an eight-byte identifier, added modulo the table
      size P .  Real addition is used to avoid arithmetic overflow,
      and this may not be very efficient on some processors.  However,
      PRXref was largely developed on Pascal-100 (TM), the S-100 CPU
      based on the Pascal Microengine chipset (TM) where real
      arithmetic is microcoded and pretty fast, so it is not a
      problem.  Replacing the hash function with your favorite should
      be easy.
      
      (By the way, "Pascal-100" is a trademark of Digicomp Research
      Corporation, and "Pascal Microengine" is a trademark of Western
      Digital Corporation.  Don't forget that.)
      
      For this method of hashing, P must be a prime.  It is now 863,
      which seems about right on a 64K system in balancing overflow of
      the hash array with exhaustion of dynamic memory.  A rough guess
      (not authoritative) is to reduce P by about 40 for each
      reduction of 1K of memory, keeping it prime of course.
      
      Keywords are placed in the table (by INITXREF) with a special
      negative linenumber, and no references to them are recorded,
      though they are tabulated.
      
   D. CROSS-REFERENCE TABLE OVERFLOW.  When either dynamic storage
      falls below MEMTHRESH (now 600) or the hash table T is filled to
      the fraction LOADFACTOR (0.9), use of disk for cross-reference
      tables is initiated.  The entire table at the time is written to
      disk in a hunk containing records (DRCDS) of DREFSPER references
      each.  The table in main memory is then reinitialized, seeded
      with the keywords and the program started afresh.  This happens
      again on successive overflows, up to MAXNHUNKS (10) times.
      After all is done, the disk hunks are read in and merged.  All
      this is handled by PRINTTABLE.
      
   E. ADDING/DELETING KEYWORDS.  The choice of keywords may not
      satisfy everybody.  This may be changed in INITXREF simply by
      deleting or inserting more calls to SEARCH.
      
   F. DISPLAY SCREEN.  A layout of the display screen is shown in the
      comments to the main program along with controlling constants.
      To reduce the display lines required from 18 to 16, reduce
      PRROWA to 2 and PRGAP to 0.
      
      Erase-to-end-of-line and -screen functions are set up with
      strings EOLSTRING and EOSSTRING deduced from SYSTEM.MISCINFO by
      INITSCREEN.  If your screen doesn't have these functions, then
      some surgery might be required, as PRXref does not keep track of
      screen coordinates. If your screen doesn't even have XY cursor
      addressing, then you are not getting your money's worth out of
      UCSD Pascal.  If you don't even have a screen...








PRXEF MANUAL, July 1980 -- Program Internals              page 12


      
      Note that INITSCREEN always uses the Ascii <null> for screen
      filler, when required, rather than the character that UCSD added
      later to SYSTEM.MISCINFO as a variable fill character.  If this
      bothers your terminal, change it.
      
   G. ESCAPING EXECUTION.  There is code in PRXref to poll the
      keyboard during printing or cross-referencing.  This is in
      functions ESCAPEHIT and KEYHIT.  KEYHIT is the low-level
      routine, and it is presently disabled, always returning FALSE.
      There are also two commented-out alternatives: (a) a routine for
      Pascal-100 with a Cromemco Tuart, using Pascal-100's memory-
      mapped I/O; (b) an EXTERNAL body to mate with an assembly
      language routine.
      
   H. OPTIONS.  Adding your own options is fairly easy, at least as
      far as data entry, using the option-entry package.  Code must be
      added in two places:
      
      1. In SHOWOPTIONS place a call to an appropriate POxxxx routine
         with the prompt string and variable name for the option.  The
         order of options here is exactly the order they will appear
         on the screen.  The option-entry package keeps track of that.
         
      2. In the body of OPTIONS place a case with the (upper case)
         constant for the option, a call to the appropriate PIxxxx
         routine and any other code needed immediately.
         
   I. CROSS-REFERENCE STATISTICS.  These are provided after the cross-
      reference for fun and profit.  "Programmer's symbols" means
      anything but keywords.  The number of usages does not
      distinguish declarations from other usages -- it's really just a
      count on the table printout.  "Keyword usages" obviously does
      not include keyword declarations.  "Total symbol usages" is the
      sum of the other two usages and probably provides a reasonable
      measure of "program size."  It's certainly better than "lines"
      or "characters," both of which can vary with superficial aspects
      of programming style.
      
      When disk is used for cross-referencing, information is provided
      on the extent of each hunk of the table written to disk.  This
      tells both the number of lines and blocks of the file that had
      been read when the hunk was written.  It might be useful in
      judging the amount of disk storage needed to cross-reference a
      large program.
      
















========================================================================================
DOCUMENT :usus Folder:VOL07:prxref.ini.text
========================================================================================

(**********************************************)
(* PRXREF.INI -- DJL, 1980 JULY 11, 8:00 P.M. *)
(**********************************************)

SEGMENT PROCEDURE INITXREF; (* was forward *)
VAR
  I, SAVELINE: INTEGER;
BEGIN
   (* use linenumber as a code to indicate keywords *)
   SAVELINE := LINENUMBER;  LINENUMBER := KWCODE;
   LNUMENTRIES := 0;  (* initialize entry counter local to hunk *)
   (* init hash tbl *)
   TOP := P;
   FOR I := 0 TO P DO  T[ I].KEY := '        ';
   (* start with a fresh heap *)  RELEASE( HEAPPOINT);  MARK( HEAPPOINT);
   (* place keywords in table *)
   SEARCH( 'AND     ');  SEARCH( 'ARRAY   ');  SEARCH( 'BEGIN   ');
   SEARCH( 'BOOLEAN ');  SEARCH( 'CASE    ');  SEARCH( 'CHAR    ');
   SEARCH( 'CONST   ');  SEARCH( 'DIV     ');  SEARCH( 'DOWNTO  ');
   SEARCH( 'DO      ');  SEARCH( 'ELSE    ');  SEARCH( 'END     ');
   SEARCH( 'EXIT    ');  SEARCH( 'FILE    ');  SEARCH( 'FOR     ');
   SEARCH( 'FUNCTION');  SEARCH( 'GOTO    ');  SEARCH( 'IF      ');
   SEARCH( 'IN      ');  SEARCH( 'INPUT   ');
   SEARCH( 'INTEGER ');  SEARCH( 'MOD     ');  SEARCH( 'NIL     ');
   SEARCH( 'NOT     ');  SEARCH( 'OF      ');  SEARCH( 'OR      ');
   SEARCH( 'OUTPUT  ');  SEARCH( 'PACKED  ');  SEARCH( 'PROCEDUR');
   SEARCH( 'PROGRAM ');  SEARCH( 'REAL    ');  SEARCH( 'RECORD  ');
   SEARCH( 'REPEAT  ');  SEARCH( 'SET     ');  SEARCH( 'STRING  ');
   SEARCH( 'TEXT    ');  SEARCH( 'THEN    ');  SEARCH( 'TO      ');
   SEARCH( 'TYPE    ');  SEARCH( 'UNTIL   ');  SEARCH( 'VAR     ');
   SEARCH( 'WHILE   ');  SEARCH( 'WITH    ');  SEARCH( 'WRITE   ');
   SEARCH( 'WRITELN ');  SEARCH( 'INTERACT');
   SEARCH( 'READ    ');  SEARCH( 'READLN  ');  SEARCH( 'SUCC    ');
   SEARCH( 'PRED    ');  SEARCH( 'TRUNC   ');  SEARCH( 'ROUND   ');
   SEARCH( 'ORD     ');  SEARCH( 'CHR     ');  SEARCH( 'ODD     ');
   SEARCH( 'EOF     ');  SEARCH( 'EOLN    ');  SEARCH( 'PAGE    ');
   SEARCH( 'PUT     ');  SEARCH( 'GET     ');  SEARCH( 'RESET   ');
   SEARCH( 'REWRITE ');  SEARCH( 'LABEL   ');  SEARCH( 'FORWARD ');
   SEARCH( 'NEW     ');  SEARCH( 'DISPOSE ');  SEARCH( 'MARK    ');
   SEARCH( 'FALSE   ');  SEARCH( 'TRUE    ');
   LINENUMBER := SAVELINE; (* resore usual linenumber *)
   END; (* INITIALIZE *)
(**************************************************************************)

SEGMENT PROCEDURE INITIALIZE( FIRSTTIME: BOOLEAN);
  (* initialize most variables:  *)
  (*   FIRSTTIME ==> at the very beginning of execution *)
  (*   NOT FIRSTTIME ==> preceding each user requested repetition of *)
  (*     processing a file *)

VAR
  I: INTEGER;
  (**************************************************************************)

  PROCEDURE NTOSTR( N: INTEGER; VAR S: STRING);
    (* convert non-negative integer to string for date routine *)
  BEGIN
    S := '';
    REPEAT
      INSERT( ' ', S, 1);  S[ 1] := CHR( (N MOD 10) + ORD( '0'));
      N := N DIV 10
      UNTIL N = 0
    END;
  (**************************************************************************)

  PROCEDURE INITSCREEN;
    (* sets up EOLSTRING and EOSSTRING for erasing parts of screen *)
    (* gets its information from SYSTEM.MISCINFO *)
    (* also checks screen width and height against MINSCRWIDTH and *)
    (* MINSCRHEIGHT and insists on random cursor addressing *)
    (* before proceeding *)

    TYPE
      SYSCOMREC = RECORD (* image of SYSTEM.MISCINFO *)
        JUNK: ARRAY[ 0..28] OF INTEGER; (* junk and expansion area *)
        MISCINFO: PACKED RECORD
          NOBREAK, STUPID, SLOWTERM,
          HASXYCRT, HASLCCRT, HAS8510A, HASCLOCK: BOOLEAN
          END;
        CRTTYPE: INTEGER;
        CRTCTRL: PACKED RECORD
          RLF, NDFS, ERASEEOL, ERASEEOS, HOME, ESCAPE: CHAR;
          BACKSPACE: CHAR;
          FILLCOUNT: 0..255;
          CLEARSCREEN, CLEARLINE: CHAR;
          PREFIXED: PACKED ARRAY[ 0..8] OF BOOLEAN
          END;
        CRTINFO: PACKED RECORD
          WIDTH, HEIGHT: INTEGER;
          RIGHT, LEFT, DOWN, UP: CHAR;
          BADCH, CHARDEL, STOP, BREAK, FLUSH, EOF: CHAR;
          ALTMODE, LINEDEL: CHAR;
          BACKSPACE, ETX, PREFIX: CHAR;
          PREFIXED: PACKED ARRAY[ 0..13] OF BOOLEAN;
          END
        END (*SYSCOM*);
    VAR
      STROFNULLS, ONENULL, PS: CTLSTRING; (* for nulls to terminal *)
      MISCFILE: FILE OF SYSCOMREC; (* file to read SYSTEM.MISCINFO *)
      NFILL, I: INTEGER;
      HADMERR: BOOLEAN; (* error flag *)

    PROCEDURE MERR( S: STRING);
      (* error handler for screen setup *)
      BEGIN  WRITELN;  WRITE( 'Screen problem: ', S);  HADMERR := TRUE  END;

    BEGIN (* INITSCREEN *)
      HADMERR := FALSE; (* assume no problems in info *)
      (*$I-*) RESET( MISCFILE, '*SYSTEM.MISCINFO'); (*$I+*)
      WITH MISCFILE^ DO BEGIN
        IF IORESULT <> 0 THEN
          MERR( 'No SYSTEM.MISCINFO file on boot volume')
        ELSE (* have SYSTEM.MISCINFO; check it out *) BEGIN
          IF NOT MISCINFO.HASXYCRT THEN MERR( 'No XY CRT.');
          IF CRTINFO.WIDTH < MINSCRWIDTH THEN BEGIN
            MERR( 'Screen width < '); WRITE( MINSCRWIDTH)  END;
          IF CRTINFO.HEIGHT < MINSCRHEIGHT THEN BEGIN
            MERR( 'Screen height < '); WRITE( MINSCRHEIGHT)  END;
          IF ( CRTCTRL.ERASEEOL = CHR( 0)) OR ( CRTCTRL.ERASEEOS = CHR( 0)) THEN
            MERR( 'Erase-to-end-of-line or -screen missing');
          END;
        IF HADMERR THEN BEGIN (* found an error *)
          WRITELN; WRITE( 'Cannot run PRXref.');
          EXIT( PRXREF)
          END;

        (* all is ok with the screen; set up control strings *)
        (* first, make strings for prefix and null *)
        PS := ' ';  PS[ 1] := CRTCTRL.ESCAPE;
        (* NOTE: using null as screen filler *)
        ONENULL := ' ';  ONENULL[ 1] := CHR( 0);
        (* then, set up string of nulls for screen filler *)
        IF CRTCTRL.FILLCOUNT > 11 THEN  NFILL := 11
        ELSE NFILL := CRTCTRL.FILLCOUNT;
        STROFNULLS := '';
        FOR I := 1 TO CRTCTRL.FILLCOUNT DO INSERT( ONENULL, STROFNULLS, 1);
        (* set up end-of-line erase string *)
        EOLSTRING := ' ';  EOLSTRING[ 1] := CRTCTRL.ERASEEOL;
        INSERT( STROFNULLS, EOLSTRING, 2);
        IF CRTCTRL.PREFIXED[ 2] THEN INSERT( PS, EOLSTRING, 1);
        (* and end-of-screen *)
        EOSSTRING := ' ';  EOSSTRING[ 1] := CRTCTRL.ERASEEOS;
        INSERT( STROFNULLS, EOSSTRING, 2);
        IF CRTCTRL.PREFIXED[ 3] THEN INSERT( PS, EOSSTRING, 1);
        END (* with *)
      END; (* INITSCREEN *)
  (**************************************************************************)

  PROCEDURE GETDATE( VAR RETDATE: STRING);
    (* get date from unit 4 catalog *)
  CONST
    MONTHSTRING = 'JanFebMarAprMayJunJulAugSepOctNovDec';
  TYPE
    (* the date layout in the catalog *)
    DATERCD = PACKED RECORD  MONTH: 0..12;  DAY: 0..31;  YEAR: 0..100  END;
  VAR
    (* catalog layout for extracting date *)
    BIGRCD: RECORD CASE BOOLEAN OF
      FALSE: ( DATEARRAY: PACKED ARRAY[ 0..21] OF CHAR);
      TRUE: (FILLER: PACKED ARRAY[ 0..19] OF CHAR;
             DATE: DATERCD)  END;
    SDAY, SYEAR: STRING;

  BEGIN WITH BIGRCD, DATE DO BEGIN
    (* get date info from catalog *)
    UNITWAIT( 4);  UNITREAD( 4, DATEARRAY[ 0], 22, 2);
    (* convert numbers to printables *)
    NTOSTR( DAY, SDAY);  NTOSTR( YEAR, SYEAR);
    (* return date in DD-MMM-YY form *)
    RETDATE := CONCAT( SDAY, '-', COPY( MONTHSTRING, MONTH*3-2, 3), '-', SYEAR)
    END  END;
  (**************************************************************************)

  BEGIN (* INITIALIZE *)
    IF FIRSTTIME THEN BEGIN (* initialize once per run *)
      (* get date; establish standard header separator *)
      GETDATE( TODAY);  HEADERSEP := TODAY;
      FOR I := 1 TO HEADERSIZE-LENGTH( TODAY) DO
        HEADERSEP := CONCAT( HEADERCHAR, HEADERSEP);
      (* initialize screen info *) INITSCREEN;
      (* nulls for the printer, if needed *)
      FOR I := 1 TO NUMPRNULLS DO  NULLS[ I] := CHR( NULL);
      (* show not yet in the xref print phase *)  INXREF := FALSE;
      (* initialize user options variables *)
      PAGESKIP := TRUE;  INCLU := TRUE;  PRINTING := TRUE;
      NUMBERING := TRUE;  XREFFING := FALSE;  SPACING := 1;
      VFORMATTING := TRUE;  CMDCHAR := '#';  INCLSKIP := TRUE;
      (* initialize in and out files and check if ok *)
      MAINNAME := 'SYSTEM.WRK.TEXT';
      IF NOT FILECHECK( MAINNAME) THEN MAINNAME := ' ';
      PRINTTITLE := 'PRINTER:';
      PRINTLAST := PAGELINES - BOTMARGIN; (* set last print line *)
      (* translate table load factor to threshhold # entries *)
      MAXNUMENTRIES := TRUNC( LOADFACTOR * P) - 1;
      CMDCHARSET := [ 'H', 'P', 'S']; (* format directives *)
      MARK( HEAPPOINT) (* where to cut back xref tbl to *)
      END
    ELSE BEGIN  (* initialize before each pass at a file *)
      (* show not in xref print phase *) INXREF := FALSE;
      (* header and page and line counting variables *)
      GPAGE := INITPAGE;  HEADER := '';
      HDRS := TRUE;  TITLEHDRS := TRUE;
      FIRSTPAGE := TRUE; (* show topofpage we are starting *)
      FININCL := FALSE; (* controls include page skipping *)
      IF XREFFING THEN BEGIN  (* initialize xref (and assume line numbering *)
        NUMBERING := TRUE;  INITXREF  END;
      LINENUMBER := 0; (* init print line number (will get bumped first) *)
      NUMKWREFS := 0;  (* initialize keyword ref counter *)
      NHUNKS := 0 (* intialize for xref overflow to disk *)
      END
    END; (* initialize *)


========================================================================================
DOCUMENT :usus Folder:VOL07:prxref.opt.text
========================================================================================

(*********************************************)
(* PRXREF.OPT -- for USUS -- 1980 July 14    *)
(*********************************************)

SEGMENT PROCEDURE OPTIONS;
  (* solicits options from user *)

CONST
  NITEMSMAX= 20; (* max number of option items *)

TYPE
  PRRCD= RECORD (* describes an option *)
    LETTER: CHAR; (* activating key hit *)
    ROW: INTEGER  (* display row *)
    END;
  CHSET= SET OF CHAR;

VAR
  PRSTUFF: ARRAY[ 1..NITEMSMAX] OF PRRCD; (* info on options *)
  CURROW, NITEMS, ITEM: INTEGER;
  PROMPTLINE: STRING;
  CH: CHAR;
  FOUND: BOOLEAN; (* for option character search *)
  OKTOGO: BOOLEAN; (* controls initiation of printing *)
(************************************************************)

PROCEDURE RINGBELL;
BEGIN  WRITE( CHR( BELL))  END;
(************************************************************)

PROCEDURE ERRMSG( S: STRING); (* prints error messages for user options *)
BEGIN
  RINGBELL;  GOTOXY( PRCOLC, CURROW);  ERASEEOL; WRITE( S)
  END;
(************************************************************)

FUNCTION SETOUTUNIT( VAR S: STRING): BOOLEAN;
  (* Check and normalize output file/volume title. *)
  (* Allow output to named file or units 1, 2, 6. *)
  (* Set PRINTTITLE to file/vol title in any case. *)
  (* Sets UNITOUT := TRUE and PRINTUNIT in case of unblked unit output. *)
  (* Check to see if file/vol can be opened -- returns TRUE iff OK. *)
VAR
  DUMMYFILE: FILE;
  UNITSET: SET OF CHAR;
BEGIN
  UNITSET:= [ '1', '2', '6'];
  (* normalize numbers with # before and : after *)
  IF ( LENGTH( S) = 1) THEN IF (S[ 1] IN UNITSET) THEN
    S := CONCAT( '#', S, ':');
  IF LENGTH( S) = 2 THEN IF (S[ 1] = '#') AND ( S[ 2] IN UNITSET) THEN
    S := CONCAT( S, ':');
  (* assume it's to be a blocked file, not a unit *)
  PRINTUNIT := -1;  PRINTTITLE := S;
  IF S[ LENGTH( S)] = ':' THEN BEGIN
    IF      ( S = '#1:') OR ( S =  'CONSOLE:') THEN BEGIN
      PRINTTITLE := 'CONSOLE:';  PRINTUNIT := 1  END
    ELSE IF ( S = '#2:') OR ( S = 'SYSTERM:') THEN BEGIN
      PRINTTITLE := 'SYSTERM:';  PRINTUNIT := 2 END
    ELSE IF ( S = '#6:') OR ( S = 'PRINTER:') THEN BEGIN
      PRINTTITLE := 'PRINTER:';  PRINTUNIT := 6  END
    END;
  (* indicate unit or blocked file *) UNITOUT := ( PRINTUNIT > 0);
  (* see if file can be opened for output *)
  (*$I-*) REWRITE( DUMMYFILE, PRINTTITLE); (*$I+*)
  SETOUTUNIT := ( IORESULT = 0);  CLOSE( DUMMYFILE)
  END;
(************************************************************)

FUNCTION READCH( OKSET: CHSET): CHAR; (* read opt char; transl to upper *)
VAR
  C: CHAR;
BEGIN
  READ( KEYBOARD, C);  UCFOLD( C);
  WHILE NOT ( C IN OKSET) DO BEGIN
    RINGBELL;  READ( KEYBOARD, C);  UCFOLD( C)  END;
  WRITE( C); READCH := C
  END;
(************************************************************)

FUNCTION READINT: INTEGER;
  (* interactive integer read *)
  (* more robust than the one in the UCSD operating system *)
  (* Accepts up to 4 digits; end with <cr> or <space> *)
  (* bad digits rejected; <backspace> is effective *)
VAR
  CBS, CH: CHAR;
  RESULT, DIGITS, I: INTEGER;
  DIGSET: SET OF CHAR;
  DONE: BOOLEAN;
BEGIN
  CBS := CHR( BS);  DIGSET := ['0'..'9', ' ', CBS];
  RESULT := 0;  DIGITS := 0; DONE := FALSE;
  REPEAT
    READ( KEYBOARD, CH);
    WHILE NOT( CH IN DIGSET) DO BEGIN
      RINGBELL;  READ( KEYBOARD, CH)  END;
    IF CH = CBS THEN BEGIN (* backspace hit *)
      IF DIGITS > 0 THEN BEGIN (* erase last char; undo conversion *)
        WRITE( CBS,' ',CBS);  RESULT := RESULT DIV 10;  DIGITS := DIGITS-1
        END
      END
    ELSE IF CH = ' ' THEN (* he  wants to quit; shall we let him? *) BEGIN
      IF DIGITS > 0 THEN (* sure *) DONE := TRUE
      ELSE (* no digits; no way *) RINGBELL
      END
    ELSE (* its a numeral *) BEGIN
      IF DIGITS < 4  THEN BEGIN  (* accept and convert digit *)
        WRITE( CH);   DIGITS := DIGITS + 1;
        RESULT := RESULT * 10 + ORD( CH) - ORD( '0');
        END
      ELSE RINGBELL
      END
    UNTIL DONE;
  READINT := RESULT
  END; (* readint *)
(************************************************************)

PROCEDURE POENTER( S: STRING);
  (* enter an option in the table;  place on display *)
BEGIN
  NITEMS := NITEMS + 1; (* count a new item *)
  WITH PRSTUFF[ NITEMS] DO BEGIN
    (* enter letter and row in table *)
    LETTER := S[ 1];  ROW := NITEMS + PRROWA - 3;
    MSGLINE := ROW + PRGAP + 1; (* further messages go here on screen *)
    (* display it *)
    GOTOXY( PRCOLA, ROW);  ERASEEOL;  WRITE( S);
    GOTOXY( PRCOLB, ROW);  WRITE( ':')
    END
  END;
(************************************************************)

PROCEDURE POINIT;
  (* initialize option table *)
BEGIN
  NITEMS := 2;  (* account for Q and <etx> *)
  MSGLINE := 2;
  PRSTUFF[ 1].LETTER := 'Q';        PRSTUFF[ 1].ROW := PRROWA - 1;
  PRSTUFF[ 2].LETTER := CHR( ETX);  PRSTUFF[ 1].ROW := PRROWA - 1;
  GOTOXY( PRCOL, PRROW);  ERASEEOS;
  PROMPTLINE:= CONCAT( 'Print/Xref: <etx> to start; Q(uit          ', TODAY)
  END;
(************************************************************)

(* routines to display options and receive user responses *)
(* types of responses are: *)
(*   YESNO:  Y or N giving TRUE or FALSE to the BOOLEAN variable *)
(*   STRNG:  character string *)
(*   INTEG:  integer (non-negative; <= 4 digits) *)
(*   CHARR:  single character *)
(* POxxxxx routines display option of type xxxxx and place info in table *)
(* PIxxxxx routines receive user response for option of type xxxxx *)
(* PSxxxxx routines display option value ( YESNO only) *)

PROCEDURE PSYESNO( VB: BOOLEAN);
BEGIN
  IF VB THEN WRITE( 'Yes')  ELSE WRITE( 'No')
  END;

PROCEDURE POYESNO( S: STRING; VB: BOOLEAN);
BEGIN  POENTER( S);  PSYESNO( VB)  END;

PROCEDURE PIYESNO( VAR VB: BOOLEAN);
BEGIN
   VB := (READCH( [ 'Y', 'N']) = 'Y');
   WRITE( CHR( BS)); PSYESNO( VB)
   END;

PROCEDURE POINTEG( S: STRING; VI: INTEGER);
BEGIN  POENTER( S);  WRITE( VI)  END;

PROCEDURE PIINTEG( VAR VI: INTEGER);
BEGIN  VI := READINT END;

PROCEDURE POSTRNG( S: STRING; VS: STRING);
BEGIN  POENTER( S);  WRITE( VS) END;

PROCEDURE PISTRNG( VAR VS: STRING);
BEGIN  READLN( VS);  IF VS = '' THEN VS := ' '  END;

PROCEDURE POCHARR( S: STRING; VC: CHAR);
BEGIN  POENTER( S);  WRITE( VC)  END;

PROCEDURE PICHARR( VAR VC: CHAR);
BEGIN  READ( VC) END;

PROCEDURE PROMPT;  (* show prompt line *)
BEGIN GOTOXY( PRCOL, PRROW);  ERASEEOL;  WRITE( PROMPTLINE)  END;
(************************************************************)

PROCEDURE SHOWOPTIONS; (* show options to user as entering in table *)
BEGIN
  POINIT; (* intitialize display screen and table *)
  POSTRNG( 'F(ilename'       ,MAINNAME);
  POSTRNG( 'O(utput file'    ,PRINTTITLE);
  POYESNO( 'X(ref'           ,XREFFING);
  POYESNO( 'P(rint'          ,PRINTING);
  POYESNO( 'I(nclude'        ,INCLU);
  POYESNO( 'V(ert format'    ,VFORMATTING);
  POCHARR( 'C(ommand char'   ,CMDCHAR);
  POYESNO( 'S(kip Pages'     ,PAGESKIP);
  POYESNO( 'N(umbering'      ,NUMBERING);
  POINTEG( 'L(ine spacing'   ,SPACING);
  POYESNO( 'E(ject on incl'  ,INCLSKIPPING);
  POINTEG( '#( of copies'    ,TIMES)
  END (* showoptions *);
  (************************************************************)

BEGIN (* OPTIONS *)
  TIMES := 1; (* always set to one repetition initially *)
  IF NOT SETOUTUNIT( PRINTTITLE) THEN PRINTTITLE := ' ';
  SHOWOPTIONS;  OKTOGO := FALSE; (* not ready to go just yet *)
  REPEAT  (* sequence of user options *)
    REPEAT  (* option solicitation until valid *)
      PROMPT;  READ( KEYBOARD, CH); UCFOLD( CH);
      (* initialize for option search *)
      ITEM := 1;  FOUND := FALSE;
      REPEAT (* looking for character in option table *)
        IF PRSTUFF[ ITEM].LETTER = CH THEN FOUND := TRUE
        ELSE ITEM := ITEM + 1
        UNTIL FOUND OR ( ITEM > NITEMS);
      UNTIL (* the option is *) FOUND;
    IF CH = CHR( ETX) THEN (* asking to go *) BEGIN
      (* but there must be valid input and output files *)
      IF ( MAINNAME <> ' ') AND ( PRINTTITLE <> ' ') THEN OKTOGO := TRUE
      ELSE (* a file title missing; complain *) RINGBELL
      END
    ELSE IF CH = 'Q' THEN (* goodbye chahlie *) EXIT( PRXREF)
    ELSE (* ordinary option character; process it *) BEGIN
      (* move cursor to selected option *)
      CURROW := PRSTUFF[ ITEM].ROW;  GOTOXY( PRCOLB+1, CURROW);  ERASEEOL;
      (* read user's response appropriately *)
      CASE CH OF
        'I' :  PIYESNO( INCLU);
        'V' :  PIYESNO( VFORMATTING);
        'S' :  PIYESNO( PAGESKIP);
        'F' :  BEGIN (* input file; verify right now *)
                 PISTRNG( MAINNAME);
                 IF NOT FILECHECK( MAINNAME) THEN BEGIN
                   ERRMSG( 'Bad input file title');  MAINNAME := ' '
                   END
                 END;
        'P' :  PIYESNO( PRINTING);
        'O' :  BEGIN (* output file/vol; verify now *)
                 PISTRNG( PRINTTITLE);
                 IF NOT SETOUTUNIT( PRINTTITLE) THEN BEGIN
                   ERRMSG( 'Bad output file/vol title');  PRINTTITLE := ' '
                   END
                 END;
        'N' :  PIYESNO( NUMBERING);
        'X' :  PIYESNO( XREFFING);
        'L' :  BEGIN
                 PIINTEG( SPACING);
                 IF SPACING < 1 THEN SPACING := 1
                 ELSE IF SPACING > 8 THEN SPACING := 8
                 END;
        'C' :  BEGIN
                 PICHARR( CMDCHAR);
                 IF CMDCHAR = '$' THEN
                   ERRMSG( 'That''s asking for trouble')
                 END;
        'E' :  PIYESNO( INCLSKIPPING);
        '#' :  PIINTEG( TIMES)
        END
      END
    UNTIL OKTOGO;
  MSG( 'Let''s go...', 0);
  REWRITE( OUTFILE, PRINTTITLE) (* ok to open output for real *)
  END; {OPTIONS}
(**************************************************************************)


========================================================================================
DOCUMENT :usus Folder:VOL07:prxref.pfi.text
========================================================================================

(*********************************************)
(* PRXREF.PFI -- for USUS -- 1980 July 14    *)
(*********************************************)

PROCEDURE PFILE( FNAME:STRING);
  (* Print the file FNAME.  Handles included files recursively, *)
  (*   (thus exceeding UCSD specs). *)
TYPE
  DIRRCD= RECORD (* for compiler and formatter directive info *)
    DIRTYPE, DIRCHAR: CHAR; (* type ($ or cmdchar) and command *)
    DIRSTR: BIGSTRING (* text associated with directive *)
    END;
VAR
  INFILE: FILE; (* input file *)
  INCBUFF: BUFFER; (* input buffer *)
  ID: ALFA; (* for accumulating an identifier in SCANNER, handing to SEARCH *)
  TI:INTEGER; (* pointer for ID *)
  NOMORE: BOOLEAN; (* signals end of file *)
  DIR: DIRRCD; (* contains directive info *)
  PRINTIT: BOOLEAN; (* controls line print/suppresssion with directives *)

  (* variables to deal with buffer; see GETLINE *)
  STPTR, TPTR, BUFFLENGTH: BINDX;
  LASTPTR, TLENGTH, LEFTLENGTH, WLENGTH: BINDXZ;

  (* name and block number being read in include file *)
  BLOCKNUM: INTEGER;  INCNAME: STRING;

  (* states for sequential machine in SCANNER *)
  STATE: (LOOKING, QUOTE, CURLYBRACKET, PARENSTAR, MAYBERC, NEWLC);
  MAYBELC: BOOLEAN; (* help for seq machine *)
  PROCFLAG: BOOLEAN; (* indicates PROC/FUNC kw *)
  {***************************************************************************}

  PROCEDURE SCANNER( CUTEND: BOOLEAN);
    (*****************************************************)
    (* Scan an input line (in the buffer), extract tokens and send them *)
    (*   to SEARCH for entry into the xref table. Respect the sanctity *)
    (*   of comments and quoted strings. *)
    (* This routine uses a sequential machine tokenizing technique. *)
    (*   Since it must work across line boundaries, the state and *)
    (*   auxilliary variables are global to PFILE. *)
    (* CUTEND ==> end of the call forces the end of a token; *)
    (*   otherwise, accumulate token across calls *)
    (*****************************************************)

  VAR
    C: CHAR;
    I, STARTPTR: INTEGER;
  (***********************)
  PROCEDURE SEARCHP( ID: ALFA);
    (* Call the table search routine to enter ID. *)
    (* Place a special code in the table immediately following any *)
    (*   symbol that is preceded by "PROCEDURE" OR "FUNCTION". *)
    (*   This will result in printing a flag in the xref for such symbols *)
  VAR
    SAVELINE: INTEGER;
  BEGIN
    (* look for ID in xref table and enter if appropriate *) SEARCH( ID);
    IF ( ID = 'PROCEDUR' ) OR ( ID = 'FUNCTION' ) THEN
      (* remember that fact for next round *)  PROCFLAG := TRUE
    ELSE IF PROCFLAG THEN BEGIN (* last round was PROC or FUNC keyword *)
      (* put the special code into the xref table *)
      PROCFLAG := FALSE;
      SAVELINE := LINENUMBER;  LINENUMBER := PROCCODE; SEARCH( ID);
      LINENUMBER := SAVELINE
      END
    END;
  (***********************)
  BEGIN (* scanner *)
    (* respect the indent code at the beginning of a line *)
    IF INCBUFF[ TPTR] = CHR( DLE) THEN STARTPTR := TPTR + 2
    ELSE STARTPTR := TPTR;
    (* main scanning loop -- to end of the line *)
    FOR I := STARTPTR TO TPTR + WLENGTH - 1 DO BEGIN
      C := INCBUFF[ I];
      (* fold to upper case (efficiently) *)
      IF ( C >= 'a') THEN IF ( C <= 'z') THEN C := CHR( ORD( C) - 32);
      IF MAYBELC THEN BEGIN (* had left paren last, is this a * ?*)
        IF C = '*' THEN (* yep, we are now starting a comment *)
          STATE := NEWLC;
        MAYBELC := FALSE
        END;
      CASE STATE OF (* main state selection for sequential machine *)
        LOOKING: BEGIN (* looking for a token *)
          IF (( C >= 'A') AND ( C <= 'Z')) OR (( C >= '0') AND (C <= '9'))
            THEN BEGIN (* its an id character; accumulate it *)
            IF (TI <= ALFALEN) THEN (* still under max token length *)
              BEGIN ID[ TI] := C;  TI := TI + 1  END
            END
          ELSE IF C <> '_' THEN BEGIN (* not an id character }
            (* enter appropriate state *)
            IF C = '{' THEN STATE := CURLYBRACKET
            ELSE IF C = '''' THEN STATE := QUOTE
            ELSE IF C = '(' THEN (* possible left comment *) MAYBELC := TRUE;
            IF TI > 1 THEN BEGIN (* just finished an id *)
              (* place in xref table *) SEARCHP( ID);
              (* initialize the id accumulator *)  TI := 1; ID := '        '
              END
            END
          END; (* end LOOKING *)
        NEWLC: (* now in middle of a parenstar comment *) STATE := PARENSTAR;
        QUOTE: IF C = '''' THEN (* leave quoted string *) STATE := LOOKING;
        CURLYBRACKET: IF C = '}' THEN (* leave comment *) STATE := LOOKING;
        PARENSTAR: IF C = '*' THEN (* maybe end comment *) STATE := MAYBERC;
        MAYBERC: IF C = ')' THEN (* leave comment *) STATE := LOOKING
          ELSE IF C = '*' THEN (* still maybe end comment *) STATE := MAYBERC
          ELSE (* whoops, back inside the comment *) STATE := PARENSTAR
        END { case state }
      END { big for loop };
    IF CUTEND THEN (* end of call forces end of token *)
      IF TI > 1 THEN BEGIN
        SEARCHP( ID);  TI := 1;  ID := '        '  END
    END;
  (**************************************************************************)
  (*$G+*)

  FUNCTION DIRECTIVE( TPTR: INTEGER; TLENGTH: BINDX; VAR DIR: DIRRCD)
      : BOOLEAN;
    (* Check input buffer at TPTR, length TLENGTH for a directive, *)
    (* that is, a Pascal comment beginning with $ or CMDCHAR *)
    (* This is  a compiler directive ($) or format directive (CMDCHAR). *)
    (* The only $ directive accepted is "$I FILENAME", file inclusion. *)
    (* If found, TRUE is returned and DIR. set as follows: *)
    (*    DIR.DIRTYPE := '$' or CMDCHAR as the case may be *)
    (*    DIR.DIRCHAR := character following DIRTYPE, the actual directive *)
    (*    DIR.DIRSTR  := the string between DIRCHAR and end of the comment *)
    (* The routine is organized to waste as little time as possible on *)
    (* non-directives, hence the GOTOs *)
  LABEL 1; (* exit point *)
  VAR
    EPOS, SPTR: INTEGER;
    ESTR: STRING;
    CHK: RECORD CASE INTEGER OF  (* for string manipulation *)
      0: (CHKARR: PACKED ARRAY[ 0..255] OF CHAR);
      1: (CHKSTR: STRING[ 255])
      END;
    CHKLENGTH: INTEGER;

  BEGIN  WITH DIR, CHK DO BEGIN
    DIRECTIVE := FALSE; (* assume not a directive *)
    IF INCBUFF[ TPTR] = CHR( DLE) THEN BEGIN (* account for ident code *)
      TPTR := TPTR + 2;  TLENGTH := TLENGTH - 2  END;
    IF TLENGTH < 4 (* not long enough for anything useful *) THEN GOTO 1;
    IF INCBUFF[ TPTR] = '(' THEN BEGIN
      IF INCBUFF[ TPTR+1] = '*' THEN BEGIN (* have a paren-star comment *)
        IF TLENGTH < 6 THEN (* too short for paren-star directive *) GOTO 1;
        SPTR := TPTR + 2;  ESTR := '*)'  END
      ELSE (* false alarm, not paren-star *) GOTO 1
      END
    ELSE IF INCBUFF[ TPTR] = '{' THEN BEGIN (* have a curly bracket comment *)
      SPTR := TPTR + 1;  ESTR := '}'  END
    ELSE (* not a comment *) GOTO 1;
    (* have a comment; get type and check if acceptable *)
    DIRTYPE := INCBUFF[ SPTR];
    IF DIRTYPE = '$' THEN (* have a compiler directive *) BEGIN
      DIRCHAR := INCBUFF[ SPTR+1];  UCFOLD( DIRCHAR); (* get command char *)
      IF DIRCHAR = 'I' THEN (* possible incl *) BEGIN
        IF INCBUFF[ SPTR+2] IN ['+', '-'] THEN (* reject I+, I- *) GOTO 1
        END
      ELSE (* reject all $ directives but I *) GOTO 1
      END
    ELSE IF DIRTYPE = CMDCHAR THEN (* check for legal command *) BEGIN
      DIRCHAR := INCBUFF[ SPTR+1];  UCFOLD( DIRCHAR); (* get command char *)
      IF NOT (DIRCHAR IN CMDCHARSET) THEN GOTO 1
      END
    ELSE (* not a directive of either type *) GOTO 1;
    (* have acceptable directive; find end of comment with string search *)
    CHKLENGTH := TLENGTH + TPTR - SPTR - 2; (* length of remainder *)
    IF CHKLENGTH > 0 THEN
      MOVELEFT( INCBUFF[ SPTR+2], CHKARR[ 1], CHKLENGTH); (* set up string *)
    CHKARR[ 0] := CHR( CHKLENGTH); (* with length *)
    EPOS := POS( ESTR, CHKSTR); (* position of end of comment *)
    IF EPOS = 0 THEN (* no end-of-comment; forget it *) GOTO 1;
    DIRSTR := COPY( CHKSTR, 1, EPOS-1); (* extract the directive's text *)
    DIRECTIVE := TRUE; (* report success *)
    1: END END;
  (*$G-*)
  (**************************************************************************)

  PROCEDURE PUTLINE;
    (* Write line to printer file, directly from buffer if possible *)
  VAR
    N: INTEGER;
    CUTLINE: BOOLEAN;
    ORCD: RECORD CASE INTEGER OF (* for strng-lngth tricks *)
      1: (OBUFF: STRING[ 135]);
      2: (NBUFF: PACKED ARRAY[ 0..135] OF 0..255)
      END;
  BEGIN
    (* scan away nulls at beginning of line *)
    N := SCAN( TLENGTH, <>CHR( NULL), INCBUFF[ TPTR]);
    IF N < TLENGTH THEN BEGIN (* something other than nulls on the line *)
    BUMPLINE; (* count an output line *)
      (* Strip possible carriage return from tail of line *)
      (* and, indicate (CUTLINE) whether to scan ID's to next line *)
      IF INCBUFF[ TPTR+TLENGTH-1] = CHR( CR) THEN BEGIN
        WLENGTH := TLENGTH-1;  CUTLINE := TRUE  END
      ELSE BEGIN WLENGTH := TLENGTH; CUTLINE := FALSE  END;
      IF PRINTING THEN BEGIN (* actual output *)
        IF NUMBERING THEN WRITE( OUTFILE, LINENUMBER: LNUMWIDTH, ' ');
        IF UNITOUT THEN (* output to unit *) BEGIN
          UNITWRITE( PRINTUNIT, INCBUFF[ TPTR], WLENGTH)
          END
        ELSE WITH ORCD DO BEGIN (* output to a file *)
          MOVELEFT( INCBUFF[ TPTR], OBUFF[ 1], WLENGTH);
          NBUFF[ 0] := WLENGTH;  WRITE( OUTFILE, OBUFF)
          END
        END;
      IF XREFFING THEN (* scan and enter symbols in table *) SCANNER( CUTLINE);
      PUTCRLF (* carriage return to printer *)
      END
    END;
  (**************************************************************************)

  PROCEDURE GETLINE;
    (* Get an input line using BLOCKREAD. *)
    (* Variables set here for other routines to use in processing: *)
    (*   INCBUFF: input buffer, filled using BLOCKREAD; *)
    (*   TPTR: start of line in INCBUFF;  *)
    (*   TLENGTH: length of line. *)
    (* Variables used internally:
    (*   LEFTLENGTH: characters left to process in INCBUFF; *)
    (*   LINELENGTH: printer line length (now a constant 130) *)
    (*   TOSCAN: number of chars in INCBUFF to scan for CR *)
    (*   BLKLENGTH: length of INCBUFF data excluding trailing nulls *)
  VAR
    I, BLKLENGTH: INTEGER;
    TOSCAN: BINDXZ;
  BEGIN
    TPTR := TPTR + TLENGTH; (* hop over the previous line *)
    LEFTLENGTH := BUFFLENGTH - TPTR + 1; (* adjust LEFTLENGTH accordingly *)
    IF LEFTLENGTH <= LINELENGTH THEN BEGIN
      (* not enough chars in buffer for a full print line *)
      IF LEFTLENGTH > 0 THEN (* scrunch remaining chars to front of buffer *)
        MOVELEFT( INCBUFF[ TPTR], INCBUFF[ 1], LEFTLENGTH);
      (* read new bufferfull from input file *)
      REPEAT
        IF EOF( INFILE) THEN BEGIN (* fill remainder with nulls *)
          FILLCHAR( INCBUFF[ LEFTLENGTH+1], 512, CHR( NULL));
          LASTPTR := LEFTLENGTH;  BLKLENGTH := 512  END
        ELSE BEGIN (* read a block from input file *)
          (*$I-*)
          I := BLOCKREAD( INFILE, INCBUFF[ LEFTLENGTH+1], 1, BLOCKNUM);
          (*$I+*)
          IOERR:=IORESULT;
          GLOBLOCK := BLOCKNUM; (* for homebrew err msgs *)
          BLOCKNUM := BLOCKNUM + 1;
          IF (I <> 1) OR (IOERR > 0) THEN IOE( IOERR, FNAME);
          (* set blocklength, omit trailing nulls *)
          BLKLENGTH :=
            512 + SCAN( -512, <>CHR( NULL), INCBUFF[ LEFTLENGTH + 512])
          END
        UNTIL ( BLKLENGTH > 0) OR EOF( INFILE);
      (* show a new buffer *)
      TPTR := 1; BUFFLENGTH := BLKLENGTH + LEFTLENGTH;
      LEFTLENGTH := BUFFLENGTH;
      END;
    (* now have buffer with at least one printer line's worth in it *)
    (*   (or end of file ) *)
    (* scan for carriage return and set TLENGTH *)
    IF LEFTLENGTH < LINELENGTH THEN TOSCAN := LEFTLENGTH
    ELSE TOSCAN := LINELENGTH;
    TLENGTH := 1 + SCAN( TOSCAN, =CHR( CR), INCBUFF[ TPTR]);
    NOMORE := (TPTR + TLENGTH > LASTPTR) (* indicate if end of file *)
    END;
  (**************************************************************************)
  PROCEDURE DOCMD( CMD: DIRRCD);
    (* Carry out a formatting directive (CMD) set up by DIRECTIVE *)
  VAR
    NTOSKIP: INTEGER; (* how many to skip for 'S' *)
    CLEANSTR: BIGSTRING;  (* for stripped operand string *)
  BEGIN WITH CMD DO BEGIN
    (* set up stripped operand string *)
    CLEANSTR := DIRSTR;  STRIPSTRING( CLEANSTR);
    IF DIRCHAR = 'H' THEN BEGIN (* header directive *)
        (* H+ ==> turn on standard title headers (default) *)
        (* H- ==> turn off headers altogether *)
        (* H string ==> use string as a header *)
      IF DIRSTR = '+' THEN BEGIN  HDRS := TRUE;  TITLEHDRS := TRUE  END
      ELSE IF DIRSTR = '-' THEN BEGIN  HDRS := FALSE  END
      ELSE BEGIN
        HDRS := TRUE;  TITLEHDRS := FALSE;
        (* use unstripped directive operand as header *) HEADER := DIRSTR;
        (* except for one possible leading space *)
        IF LENGTH( HEADER) > 0 THEN IF HEADER[ 1] = ' ' THEN
          DELETE( HEADER, 1, 1)
        END
      END (* case 'H' *)
    ELSE IF DIRCHAR = 'S' THEN BEGIN (* skip directive: S ntoskip *)
      IF CLEANSTR = '' THEN CLEANSTR := '1';
      NTOSKIP := STRTON( CLEANSTR); (* convert to number *)
      IF (NTOSKIP > PAGELINES) OR (NTOSKIP < 0) THEN (* error *)
        PRINTIT := TRUE (* give up and just print it *)
      ELSE SKIP( NTOSKIP * SPACING) (* skip, accounting for scurrent spacing *)
      END (* case 'S' *)
    ELSE IF DIRCHAR = 'P' THEN BEGIN (* page skip *)
      IF CLEANSTR = '' THEN TOPOFPAGE  ELSE PRINTIT := TRUE
      END (* case 'P' *)
    END END;
  (**************************************************************************)

BEGIN (* PFILE *)
  IF NOT FILECHECK( FNAME) THEN BEGIN
    MSG( 'File: ', 1);  WRITE( FNAME, ' cannot be opened');
      EXIT( PRXREF)  END;
  CLOSE( INFILE); RESET( INFILE, FNAME);
  (* set name and numbering for included file *)
  LNAME := FNAME;  LPAGE := 1;
  IF INCLSKIPPING THEN TOPOFPAGE;  FININCL := FALSE;
  (* initialize variables for GETLINE *)
  BLOCKNUM := 2;  LASTPTR := BUFFMAX;
  BUFFLENGTH := 1;  TPTR := BUFFLENGTH + 1;  TLENGTH := 0;
  IF XREFFING THEN (* initialize variables for SCANNER *) BEGIN
    TI := 1;  ID := '        ';  (* accumulator for identifiers *)
    STATE := LOOKING;  MAYBELC := FALSE;  (* state variables *)
    PROCFLAG := FALSE  (* proc/func kw flag *)
    END;
  (* main file read/print loop -- GETLINE and PUTLINE until end of file *)
  REPEAT
    GETLINE;  LINENUMBER := LINENUMBER + 1;
    (* account for indent code on the line *)
    IF INCBUFF[ TPTR] = CHR( DLE) THEN STPTR := TPTR + 2
    ELSE STPTR := TPTR;
    PRINTIT := TRUE; (* assume line will be printed *)
    (* check for compiler directive or format comment *)
    IF DIRECTIVE( TPTR, TLENGTH, DIR) THEN WITH DIR DO BEGIN (* directive *)
      PRINTIT := FALSE; (* line probably won't be printed (could be wrong) *)
      IF DIRTYPE = '$' THEN (* compiler directive -- include *) BEGIN
        IF INCLU THEN (* including is enabled *) BEGIN
          IF DIRCHAR = 'I' THEN (* just double-checking for $I *) BEGIN
            STRIPSTRING( DIRSTR); (* strip blanks *)
            INCNAME := DIRSTR;  (* this is include file's name *)
            MSG( 'included file: ', 1);  WRITE( INCNAME);
            LINENUMBER := LINENUMBER - 1; (* adjust for compiler numbering *)
            (* recursively print the included file *)
            PFILE( INCNAME);
            IF ESCAPING THEN (* keep getting out of PFILE *) EXIT( PFILE);
            LNAME := FNAME;  FININCL := TRUE;
            LINENUMBER := LINENUMBER + 1; (* adjust for compiler numbering *)
            MSG( ' ', 1);
            END
          END
        END
      ELSE IF DIRTYPE = CMDCHAR THEN (* format directive *) BEGIN
        IF VFORMATTING THEN (* its enabled; do the command  *) DOCMD( DIR)
        ELSE (* not enabled; just print the line *) PRINTIT := TRUE
        END
      END;
    IF PRINTIT THEN (* line to be printed as-is *) BEGIN
      IF FININCL THEN BEGIN  (* finish up include with page skip *)
        FININCL := FALSE; TOPOFPAGE END;
      PUTLINE (* print the line *)
      END;
    (* check user hit on keyboard with escape *)
    IF ESCAPEHIT THEN EXIT( PFILE)
    UNTIL (* GETLINE says *) NOMORE
  END; {pfile}


========================================================================================
DOCUMENT :usus Folder:VOL07:prxref.tbl.text
========================================================================================

(**********************************************)
(* PRXREF.TBL -- for USUS -- 1980 July 14     *)
(*  Bug fixed in PRINTWORD, 1980 Oct 13, JLG  *)
(**********************************************)

SEGMENT PROCEDURE INITXREF;  FORWARD;
  (* initializes the cross-reference with keywords, etc. *)

(**************************************************************************)

SEGMENT PROCEDURE PRINTTABLE ( WHAT: PTABLETYPE);
  (* output all or part of the cross-reference table *)
  (* WHAT = PRINT ==> entire tbl from memory to output file/vol *)
  (* WHAT = DISK  ==> fragment in memory to overflow file *)
  (* WHAT = MERGE ==> merge and output the fragments overflowed *)
TYPE
  HARRAY = ARRAY[ INDEX] OF WORD;  (* for the hash hdr table *)
VAR
  I, M: INDEX;
  HI: HUNKQINDEX;
  DRSIZE: INTEGER; (* for SIZEOF( DRCDS) *)
  NUMSYMS, NUMREFS: INTEGER; (* number of pgmr's symbols and refs to them *)
  HOLDSPACING: INTEGER; (* so spacing can be restored after setting to 1 *)
  (********************************************************************)

  PROCEDURE COMPACT( VAR T: HARRAY; VAR N: INDEX);
    (* compact the spread-out hash table preparatory to sort *)
  VAR
    I: INDEX;
  BEGIN
    N := 0;
    FOR I := 0 TO P DO WITH T[ I] DO BEGIN
      IF KEY <> '        ' THEN IF FIRST <> NIL THEN BEGIN
        (* slide this entry backwards *)
        T[ N] := T[ I];  N := N + 1  END
      END
    END;
  (*********************************************************************)

  PROCEDURE TSORT( VAR A: HARRAY;  VAR N: INDEX);
    (* good ole quicksort -- more-or-less from Conway & Gries *)
    (* sorts hash table A by key for printout or write to disk *)
  VAR
    LOWER, UPPER: ARRAY[ INDEX] OF INTEGER;
    COUNT, L, U, M, K, NJ: INTEGER;
    TEMPA: WORD;

  BEGIN (* TSORT *)
    MSG( ' sorting', 1);
    COMPACT( T, N);  (* compact the array first *)
    LOWER[ 1] := 0;  UPPER[ 1] := N-1;  M := 1;  COUNT := 50;
    WHILE M <> 0 DO BEGIN
      IF ESCAPEHIT THEN (* user requests escape *) EXIT( PRINTTABLE);
      IF COUNT >= 50 THEN BEGIN  COUNT := 0;  WRITE( '.')  END
      ELSE COUNT := COUNT + 1;
      L := LOWER[ M];  U := UPPER[ M];  M := M - 1;
      IF U = L + 1 THEN BEGIN
        IF A[ L].KEY > A[ U].KEY THEN BEGIN
          TEMPA := A[ L];  A[ L] := A[ U];  A[ U] := TEMPA  END
        END
      ELSE IF U > L + 1 THEN BEGIN
        NJ := L + 1;  K := U;
        WHILE NJ <= K DO BEGIN
          IF A[ NJ].KEY <= A[ L].KEY THEN NJ := NJ + 1
          ELSE BEGIN;
            WHILE A[ K].KEY > A[ L].KEY  DO K := K - 1;
            IF NJ < K THEN BEGIN
              TEMPA := A[ NJ];  A[ NJ] := A[ K];  A[ K] := TEMPA;
              NJ := NJ + 1;  K := K - 1  END
            END
          END;
        TEMPA := A[ L];  A[ L] := A[ K];  A[ K] := TEMPA;
        IF U - K > K - L THEN BEGIN
          M := M + 1;  LOWER[ M] := K + 1;  UPPER[ M] := U  END;
        M := M + 1;  LOWER[ M] := L;  UPPER[ M] := K - 1;
        IF U - K <= K - L THEN BEGIN
          M := M + 1;  LOWER[ M] := K + 1;  UPPER[ M] := U  END
        END
      END
    END;
    (**************************************************************************)

    PROCEDURE PRINTREF( NEXTREF: INTEGER);
      (* print a reference *)
    BEGIN
      IF NEXTREF <> PROCCODE THEN  BEGIN
        NUMREFS := NUMREFS + 1;  WRITE( OUTFILE, NEXTREF: 5)  END
      ELSE (* just a flag for a proc/func *) WRITE( OUTFILE, '<----')
      END;
    (**************************************************************************)

  PROCEDURE PRINTWORD( W: WORD);
    (* print an id and all its references *)
  VAR
      L: INTEGER;
      X: ITEMPTR;
      NEXTREF : INTEGER;
      THISREF: REFINDEX;
  BEGIN
    IF W.FIRST <> NIL THEN BEGIN (* have non-keyword *)
      WRITE( OUTFILE, W.KEY: SYMPRLENGTH);  (* print symbol *)
      NUMSYMS := NUMSYMS + 1;  (* count a programmer's symbol *)
      (* print its references *)
      X := W.FIRST;  L := 0;  (* point to first ref; init horizontal counter *)
      REPEAT    {bug fix per author made next 2 lines, 13 Oct 1980, J. Gagne}
        IF L MOD REFSPERLINE = REFSPERLINE -1 (* start another print line *)
          THEN BEGIN SKIP(1);  WRITE( OUTFILE, ' ': SYMPRLENGTH) END;
        L := L+1; (* count another ref across *)
        (* go to next reference *)
        THISREF := (L-1) MOD REFSPERITEM + 1;
        NEXTREF := X^.REF[ THISREF]; (* next ref in this array *)
        IF THISREF = X^.REFNUM  THEN X := NIL (* indicate done *)
        ELSE  IF THISREF = REFSPERITEM THEN X := X^.NEXT; (* next array *)
        PRINTREF( NEXTREF)
        UNTIL X = NIL;
      SKIP(1);
      END
    END;
  (**************************************************************************)

  PROCEDURE SK;  BEGIN  SKIP(1)  END;
  (**************************************************************************)

  PROCEDURE DWRITE;
    (* write the current xref table to a hunk of disk *)
  VAR
    D: DRCDS; (* to assemble a file rcd *)
    I, NR, NREFS, R: INTEGER;
    RPTR, NEXTRPTR: ITEMPTR;
    DONE: BOOLEAN;
    M: INDEX;
  (**********************************)

  PROCEDURE DPUT( D: DRCDS);
    (* actual PUT of xref rcd to disk overflow file *)
  BEGIN
    DF^ := D;
    (*$I-*)  PUT( DF);  IOERR := IORESULT;  (*$I+*)
    IF IOERR = 8 THEN BEGIN
      MSG( 'No room on disk for overflow.', 2);
      WRITE( '  Xref aborted; input block ', GLOBLOCK, '.');
      XREFFING := FALSE;
      IF PRINTING THEN BEGIN
        WRITE( '  Print continues.');  EXIT( DWRITE)  END
      ELSE EXIT( PRXREF)
      END
    ELSE IF IOERR <> 0 THEN BEGIN (* other I/O error *)
      IOE( IOERR, 'Xref overflow');  EXIT( PRXREF)  END;
    (* count another rcd;  reset ref-within-rcd counter *)
    DFCOUNT := DFCOUNT + 1;  NR := 1
    END;
  (**********************************)

  PROCEDURE DPUTREF( RLN: INTEGER);
    (* write a single ref entry; if array fills, put it to disk *)
  BEGIN
    D.REF[ NR] := RLN;  NR := NR + 1; (* place it in array *)
    IF NR > DREFSPER THEN (* put to disk *) DPUT( D);
    END;
  (**********************************)

  BEGIN (* DWRITE *)
    MSG( 'xref overflow to disk; hunk #', 2);  WRITE( NHUNKS+1, ';');
    IF NHUNKS = 0 THEN BEGIN (* initial hunk; open file, initialize *)
      CLOSE( DF); REWRITE( DF, ',,DF.DFDF.DFDFZ');  DFCOUNT := 0  END;
    (* record statistics; count hunks *)
    HUNKSTART[ NHUNKS] := DFCOUNT;  NHUNKS := NHUNKS + 1;
    TSORT( T, M); (* sort the present xref table *)
    WRITE('; writing');
    HUNKLINE[ NHUNKS] := LINENUMBER;
    FOR I := 0 TO M-1 DO BEGIN (* write each symbol's entry to file *)
      IF ESCAPEHIT THEN (* user requests escape *) EXIT( PRINTTABLE);
      IF I MOD 50 = 25 THEN WRITE('.');
      (* write the record with the symbol *)
      D.JUNK := 0;  D.KEY := T[ I].KEY;  DPUT( D);
      (* write the record(s) with the line number references *)
      RPTR := T[ I].FIRST;  DONE := FALSE;
      REPEAT
        IF RPTR = T[ I].LAST THEN BEGIN (* last piece of refs *)
          NREFS := RPTR^.REFNUM; (* might not be a full array of refs *)
          DONE := TRUE
          END
        ELSE BEGIN (* not last piece; sure to be full *)
          NEXTRPTR := RPTR^.NEXT;  NREFS := REFSPERITEM  END;
        (* put all the references in this piece *)
        FOR R := 1 TO NREFS DO DPUTREF( RPTR^.REF[ R]);
        RPTR := NEXTRPTR (* point to next piece *)
        UNTIL DONE;
      (* pad out with some end codes *)
      FOR R := 1 TO DREFSPER DO DPUTREF( EREFCODE)
      END;
    HUNKSTART[ NHUNKS] := DFCOUNT;  (* hunk statistics *)
    MSG( ' ', 2)
    END;
  (*****************************************************************)

  PROCEDURE DMERGE;
    (* merge and print the xref hunks put on file *)
  TYPE
    (* merge buffer template *)
    HBUFFINDEX = 0..HBUFFSIZE;
    BUFFRCD = RECORD
      BUFF: ARRAY[ HBUFFINDEX] OF DRCDS;
      NEXT, LAST: HBUFFINDEX; (* point to next-to-process, last-in-buff *)
      DCTR: INTEGER; (* location on disk for this hunk *)
      NOTFINI: BOOLEAN  (* indicates if hunk is exhausted *)
      END;
  VAR
    HI, MINSPOT: HUNKPINDEX;
    NOMORE: BOOLEAN;
    MINSOFAR, MAXALFA, LOOKKEY, LASTKEY: ALFA;
    I, REFCOUNT: INTEGER;
    BUFFSTUFF: ARRAY[ HUNKPINDEX] OF BUFFRCD; (* merge buffers *)
  (*****************************************************************)

  PROCEDURE FILLBUFF( HI: HUNKPINDEX);
    (* fill merge buffer when it empties *)
  VAR
    DI: HBUFFINDEX;
  BEGIN  WITH BUFFSTUFF[ HI] DO BEGIN
    WRITE( '.');
    IF DCTR >= HUNKSTART[ HI] THEN BEGIN (* this hunk exhausted *)
      (* tell DMERGE that *) NOTFINI := FALSE  END
    ELSE BEGIN (* fill buffer *)
      (* find correct hunk in file *) SEEK( DF, DCTR);  DI := 0;
      (* read stuff into buffer *)
      WHILE ( DCTR < HUNKSTART[ HI]) AND ( DI < HBUFFSIZE) DO BEGIN
        GET( DF);  DI := DI + 1;  DCTR := DCTR + 1;  BUFF[ DI] := DF^  END;
      (* set pointers to last rcd in buff; next rcd in buff to process *)
      LAST := DI;  NEXT := 1;  NOTFINI := TRUE
      END;
    END  END;
  (*****************************************************************)

  PROCEDURE BUMPBUFF( HI: HBUFFINDEX);
    (* proceed to next rcd in buffer, filling from disk first if necessary *)
  BEGIN  WITH BUFFSTUFF[ HI] DO BEGIN
    IF NEXT >= LAST THEN  (* no more rcds to process in buff *)
      (* so read some more *) FILLBUFF( HI)
    ELSE (* just look at the next rcd in buff *) NEXT := NEXT + 1
    END END;
  (*****************************************************************)

  PROCEDURE MPRINTREF( HI: HUNKPINDEX);
    (* when merging, print the id and reference at front of buffer HI *)
  VAR
    THISREF, RI: INTEGER;
    REFSDONE: BOOLEAN;
  BEGIN WITH BUFFSTUFF[ HI] DO BEGIN
    IF BUFF[ NEXT].KEY <> LASTKEY THEN (* this id different than last *) BEGIN
      LASTKEY := BUFF[ NEXT].KEY; (* record id for next round's test *)
      (* start new line and print the id *)
      SKIP( 1);  WRITE( OUTFILE, LASTKEY:9);  REFCOUNT := 0;
      NUMSYMS := NUMSYMS + 1;  (* count a pgmr's symbol *)
      END;
    REPEAT (* process each array of references *)
      BUMPBUFF( HI);  RI := 1;  REFSDONE := FALSE;
      REPEAT  WITH BUFF[ NEXT] DO BEGIN (* process single reference *)
        THISREF := REF[ RI];
        IF THISREF = EREFCODE THEN (* have a end-of-refs flag *)
          REFSDONE := TRUE
        ELSE BEGIN (* have a real reference *)
          IF REFCOUNT >= REFSPERLINE THEN BEGIN (* new print line *)
            REFCOUNT := 0;  SKIP( 1);  WRITE( OUTFILE, ' ': 9)  END;
          (* print the ref and bump array and printline counters *)
          PRINTREF( THISREF); REFCOUNT := REFCOUNT + 1;  RI := RI + 1
          END
        END UNTIL ( RI > DREFSPER) OR REFSDONE
      UNTIL REFSDONE;
    BUMPBUFF( HI) (* set up next thing in buffer for merging *)
    END END;
  (*****************************************************************)

  BEGIN  (* DMERGE *)
    MSG( 'merging xref hunks from disk', 2);
    (* set up maximal symbol for merge runout *)
    FOR I := 1 TO ALFALEN DO MAXALFA[ I] := CHR( ORD( 'Z') + 1);
    (* fill all merge buffers initially *)
    FOR HI := 1 TO NHUNKS DO WITH BUFFSTUFF[ HI] DO BEGIN
      DCTR := HUNKSTART[ HI-1];  FILLBUFF( HI)  END;
    LASTKEY := MAXALFA;
    (* merge loop; until all is printed *)
    REPEAT
      IF ESCAPEHIT THEN (* user requests escape *) EXIT( PRINTTABLE);
      NOMORE := TRUE;  MINSOFAR := MAXALFA;
      FOR HI := 1 TO NHUNKS DO WITH BUFFSTUFF[ HI] DO BEGIN
        (* locate buffer with minimum key *)
        IF NOTFINI THEN BEGIN
          NOMORE := FALSE;  LOOKKEY := BUFF[ NEXT].KEY;
          IF MINSOFAR > LOOKKEY THEN BEGIN
            MINSOFAR := LOOKKEY;  MINSPOT := HI  END
          END
        END;
      IF NOT NOMORE THEN BEGIN (* print the minimum element; bump buffer *)
        MPRINTREF( MINSPOT)  END
      UNTIL NOMORE
    END;
  (*****************************************************************)
  PROCEDURE SHOWSTATS;
  VAR
    I: INTEGER; (* misc index work vbl *)
  BEGIN
    DRSIZE := SIZEOF( DRCDS);
    SKIP( 2); WRITE( OUTFILE, LINENUMBER: 5, ' Lines');
    SK; WRITE( OUTFILE, NUMSYMS: 5, ' Programmer''s symbols');
    SK; WRITE( OUTFILE, NUMREFS: 5,
      ' Programmer''s symbol usages (including declarations)');
    SK; WRITE( OUTFILE, NUMKWREFS: 5,
        ' Keyword usages');
    SK; WRITE( OUTFILE, (NUMKWREFS + NUMREFS): 5,
        ' Total symbol usages');
    IF NHUNKS > 0 THEN BEGIN  (* disk usage stats *)
      SK; SK; WRITE( OUTFILE, NHUNKS:5, ' Hunks of disk memory used');
      SK; WRITE( OUTFILE, TRUNC(0.999+((DFCOUNT-1)*DRSIZE)/512.0): 5,
          ' Blocks of disk used (512 bytes/block)');
      SK; SK; WRITE( OUTFILE,
          '     HUNK  START--END (RCD #)    START--END (LINE #)');
      HUNKLINE[ 0] := 1;
      FOR I := 1 TO NHUNKS DO BEGIN
        SK; WRITE( OUTFILE, I:8, HUNKSTART[ I-1]:7, HUNKSTART[ I]-1: 6);
            WRITE( OUTFILE, ' ':11, HUNKLINE[ I-1]:5, HUNKLINE[ I]: 6);
        END
      END
    END; (* SHOWSTATS *)
(*****************************************************************)

BEGIN (* PRINTTABLE *)
  HOLDSPACING := SPACING;  SPACING := 1;  (* single space the xref *)
  NUMSYMS := 0;  NUMREFS := 0;  (* initialize statistics *)
  IF WHAT = DISK THEN BEGIN (* write present table to disk *)
    DWRITE; (* write it *)
    RELEASE( HEAPPOINT);  MARK( HEAPPOINT); (* reclaim heap *)
    INITXREF (* initialize xref for next disk hunk *)
    END
  ELSE BEGIN  (* either merge and print from disk or just print xref *)
    (* show in xref; fix page numbering, new page *)
    INXREF := TRUE;  LPAGE := 1;  TOPOFPAGE;
    IF WHAT = MERGE THEN DMERGE (* merge xref hunks from disk and print *)
    ELSE IF WHAT = PRINTER THEN BEGIN  (* sort and print non-disk xref *)
      TSORT( T, M);  WRITE(' printing xref');
      FOR I := 0 TO M-1 DO BEGIN
      IF ESCAPEHIT THEN (* user requests escape *) EXIT( PRINTTABLE);
      IF I MOD 20 = 10 THEN WRITE('.'); PRINTWORD( T[ I])  END
      END;
    SHOWSTATS
    END;
  SPACING := HOLDSPACING  (* restore spacing from single *)
  END; (*PRINTTABLE*)
(**************************************************************************)


========================================================================================
DOCUMENT :usus Folder:VOL07:prxref.text
========================================================================================

(************************************************************************)
(*                                                                      *)
(* PRXref -- Pascal program printer and cross-referencer                *)
(*                                                                      *)
(* Version 2.0 -- 1980 July                                             *)
(*   submitted to UCSD Pascal System Users Society, 1980 July 14        *)
(*                                                                      *)
(* program and documentation written by David J. Lewis                  *)
(*                                                                      *)
(*        Digicomp Research Corporation,                                *)
(*        Terrace Hill,                                                 *)
(*        Ithaca, N.Y. 14850                                            *)
(*        607-273-5900                                                  *)
(*    and                                                               *)
(*        Department of Mathematics,                                    *)
(*        Ithaca College,                                               *)
(*        Ithaca, N.Y.  14850                                           *)
(*        607-274-3108                                                  *)
(*                                                                      *)
(* Copyright (C) 1980, David J. Lewis                                   *)
(*                                                                      *)
(* Permission is granted to use and copy this program and its           *)
(* documentation under the terms of the UCSD Pascal Users' Group        *)
(* as of 1980 July 14.  Use or copying of this program or               *)
(* documentation under any other circumstances or terms is              *)
(* prohibited without the prior, written consent of the author.         *)
(* In particular, any resale or distribution for profit is prohibited.  *)
(*                                                                      *)
(* "UCSD Pascal" is a registered trademark of the Regents of the        *)
(*  University of California.                                           *)
(*                                                                      *)
(************************************************************************)
(*#P*)
PROGRAM PRXREF;

LABEL
  2; (* for escaping upon keyboard request *)

CONST

  (* constants describing and controlling printer output *)
  PAGELINES = 66; (* lines per printed page *)
  TOPMARGIN = 2; (* margin above header *)
  BOTMARGIN = 4; (* margin at bottom of page *)
  HEADERMARGIN = 1; (* margin after header *)
  HEADERSIZE = 80; (* columns in hdr *)
  HEADERCHAR = '-'; (* character for header separater *)
  LNUMWIDTH = 5; (* cols for line number print *)
  LINELENGTH = 130; (* total print columns *)
  NUMPRNULLS = 0; (* how many nulls to send on CR to printer *)
  REFSPERLINE = 14; (* refs per print line; 14 is right for 80 columns *)
  SYMPRLENGTH = 8; (* width of printed symbol *)
  INITPAGE = 1;  (* initial page number *)
  PRFORMFEED = 0; (* printer form feed char (0 ==> it has none) *)

  (* miscellaneous ascii characters *)
  BS = 8; DLE = 16;  CR = 13;  NULL = 0;  ETX = 3; ESC = 27; BELL = 7;

  (* locations of items on the display; the picture: *)

  (*  +---------------------------------------------+                *)
  (*  | prompt line                                 | <--PRROW       *)
  (*  |                                             |                *)
  (*  |   option       :response    error message   | <--PRROWA      *)
  (*  |   option       :response    error message   |                *)
  (*  |    .             .           .              |                *)
  (*  |     .             .           .             |                *)
  (*  |      .             .           .            |                *)
  (*  |   option       :response    error message   |                *)
  (*  |                                             | <--PRGAP lines *)
  (*  | message: main file name & copy count        |      here      *)
  (*  | message: included file name                 |                *)
  (*  | miscellaneous messages                      |                *)
  (*  |                                             |                *)
  (*  +---------------------------------------------+                *)
  (*    ^PRCOL                                                       *)
  (*      ^PRCOLA      ^PRCOLB      ^PRCOLC                          *)

  PRCOL  = 0;  (* column for prompt line and messages *)
  PRCOLA = 2;  (* column for options *)
  PRCOLB = 17; (* column for colon for user response *)
  PRCOLC = 36; (* column for option error messages *)
  PRROW  = 0;  (* row for prompt *)
  PRROWA = 2;  (* top row of options *)
  PRGAP  = 1;  (* gap between bottom option and 3 lines for messages *)
  (* These values should fit on a 18 x 64 screen. *)
  (* Those unfortunates with only 16 lines should set PRROWA=1; PRGAP=0. *)

  (* minimum dimensions of display; to be checked against SYSTEM.MISCINFO *)
  MINSCRWIDTH = 64;  MINSCRHEIGHT = 18;

  (* constants describing the scatter storage table and hash headers *)
  P  = 863; (* size of hash table; must be a prime number *)
  ALFALEN  =  8; (* characters per identifier *)
  REFSPERITEM =  5; (* # refs in a table item *)

  (* constants controlling shape of xref overflow to disk *)
  DREFSPER = 5; (* # refs per item in disk overflow *)
  MAXNHUNKS = 10; (* maximum number of hunks overflowed to disk *)
  HBUFFSIZE = 100; (* size of merge buffer to process disk overflow *)
  MEMTHRESH = 600; (* ovflow xref when <= MEMTHRESH bytes left in stack/heap *)
  LOADFACTOR = 0.9; (* overflow xref when table is this fraction full *)
  INTSPERALFA = 4; (* num of integers in 8 bytes *)

  (* codes to enter in xref indicating a keyword and proc/func *)
  KWCODE = -9998;  PROCCODE = -9999;
  EREFCODE = -9997; (* code to mark end of disk xref item *)

  BUFFMAX = 647; (* 512+linelength+3 (for indent, CR): buffer size needed *)
                 (* ok to leave this large; now accomodates 132 char line *)
TYPE

  (* input buffer *)
  BINDX = 1..BUFFMAX; BINDXZ = 0..BUFFMAX;
  BUFFER = PACKED ARRAY[ BINDX] OF CHAR;

  (* scatter storage table types *)
  ALFA = PACKED ARRAY[ 1..ALFALEN] OF CHAR; (* for identifiers *)
  INDEX = 0..P; (* index for hash table *)
  ITEMPTR = ^ITEM;
  WORD = RECORD (* hash table entry *)
    KEY: ALFA; (* the identifier its very self *)
    FIRST, LAST: ITEMPTR; (* point to chain of item arrays *)
    END ;
  REFINDEX = 1..REFSPERITEM;
  REFTYPE = ( COUNT, PTR);
  ITEM = RECORD (* array of references; link these together *)
    REF: ARRAY[ REFINDEX] OF INTEGER; (* the array *)
    CASE REFTYPE OF
       COUNT: ( REFNUM: REFINDEX); (* size of array *)
       PTR: ( NEXT: ITEMPTR) (* or a pointer to next item array *)
    END;

  (* disk records for xref overflow *)
  HUNKPINDEX = 1..MAXNHUNKS;
  HUNKQINDEX = 0..MAXNHUNKS;
  DINDEX = 1..DREFSPER;
  DRCDS = RECORD CASE BOOLEAN OF (* a disk record *)
    TRUE: ( JUNK: INTEGER;  KEY: ALFA);
    FALSE: ( REF: ARRAY[ DINDEX] OF INTEGER)
    END;

  PTABLETYPE = ( PRINTER, DISK, MERGE); (* instruct PRINTTABLE *)
  BIGSTRING = STRING[ 255];
  CTLSTRING = STRING[ 13]; (* for ERASEEOL and ERASEEOS's strings *)

VAR

  (* output file names *)
  PRINTUNIT: INTEGER; PRINTTITLE: STRING;
  UNITOUT: BOOLEAN; (* true ==> output to a unit; false ==> to a file *)

  (* variables for user options         *)
  (* PRINTING     <==> P(rinting: Yes   *)
  (* XREFFING     <==> X(ref: Yes       *)
  (* INCLU        <==> I(nclude: Yes    *)
  (* PAGESKIP     <==> S(kip pages: Yes *)
  (* SPACING       =   L(ine spacing    *)
  (* NUMBERING    <==> N(umbering: Yes  *)
  (* INCLSKIPPING <==> K( inclsKip: Yes *)
  (* TIMES         =   #( of copies     *)
  (* CMDCHAR       =   C(ommand char    *)
  (* VFORMATTING  <==> V(ert format: Yes*)

  INCLSKIPPING, PRINTING, NUMBERING, XREFFING: BOOLEAN;
  VFORMATTING, INCLU, PAGESKIP: BOOLEAN;
  SPACING, TIMES: INTEGER;
  CMDCHAR: CHAR;

  (* scatter storage variables *)
  T: ARRAY [ INDEX] OF WORD; (* hash header table *)
  TOP: INDEX; (* top of chain linking all entries in T *)

  (* stuff for statistics *)
  NUMKWREFS: INTEGER; (* total number of kw references *)
  LNUMENTRIES: INTEGER; (* local to a hunk: # tbl entries, kws *)

  (* stuff for overflow to disk *)
  DF: FILE OF DRCDS; (* file for xref overflow *)
  NHUNKS: HUNKQINDEX; (* counts disk hunks in DF *)
  DFCOUNT: INTEGER; (* counts records put to DF *)
  HEAPPOINT: ^INTEGER; (* for cutting back heap after writing disk hunk *)
  MAXNUMENTRIES: INTEGER; (* overflow to disk when # entries exceeds this *)
  (* record and line numbers delimitting disk hunks *)
  HUNKSTART, HUNKLINE: ARRAY[ HUNKQINDEX] OF INTEGER;
  GLOBLOCK: INTEGER;  (* to report block num in PUT error *)

  (* misc vbls controlling printed output *)
  OUTFILE: TEXT;  (* output file (if not a unit) *)
  CURLINE: INTEGER; (* where on page are we printing now *)
  NULLS: PACKED ARRAY[ 0..NUMPRNULLS] OF CHAR;  (* for printer nulls *)
  LINENUMBER: INTEGER; (* line number in file, for output *)
  FININCL: BOOLEAN; (* helps control include page skipping *)
  PRINTLAST: INTEGER;  (* last print line to print on before page eject *)
  FIRSTPAGE: BOOLEAN; (* ==> first page not printed yet, for page eject *)

  (* misc vbls for print heading *)
  LPAGE, GPAGE: INTEGER; (* for print page numbering *)
  HEADER: STRING; (* for print headers *)
  HEADERSEP: STRING[ HEADERSIZE]; (* separator after standard header *)
  TITLEHDRS, HDRS: BOOLEAN; (* control type of hdrs *)
  TODAY: STRING; (* today's date -- printable *)

  (* misc main prog and global work vbls *)
  MAINNAME, LNAME: STRING;  (* input file and included file names *)
  INXREF: BOOLEAN; (* ==> in xref phase of pgm *)
  REPETITION: INTEGER; (* for repeating file processing TIMES times *)
  IOERR: INTEGER; (* for reporting i/o errors *)
  C: CHAR; (* for kb hit checking *)
  MSGLINE: INTEGER; (* where on display for msgs *)
  CMDCHARSET: SET OF CHAR; (* for checking format directives *)
  EOLSTRING, EOSSTRING: CTLSTRING; (* for ERASEEOL, -EOS *)
  ESCAPING: BOOLEAN; (* ==> keyboard escape requesting abort *)
  GOAHEAD: BOOLEAN; (* kludge for escape and finish up skip *)

(**************************************************************************)

PROCEDURE SKIP( NUM: INTEGER);  FORWARD; (* line skip *)
PROCEDURE TOPOFPAGE;  FORWARD;  (* page eject *)
PROCEDURE ERASEEOL;  FORWARD;  (* erase display to end of line *)
PROCEDURE ERASEEOS;  FORWARD;  (* ...ditto end of screen *)
PROCEDURE SEARCH( IDX: ALFA);  FORWARD; (* xref tbl lookup/enter *)
FUNCTION FILECHECK( VAR S: STRING): BOOLEAN;  FORWARD; (* check input file *)
PROCEDURE UCFOLD( VAR C: CHAR);  FORWARD; (* fold lower case to upper *)
PROCEDURE MSG( S: STRING; L: INTEGER);  FORWARD; (* display message *)
PROCEDURE IOE( I: INTEGER;  S: STRING); FORWARD; (* i/o err msg and abort *)
FUNCTION ESCAPEHIT: BOOLEAN; FORWARD;  (* checks KB, holds up, T iff esc *)

(*$I PRXREF.TBL*)
(*$I PRXREF.OPT*)
(*$I PRXREF.INI*)
(*$I PRXREF.UTL*)
(*$I PRXREF.PFI*)

(*******************************************************************)
(*$G+*)

BEGIN {main program}
  INITIALIZE( TRUE); (* first initialization of almost everything *)
  REPEAT (* forever -- until user says Q(uit *)
    (* solicit options from user *) OPTIONS;
    (* process the file the requested number of times *)
    REPETITION := 1;  GOAHEAD := TRUE;
    WHILE (REPETITION <= TIMES) AND GOAHEAD DO BEGIN
      INITIALIZE( FALSE); (* init for a repitition *)
      MSG( 'file: ', 0);
      WRITE( MAINNAME, ', copy ', REPETITION, ' of ', TIMES);
      LNAME := MAINNAME;
      ESCAPING := FALSE; (* assume not escaping yet *)
      PFILE( MAINNAME);  (* do the read/print work *)
      (* all done printing *)
      IF ESCAPING THEN (* immediately back to options *) GOTO 2;
      IF XREFFING THEN BEGIN (* xref was requested; print the table *)
        IF NOT PAGESKIP THEN SKIP( 1);
        IF NHUNKS = 0 THEN (* disk wasn't used for xref *) BEGIN
          PRINTTABLE( PRINTER);
          IF ESCAPING THEN GOTO 2
            END
        ELSE BEGIN  (* disk was used for xref *)
          (* write last piece to disk, then print whole mess from disk *)
          PRINTTABLE( DISK);
          IF ESCAPING THEN GOTO 2;
          PRINTTABLE( MERGE);
          IF ESCAPING THEN GOTO 2
          END
        END;
      2: (* escape point *) IF ESCAPING THEN BEGIN
        ESCAPING := FALSE; (* so final page skip will work *)
        GOAHEAD := FALSE  (* but loop will stop *)
        END;
      (* final page skip *)
      IF PAGESKIP THEN  PLAINSKIP( PAGELINES - CURLINE + 1);
      REPETITION := REPETITION + 1
      END;
    IF UNITOUT OR ESCAPING THEN CLOSE( OUTFILE)  ELSE CLOSE( OUTFILE, LOCK)
    UNTIL FALSE
  END.
  (*$G-*)

========================================================================================
DOCUMENT :usus Folder:VOL07:prxref.utl.text
========================================================================================

(*****************************************************************)
(* PRXREF.UTL -- for USUS -- 1980 July 14   (disabled KEYHIT)    *)
(*****************************************************************)

(* screen control -- takes cues from SYSTEM.MISCINFO, via two strings *)
(* EOLSTRING and EOSSTRING established by procedure INITSCREEN *)

PROCEDURE ERASEEOL; (* erase display to end of line *)
BEGIN
  UNITWRITE( 1, EOLSTRING[ 1], LENGTH( EOLSTRING), , 4 (* ==> raw output *) )
  END;

PROCEDURE ERASEEOS;   (* erase display to end of screen *)
BEGIN
  UNITWRITE( 1, EOSSTRING[ 1], LENGTH( EOSSTRING), , 4 (* ==> raw output *) )
  END;
(**************************************************************************)

PROCEDURE DOTTEXT( VAR S: STRING);
  (* appends ".TEXT" to file name S if it doesn't already have one *)

VAR
  I: INTEGER;
  C: CHAR;
BEGIN
  FOR I := 1 TO LENGTH( S) DO BEGIN
    C := S[ I];  UCFOLD( C); S[ I] := C  END;
  IF (( POS( '.TEXT', S) <> LENGTH( S) - 4) OR ( LENGTH( S) <= 4)) THEN
    S := CONCAT( S, '.TEXT')
  END;
(**************************************************************************)

FUNCTION FILECHECK (*** VAR S: STRING ): BOOLEAN ***) ;
  (* verify that input .TEXT file S exists, return TRUE if it does *)
VAR
  DUMMYFILE: FILE;
BEGIN
  DOTTEXT( S);
  (*$I-*) RESET( DUMMYFILE, S); (*$I+*)
  FILECHECK := (IORESULT = 0);  CLOSE( DUMMYFILE)
  END;
(****************************************************************)

PROCEDURE UCFOLD(***  VAR C: CHAR ***);
    (* Folds lower case alphabetics into upper case. *)
  BEGIN
  IF ( C >= 'a') THEN IF ( C <= 'z') THEN C := CHR( ORD( C) - 32)
  END;
(**************************************************************************)

PROCEDURE MSG (*** S: STRING;  L: INTEGER ***) ; (* display S on msg line L *)
BEGIN
  GOTOXY( PRCOL, MSGLINE+L);  ERASEEOL;  WRITE( S);  END;

PROCEDURE IOE(*** N: INTEGER;  S: STRING ***); (* handle fatal I/O error *)
BEGIN
  MSG(' I/O error on file: ', 2);  WRITE( S);  EXIT( PRXREF)  END;
(**************************************************************************)

PROCEDURE SEARCH(*** IDX: ALFA***);
  (* global: T, TOP *)

  (*************************************************************************)
  (* Process and enter symbol IDX in the cross-reference symbol table *)
  (* The crux of this routine is taken from N. Wirth, ALGORITHMS + DATA *)
  (*   STRUCTURES = PROGRAMS, pages 264-274.  The original version *)
  (*   was supplied with the release of UCSD Pascal version I.4. *)
  (*   This version is considerably modified by the present author. *)
  (* The general method is hashing with quadratic probing.  This is *)
  (*   fully documented in the reference, so only modifications will be *)
  (*   discussed here. *)
  (* The identifier IDX is sought in the table, provided it begins with *)
  (*   a non-numeric  character.  If a found symbol is a keyword, it is *)
  (*   ignored.  Otherwise, it is assumed a programmer's symbol and entered *)
  (*   in the table with the line number on which it occurred.  A symbol *)
  (*   not found initiates a new table entry for a programmer's symbol. *)
  (* Keywords are entered in the table with a special, negative line number, *)
  (*   before the program begins (see INITXREF). *)
  (* Should the table fill up, the disk table handler is invoked. *)
  (*   The table is sorted and written to disk for later merging with other *)
  (*   portions.  The table is then reinitialized for further entries. *)
  (*************************************************************************)

VAR
  I, H, D: INTEGER;
  JR: REAL;
  X : ITEMPTR;
  F: BOOLEAN;
  FCH: CHAR;
  (* record to deal with ID simultaneously as alphanumeric and numeric *)
  IDREC: RECORD CASE BOOLEAN OF
    TRUE: ( ID: ALFA);
    FALSE: ( NUM: PACKED ARRAY[ 1..INTSPERALFA] OF INTEGER )
    END;
BEGIN (* SEARCH *) WITH IDREC DO BEGIN
  (* reject symbols beginning with a numeric character *)
  FCH := IDX[1]; IF (FCH <= '9') AND (FCH >= '0') THEN EXIT( SEARCH);
  ID := IDX;  JR := 0.0;
  (* hash the symbol (without using integer overflow) *)
  FOR I := 1 TO INTSPERALFA DO  BEGIN
    JR := JR + NUM[ I];
    IF JR > 32766.9 THEN JR := JR - 32766.9
    END;
  H := TRUNC( JR) MOD P;
  (* search the scatter store with quadratic probing *)
  F := FALSE;  D := 1;
  REPEAT
    IF T[H].KEY = ID THEN BEGIN (* found *)
      F := TRUE;  (* terminate search *)
      IF T[ H].FIRST <> NIL THEN BEGIN (* found is not keyword *)
        (* check if room left in the current item *)
        IF T[H].LAST^.REFNUM = REFSPERITEM THEN BEGIN
          (* no room; create new item and link to previous one *)
          NEW( X);  X^.REFNUM := 1;  X^.REF[ 1] := LINENUMBER;
          T[ H].LAST^.NEXT:= X;  T[ H].LAST := X;
          END
        ELSE WITH T[ H].LAST^ DO BEGIN
          (* there is room; insert symbol in current item *)
          REFNUM := REFNUM + 1;  REF[ REFNUM] := LINENUMBER
          END
        END
      ELSE BEGIN (* found is a keyword *)
        NUMKWREFS := NUMKWREFS + 1 (* count the ref *)  END
      END
    ELSE IF T[ H].KEY = '        ' THEN BEGIN (* new entry *)
      F := TRUE; (* terminate search *)
      LNUMENTRIES := LNUMENTRIES + 1; (* local entry count, for ovflw check *)
      (* check if this is to be a keyword entry *)
      IF LINENUMBER <> KWCODE THEN (* non keyword *) BEGIN
        (* enter symbol and start new item *)
        NEW( X);  X^.REFNUM := 1;  X^.REF[1] := LINENUMBER;
        T[H].FIRST := X;  T[H].LAST  := X  END
      ELSE (* keyword *) BEGIN  (* indicate that by NIL pointer *)
        T[ H].FIRST := NIL;  END;
      T[ H].KEY   := ID;  TOP := H
      END
    ELSE BEGIN (* collision; quadratic probe *)
      H := H + D;  D := D + 2;  IF H >= P THEN  H := H - P;
      IF D = P THEN BEGIN
        (* table overflow; shouldn't happen if table is sufficiently large *)
        (* since table will be written to disk before it occurs *)
        WRITELN( OUTPUT,'Internal error: table overflow!!');  EXIT( PRXREF)
        END
      END
    UNTIL F;
  (* check if hash load factor exceeded or dynamic memory exhausted *)
  IF (LNUMENTRIES >= MAXNUMENTRIES) OR (MEMAVAIL < MEMTHRESH)  THEN
    (* write current table contents to disk *) PRINTTABLE( DISK)
  END END (*SEARCH*) ;
(**************************************************************************)

PROCEDURE PUTCRLF;
  (* Do printer line skip, with regard for possible printer need for nulls *)
VAR
  I: INTEGER;
BEGIN
  IF PRINTING OR INXREF THEN  FOR I := 1 TO SPACING DO BEGIN
    WRITE( OUTFILE, CHR(CR));
    IF NUMPRNULLS > 0 THEN  IF UNITOUT THEN  IF PRINTUNIT = 6 THEN
      UNITWRITE( PRINTUNIT, NULLS[ 1], NUMPRNULLS)
    END
  END;
(**************************************************************************)

PROCEDURE BUMPLINE;
  (* perform logical line skip; watch for page overflow *)
VAR
  I: INTEGER;
BEGIN
  IF CURLINE >= PRINTLAST THEN TOPOFPAGE;
  CURLINE := CURLINE + SPACING
  END;
(**************************************************************************)

PROCEDURE SKIP(*** NUM: INTEGER***);
  (* skip NUM lines on printer, logically and physically *)
VAR
  I: INTEGER;
BEGIN
  FOR I := 1 TO NUM DO BEGIN
    BUMPLINE;  PUTCRLF;
    IF ESCAPEHIT THEN EXIT( SKIP)
    END
  END;
(**************************************************************************)

PROCEDURE PLAINSKIP( N: INTEGER);
  (* uncomplicated skip; no check for end of page, etc. *)
VAR
  I: INTEGER;
BEGIN
  FOR I := 1 TO N DO BEGIN
    CURLINE := CURLINE + 1;  PUTCRLF;
    IF ESCAPEHIT THEN EXIT( PLAINSKIP)
    END
  END;
(**************************************************************************)

PROCEDURE TOPOFPAGE;
    (* Page skip; respects header, pageskipping options, prints hdrs, etc *)
VAR
  I: INTEGER;

BEGIN
  IF PRINTING OR INXREF THEN BEGIN (* otherwise don't bother *)
    IF PAGESKIP THEN  (* skip to top of new physical page *)
      IF NOT FIRSTPAGE THEN (* actual skip is required *)
        IF (PRFORMFEED <> 0) AND UNITOUT THEN (* send formfeed char *)
          WRITE( OUTFILE, CHR( PRFORMFEED))
        ELSE (* do it with skips *)
          PLAINSKIP( PAGELINES - CURLINE + 1);
      (* else user has set it there already *);
    (* set curline for new page; show no longer first page *)
    CURLINE := 1;  FIRSTPAGE := FALSE;
    IF HDRS OR PAGESKIP THEN PLAINSKIP( TOPMARGIN); (* margin above hdr *)
    IF HDRS THEN BEGIN (* print the header *)
      IF PRINTING THEN BEGIN
        IF TITLEHDRS THEN (* use standard file title header *) BEGIN
          WRITE( OUTFILE, 'FILE: ', MAINNAME, '  PAGE ', GPAGE);
          IF LNAME <> MAINNAME THEN (* show included file name *)
            WRITE( OUTFILE, ' ':12, 'INCLUDED FILE: ', LNAME, '  PAGE ', LPAGE)
          END
        ELSE  (* user header from format command *)
          WRITE( OUTFILE, HEADER, GPAGE)
        END;
      IF INXREF THEN BEGIN (* special header during xref *)
        IF NOT PRINTING THEN WRITE( OUTFILE, 'FILE: ', MAINNAME);
        WRITE( OUTFILE, ' ':12, 'CROSS REFERENCE', '  PAGE ', LPAGE)
        END;
      (* header separator *)
      PLAINSKIP( 1);  WRITE( OUTFILE, HEADERSEP);  PLAINSKIP( HEADERMARGIN+1)
      END;
    (* update page counters, global and local (for included file) *)
    GPAGE := GPAGE + 1;   LPAGE := LPAGE + 1
    END
  END;
(**************************************************************************)

PROCEDURE STRIPSTRING( VAR S: BIGSTRING);
  (* strip leading and trailing blanks from S; maybe down to null string *)
VAR
  A, B, L: INTEGER;
BEGIN
  L := LENGTH( S);
  IF L > 0 THEN BEGIN
    A := SCAN( L, <>' ', S[ 1]);  (* find first non-space *)
    IF A >= L THEN (* nothing but spaces in S *) S := ''
    ELSE (* find last non-space;  extract middle *) BEGIN
      B := SCAN( -L, <>' ', S[ L]);  S := COPY( S, A+1, L-A+B)  END
    END
  END;
(**************************************************************************)

FUNCTION STRTON( S: BIGSTRING): INTEGER;
  (* small, crummy routine to convert string to integer *)
  (* assumes S stripped of leading and trailing blanks *)
  (* handles up to 3 digits, no sign; returns -1 on any error *)
VAR
  N, I: INTEGER;
  ERR: BOOLEAN;
BEGIN
  IF LENGTH( S) > 3 THEN ERR := TRUE
  ELSE BEGIN
    N := 0;  I := 1;  ERR := FALSE;
    REPEAT
      IF S[ I] IN [ '0'..'9'] THEN BEGIN
        N := N * 10 + ORD( S[ I]) - ORD( '0');  I := I + 1  END
      ELSE ERR := TRUE;
      UNTIL (I > LENGTH( S)) OR ERR;
    IF ERR THEN STRTON := -1  ELSE STRTON := N
    END
  END;
(**************************************************************************)

FUNCTION KEYHIT: BOOLEAN;
  (* if any key on terminal is hit, return true *)
  (* if nothing happening on kb, return false without ado *)

{-----------------------------------following is commented out-----

(* This version is for Pascal-100 (TM), the Pascal CPU for the S-100 bus *)
(*   manufactured by Digicomp Research *)
(* with a Cromemco Tuart at ports 0 (control) and 1 (data) *)

  CONST
    CTLPORT = 0; (* which port tells *)
    RDABIT = 6;  ACTIVELOW = FALSE;
  TYPE
    WORDBITS = PACKED ARRAY[ 0..15] OF BOOLEAN;
  VAR
    PORT: RECORD CASE INTEGER OF
      0: (IADDR: INTEGER);
      1: (ADDR: ^WORDBITS)
      END;
  BEGIN WITH PORT DO BEGIN
    IADDR := CTLPORT - 256; (* set the port pointer *)
    (* read the port, active low or high as appropriate *)
    IF ACTIVELOW THEN KEYHIT := NOT ADDR^[ RDABIT]
    ELSE KEYHIT := ADDR^[ RDABIT];
    END END;
  ------------------------------------above is commented out---------}

  {-----------------------------------following is commented out-----
  (* This is a version for a module in the library *)
  EXTERNAL;
  ------------------------------------above is commented out---------}

  (* This is a version that does nothing; assumes nothing *)
  (* This is the active routine *)
  BEGIN  KEYHIT := FALSE  END;

(* Boy, do we need conditional compilation !! *)
(**************************************************************************)

FUNCTION ESCAPEHIT (*** : BOOLEAN ***);
  (* looks for kb hit; if yes and escape, abort; else wait for another *)
  (* and look again for escape *)
  (* sets the global vbl ESCAPING as well as the function itself *)
  (* if ESCAPING is true to begin with, it will remain true regardless of *)
  (* keyboard activity or lack thereof *)
BEGIN
  IF KEYHIT THEN (* somebody knocking *) BEGIN
    READ( KEYBOARD, C); (* read what's there *)
    IF C <> CHR( ESC) THEN BEGIN (* hold everything until another hit *)
      MSG( 'any key to continue;  <esc> to quit', 2);
      READ( KEYBOARD, C);  MSG( ' ', 2)
      END;
    IF C = CHR( ESC) THEN BEGIN
      MSG( '<esc> again to quit PRXref;  ', 2);
      WRITE( 'any other key to reinitialize');
      READ( KEYBOARD, C);  IF C = CHR( ESC) THEN EXIT( PRXREF);
      ESCAPING := TRUE
      END
    END;
  ESCAPEHIT := ESCAPING
  END;

(*********************************************************)


========================================================================================
DOCUMENT :usus Folder:VOL08:archiver.text
========================================================================================

{Copyright 1980 by
Stuart Lynne
1350 Clifton Ave.
Coquitlam, British Columbia,
Canada
V3J 5K6

Permission granted to use for noncommercial purposes.  All
other rights reserved}



{
*   Archiver
*
*   Author: Stuart Lynne
*
*   Date:   August 22, 1980
*
}

{$I globals }

  segment procedure userprogram;
    
    const
      bufsize = 60;
    
    type
      blocktype = array [0..255] of integer;
      
    var
      
      lastblock, archlast, archsize: integer;
      
      command: char;
      
      initial: boolean;
      
      archname, volname: vid;
      
      Fi: file;
      
      
    function min (A, B: integer): integer;
      begin
        if A < B then
          min := A
        else
          min := B
      end;
      
    procedure archinitialize;
      var
        volinfo: directory;
      
      begin
        initial := false;
        unitread (4, volinfo, sizeof (volinfo), 2);
        archlast := volinfo[volinfo[0].dnumfiles].dlastblk;
        archsize := volinfo[0].deovblk;
        archname := volinfo[0].dvid;
        writeln;
        writeln ('The archive disk is  ', archname, '.');
        writeln ('It is ', archsize, ' blocks long and has ', 
                 archsize - archlast, ' blocks left for use.')
      end;
      
    procedure srceinitialize;
      var
        volinfo: directory;
      
      begin
        unitread (5, volinfo, sizeof (volinfo), 2);
        lastblock := volinfo[volinfo[0].dnumfiles].dlastblk;
        volname := volinfo[0].dvid;
        writeln;
        writeln ('Now archiving ',volname, 
                 ' which is ',lastblock, ' blocks long.')
      end;
      
    function tryagain: char;
      var
        C: char;
      begin
        writeln;
        write ('A(rchive, N(ew, Q(uit, D(irectory');
        read (C);
        tryagain := C;
        writeln
      end;
      
    procedure transfer;
      var
        I, Count: integer;
        buf: array [1..bufsize] of blocktype;
        Fo: file;
      
      begin
        rewrite (Fo, concat ('#4:', volname, '.dsk'));
        Count := 0;
        while Count < lastblock do
          begin
            I := blockread (Fi, buf, min (lastblock - Count, bufsize));
            if blockwrite (Fo, buf, I) <> I then
              begin
                close (Fo, purge);
                writeln ('No room on volume');
                exit (transfer)
              end;
            Count := Count + i
          end;
          
        archlast := archlast + Count;
        close (Fo, lock);
        
        writeln (volname, ' has been archived.');
        writeln ('There are ', archsize - archlast, 
                 ' blocks left on ', archname);
            
      end;
      
    procedure directory;
      var
        fname: string;
      begin
        write ('Directory of what disk');
        readln (fname);
        if fname = 
      end;
      
    begin
    
      writeln;
      writeln ('Archiver version 1.0');
      
      writeln;
      writeln ('Archive disk on unit # 4.');
      writeln ('Source  disk on unit # 5.');
      
      initial := true;
      
      repeat
        command := tryagain;
        if command in ['n', 'N'] then
          archinitialize
        else
          if initial then
            writeln ('N(ew archive disk please!')
          else
            if command in ['A', 'a'] then
              begin
                reset (Fi, '#5:');
                srceinitialize;
                if (lastblock + archlast) < archsize then
                  transfer
                else
                  begin
                    writeln (volname, ' will not fit on ', archname)
                  end;
                close (Fi, normal)
              end
            else
              if command in ['D', 'd'] then
                directory
      until command in ['q', 'Q'];
      
      writeln;
      writeln ('Replace System Disk!');
      readln
    
    end;
    
  begin
  end.



========================================================================================
DOCUMENT :usus Folder:VOL08:catalog.8.text
========================================================================================

                     CATALOG FOR VOLUME 8 -**- USUS LIBRARY
                    More Software Tools and a Few Utilities.
           (updated 26 July 1981 -- changed from Newsletter listing)

    name         blks          description
    
ARCHIVER.TEXT     10  Save & retrieve disk images.

BANNER.TEXT           <see Volume 6>

CHAIN.TEXT         6  Chain to another program.
CHAIN.1.TEXT       4  Demo programs...
CHAIN.2.TEXT       4

COPYBLOCKS.TEXT    6  Copy blocks to a file by block number.

CRMBLEV1.2.TEXT   14  Break up long files for editing with the UCSD editor.

D.TEXT            20  Revised disk directory lister.

DISKSORT.TEXT     12  Revised sample sort.

ERROR.DATA.TEXT    4  Messages used by FILEUNIT.

EXHALEV2.1.TEXT    6  Send data to remote port.
INHALEV2.1.TEXT    8  Receive data from remote.

FAST.SEEK.TEXT    10  Greatly speed SEEK procedure.

FILEUNIT.TEXT     32  General-purpose file handling routines.

GLOBAL.II0.TEXT   30  GLOBALS for UCSD system II.0.
GLOBAL.III.TEXT   36                     .....III.0.

LINECOUNT.TEXT    10  Counts lines in text files or entire volumes.

LISP.TEXT         28  Public-domain LISP interpreter.

LISTER.TEXT        6  List text files.

MAILER.DOC.TEXT   10
MAILER.TEXT       22  Mailing list facility; sounds NICE.

MODEMV2.2.TEXT     8  Rework of program on Volume 2A.

MULDIV.Z80.TEXT    6  Part of Z80.SEEK.

PERUSEV4.6.TEXT   14  Look over a text file forwards & back; FAST!

RECOVER.TEXT       6  Find program source text after zapping a directory.

REM.TERM.TEXT     34  Hardware-independent communications utility.
REM.UNIT.TEXT     32  One implementation of new USUS standard remote unit.

SCREEN.TEXT        6  Western Digital screen control unit.
SCREENUNIT.TEXT   10  Terminal-independent screen control from Volume 5.

UNITS.DOC.TEXT    22  Documentation for FILEUNIT.

VOLUME.8.TEXT     32  Documentation for the files on this disk.

WRITERV7.2.TEXT   34  Nice text printer, updated from Volume 2A.

Z80.SEEK.TEXT      8  Fast seek routine specific to Z-80's.

NOTES:  These files may be distributed to USUS members ONLY and may be used
        only for noncommercial purposes, unless written consent of the author
        is obtained, in which case author instructions prevail.

        All disk formats will contain the same material (minifloppies on two
        disks).  This material has not been tested thoroughly; send bug reports
        and fixes to me and to the USUS Newsletter.
        
        Jim Gagne, USUS Library Chairman



========================================================================================
DOCUMENT :usus Folder:VOL08:chain.1.text
========================================================================================


program chain_1;

  procedure chain (S: string);
    external;
    
  begin
    
    writeln;
    writeln ('Hello there from Chain test program # 1');
    chain ('Chain.2.code')
    
  end.

========================================================================================
DOCUMENT :usus Folder:VOL08:chain.2.text
========================================================================================


program chain_2;

    
  begin
    
    writeln;
    writeln ('Hello there from Chain test program # 2')
    
  end.

========================================================================================
DOCUMENT :usus Folder:VOL08:chain.text
========================================================================================

{Copyright 1980 by
Stuart Lynne
1350 Clifton Ave.
Coquitlam, British Columbia,
Canada
V3J 5K6

Permission granted to use for noncommercial purposes.  All
other rights reserved}

  
{ chainer }
{$S+}
{
*
*       Chain
*
*       Author: Stuart Lynne
*
}
{$C  Copyright (c) 1980, by Stuart Lynne. All rights reserved. }
{$I globals}
{L+}
{D+}
{L printer: }

separate unit chainer;
  
  interface
  
    type
      seg_set = set of 0..15;
      
      sysp = ^ syscomrec;
      
    procedure Chain (S: string);
    procedure SysDate (var D: daterec);
    procedure syscomp (var S: sysp);
    
  implementation
  
    type
      intseg = array[1..15] of record
              address, refcount: integer
            end;
    
    procedure Chain (*S: string *);
    
      var dummy: integer;
          kind:  filekind;
      
      begin
      
        state := linkandgo;
        userinfo.gotcode := true;
        if scantitle (S, userinfo.codevid, userinfo.codetid, dummy, kind) then;
      end;
      
                                                              {$P}
    procedure SysDate (* var D: daterec *);
      begin
        D := thedate
      end;
    
    procedure syscomp (* var S: sysp *);
      begin
        S := syscom
      end;
      
    
  end;
  
  begin
  end.
  
  

========================================================================================
DOCUMENT :usus Folder:VOL08:copyblocks.text
========================================================================================

PROGRAM COPYBLOCKS;
USES (*$U screenunit.code*)SCREENUNIT,
     (*$U fileunit.code*)FILEUNIT;

{by George Schreyer}

VAR I,J,K,L,M,N : INTEGER;
    DISKA,DISKB : FILE;
    VOLNAME,FILENAME : STRING;
    DATA : PACKED ARRAY [0..511] OF CHAR;

BEGIN
   GETCRTINFO;
   GOTOXY(0,0);
   CRT(ERASEOS);
   WRITELN('     copyblocks version 1.0    13-Jun-81');
   VER_SCREENUNIT;
   VER_FILEUNIT;
   
   WRITELN;
   WRITELN('Copyblocks transfers a group of blocks, probably a whole file');
   writeln('which has for some reason dissappeared from the directory,');
   WRITELN('from a file or volume to a text file.  You must supply the');
   WRITELN('absolute starting block from the beginning of the file or volume');
   writeln('and the number of blocks which are to be transferred.  ');
   OPNDSKREAD(DISKA,'name of source volume ?',VOLNAME,0,11);
   IF VOLNAME='' THEN EXIT(PROGRAM);
   OPNDSKWRT(DISKB,'Filename of output file ? ',FILENAME,0,13);
   IF FILENAME='' THEN EXIT(PROGRAM);
   WRITELN;
   WRITE('Blocknumber to start from ? ');
   READLN(I);
   WRITE('Number of blocks to copy ? ');
   READLN(J);
   FOR L:= I TO I+J-1 DO
      BEGIN
         K:=BLOCKREAD(DISKA,DATA,1,L);
         K:=BLOCKWRITE(DISKB,DATA,1);
      END;
   CLOSE(DISKB,LOCK);
END.
   

========================================================================================
DOCUMENT :usus Folder:VOL08:crmblev1.2.text
========================================================================================

PROGRAM CRUMBLE;
USES(*$U SCREENUNIT.CODE*) SCREENUNIT,
    (*$U FILEUNIT.CODE*) FILEUNIT;

{   by George Schreyer
          
               Program crumble will break a text file which is too
          large for the editor to handle in bite sized chunks.  The
          program will first ask for the base file (the too big one)
          and then for a generic include file name, that is a name up
          to seven characters onto which it will append the suffix
          '.0 ... .N' where N is the number of the particular include
          file into which your code is going.  The program will keep
          track of the size of each include file so that it itself
          won't get too large.  After the program has copied the
          requested number of records (lines) it will display the
          current (approx) size in bytes and then ask if you want too
          stuff even more records into it or create a new include
          file to take the new lines.  If you don't have a listing
          with line numbers on it try transferring about 300 lines at
          a time or eX)ecute WRITER and get a listing with
          numbers.}
 
          {Copyright 1980 by George Schreyer.  All rights reserved}
          {Non commercial use is ok}
 
CONST VERSION = 'crumble    version 1.2    30-Apr-81';
 
VAR
   REC_COUNT            : INTEGER;
   STOP_RECORD          : INTEGER;
   START_RECORD         : INTEGER;
   NUM_BYTES            : INTEGER;
   GOTFILE              : BOOLEAN;
   BASE_FILENAME        : STRING;
   NAME_OK              : BOOLEAN;
   FILENUM              : INTEGER[2];
   INCLUDE              : TEXT;
   BASE                 : TEXT;
   INCLUDE_FILENAME     : STRING;
   FILENAME             : STRING;
   MORE                 : BOOLEAN;
   LAST_REC             : INTEGER;
   STOP_NOW             : BOOLEAN;
   REPLY                : CHAR;
   MORE_DATA            : BOOLEAN;
   POS_COLON            : INTEGER;
   I                    : INTEGER;
   I_TRIED              : BOOLEAN;
   IORESLT              : INTEGER;

PROCEDURE CLEAR_SCREEN;
BEGIN
  GOTOXY(0,0);
  CRT(ERASEOS);
END {CLEAR_SCREEN};

PROCEDURE CLEAR_EOL(X,Y : INTEGER);
BEGIN
   GOTOXY(X,Y);
   CRT(ERASEOL);
END;  {clear_eol}


PROCEDURE WARNING;
VAR REPLY : CHAR;
    RECS_LEFT : INTEGER;
BEGIN
   CLEAR_EOL(0,0);
   RECS_LEFT:=STOP_RECORD-REC_COUNT;
   WRITE('Your include file is 9/10 full and you have ',RECS_LEFT:4,
         ' records left to copy.');
   CLEAR_EOL(0,1);
   WRITE('Are you sure that you wish to continue? (Y/N) ');
   READ(REPLY);
   IF REPLY <> 'Y' THEN
      BEGIN
         STOP_NOW:=TRUE;
      END
   ELSE MORE_DATA:=TRUE;
END;  {warning}

PROCEDURE COPY;
   VAR LINE : STRING;

BEGIN
   NUM_BYTES:=0;
   FOR REC_COUNT:=START_RECORD TO STOP_RECORD DO
      BEGIN
         LAST_REC:=REC_COUNT;
         READLN(BASE,LINE);
         IF EOF(BASE) THEN EXIT(COPY)
         ELSE 
            BEGIN
               WRITELN(INCLUDE,LINE);
               WRITELN(LINE);
               NUM_BYTES:=LENGTH(LINE)+4+NUM_BYTES;
               IF (NUM_BYTES>15000) AND (NOT MORE_DATA) THEN WARNING;
               IF STOP_NOW THEN 
                  BEGIN
                     EXIT(COPY);
                  END;
            END;
       WRITELN(INCLUDE);
       END;
 END; {copy}
 
 PROCEDURE INITILIZE;
 BEGIN
    MORE:=FALSE;
    INCLUDE_FILENAME:='';
    MORE_DATA:=FALSE;
    STOP_NOW:=FALSE;
    FILENUM:=0;
    START_RECORD:=1;
    STOP_RECORD:=0;
    FILENAME:='';
    BASE_FILENAME:='';
    NUM_BYTES:=0;
 END;  {init}
 
 PROCEDURE GETRECORDS;
 BEGIN
    CLEAR_SCREEN;
    IF START_RECORD <> 1 THEN WRITELN('last record copied was ',LAST_REC);
    WRITELN;
    WRITE('please type in a');
    IF START_RECORD >1 THEN WRITE(' new');
    WRITELN(' record to copy up to ');
    WRITELN;
    WRITE('record number? ');
    READLN(STOP_RECORD);
END;   {getrecords}
 
 
 PROCEDURE INSERT_FILENUM;
 VAR FILENUM_STRING : STRING;
     TEMP_FILENAME  : STRING;
 
 BEGIN
    TEMP_FILENAME:=FILENAME;
    STR(FILENUM,FILENUM_STRING);
    INSERT((CONCAT('.',FILENUM_STRING)),
        TEMP_FILENAME,(POS('.TEXT',FILENAME)));
    INCLUDE_FILENAME:=TEMP_FILENAME;
 END;  {insert_filename}
            
 BEGIN  {main program}
    GETCRTINFO;
    CLEARSCREEN;
    INITILIZE;
    WRITELN('     ',VERSION);
    VER_SCREENUNIT;
    VER_FILEUNIT;
    OPNDSKREAD(BASE,'file to be crumbled? ',BASE_FILENAME,0,13);
    IF BASE_FILENAME = '' THEN EXIT(PROGRAM);
       REPEAT  {until include file open ok}
          REPEAT   {until name_ok}
             CLEAR_SCREEN;
             GOTOXY(0,9);
             WRITE('Type the generic name of includes files.  (7 chars max)  ');
             READLN(FILENAME);
             IF LENGTH(FILENAME)=0 THEN EXIT(PROGRAM);
             POS_COLON:=POS(':',FILENAME);
             IF (POS('.TEXT',FILENAME)>8+POS_COLON) 
                 OR ((POS('.TEXT',FILENAME)=0)
                 AND (LENGTH(FILENAME)>7+POS_COLON)) THEN 
                 NAME_OK:=FALSE ELSE NAME_OK:=TRUE;
          UNTIL NAME_OK;
          IF POS('.TEXT',FILENAME)=0 THEN FILENAME:=CONCAT(FILENAME,'.TEXT');
          INSERT_FILENUM;
          REWRT_DISK(INCLUDE,INCLUDE_FILENAME,IORESLT,I_TRIED);
          IF (NOT I_TRIED) AND (IORESLT <> 0) THEN IO_ERROR(IORESLT,
            INCLUDE_FILENAME);
       UNTIL (I_TRIED AND (IORESLT=0));
       CLOSE(INCLUDE);
       REPEAT  {until eof(base)}
          REWRITE(INCLUDE,INCLUDE_FILENAME);
          REPEAT  {until more=false}
                CLEAR_SCREEN;
                GETRECORDS;
                WRITELN; {don't delete this line}
                COPY;
                START_RECORD:=LAST_REC+1;
                IF NOT EOF(BASE) THEN
                    BEGIN
                       FOR I:=1 TO 7 DO CLEAR_EOL(0,I);
                       GOTOXY(0,0);
                       WRITELN('number of bytes transferred = ',NUM_BYTES);
                       WRITELN;
                       WRITELN('do you wish to T)ransfer more data into ',
                               INCLUDE_FILENAME,',');
                       WRITELN;
                       WRITE('C)ontinue, or Q)uit with files saved? ');
                       READ(REPLY);
                       CLEAR_SCREEN;
                       IF REPLY = 'Q' THEN
                          BEGIN
                             CLOSE(INCLUDE,LOCK);
                             EXIT(PROGRAM);
                          END;
                       IF (REPLY = 'T') THEN 
                          BEGIN
                             MORE:=TRUE;
                          END
                       ELSE
                          BEGIN
                             MORE:=FALSE;
                             CLOSE(INCLUDE,LOCK);
                             FILENUM:=FILENUM+1;
                             INSERT_FILENUM;
                          END;
                    END  {eof(base)}
                ELSE MORE:=FALSE;
          UNTIL NOT MORE;
    UNTIL EOF(BASE);
CLOSE(BASE);
CLOSE(INCLUDE,LOCK);
END.


========================================================================================
DOCUMENT :usus Folder:VOL08:d.text
========================================================================================

PROGRAM   DIR;
{$I-,R-}
{
  This program is for NONcommercial use only, without written permission from
  the authors.  Jim Gagne, Datamed Research, 1433 Roscomare Road, Los Angeles,
  California 90024.}

CONST
        Has40ColApple = false;
        ScreenWidth = 80;
        LastLine    = 23;      {last line no. on screen, starting from line 0.}
        MaxDirEnt   = 77;
        UnusedFlag  = -1;
        LastUnusedFlag = -2;

TYPE

     DATEREC = PACKED RECORD
                        MONTH: 0..12;
                        DAY: 0..31;
                        YEAR: 0..100
               END;

     DIRRANGE = 0..MaxDirEnt;

     VID = STRING[7];
     TID = STRING[15];
     FILEKIND = (UNTYPED,XDISK,CODE,TEXT,
                 INFO,DATA,GRAF,FOTO,SECUREDIR);

     DIRENTRY = RECORD
                  DFIRSTBLK: INTEGER;
                  DLASTBLK: INTEGER;
                  CASE DFKIND:FILEKIND OF
                    SECUREDIR,UNTYPED:
                                       (DVID:VID;
                                        DEOVBLK,
                                        DLOADTIME,
                                        DBLOCKS:INTEGER;
                                        DLASTBOOT:DATEREC);
                    XDISK,CODE,TEXT,INFO,DATA,
                    GRAF,FOTO:
                               (DTID:TID;
                                DLASTBYTE:1..512;
                                DACCESS:DATEREC)
                END;

     DIRP = ^DIRECTORY;
     DIRECTORY = ARRAY[0..78] OF DIRENTRY;


VAR
    I, RoomLeft, TotlEntries, TotlBlocks, TotlFiles, UnusedLines,
      FilesOnScrn, PrevBlk, TotFilesListed, DirLinesThatFit, StartLine: INTEGER;
    FoundSysFile, WantsInAlphaOrder: boolean;
    IdxArry: ARRAY [DIRRANGE] OF Integer;
    SysNames: string[120];
    DIRX: DIRECTORY;


PROCEDURE ALPHABETIZE_DIRECTORY;
VAR I : integer;


PROCEDURE NRQuickSort(First,Last:integer);

{this procedure was taken from "PASCAL PROGRAMS FOR SCIENTISTS AND ENGINEERS"
 by Alan R. Miller, published by SYBEX.  You ought to buy it, its a very good
 book}

VAR
   Left,Right : ARRAY [1..20] OF integer;
   I,J,SP,MID : integer;
   Pivot : STRING;
   

PROCEDURE Swap(VAR P,Q : integer);
VAR HOLD : integer;
BEGIN HOLD := P;  P := Q;  Q := HOLD END;


BEGIN
  Left[1] := First;  Right[1] := Last;  SP := 1;
  WHILE SP > 0 DO
    BEGIN
      IF Left[SP]>= Right[SP] THEN SP := SP-1
      ELSE BEGIN
        I := Left[SP];  J := Right[SP];  Pivot := DIRX[IdxArry[J]].DTID;
        MID := (I+J) DIV 2;
        IF (J-I) > 5 THEN
          IF ((DIRX[IdxArry[MID]].DTID < Pivot) AND
              (DIRX[IdxArry[MID]].DTID > DIRX[IdxArry[I]].DTID)) OR
             ((DIRX[IdxArry[MID]].DTID > Pivot) AND
              (DIRX[IdxArry[MID]].DTID < DIRX[IdxArry[I]].DTID))
            THEN Swap(IdxArry[MID],IdxArry[J])
            ELSE IF ((DIRX[IdxArry[I]].DTID < DIRX[IdxArry[MID]].DTID) AND
                   (DIRX[IdxArry[I]].DTID > Pivot)) OR
                  ((DIRX[IdxArry[I]].DTID > DIRX[IdxArry[MID]].DTID) AND
                   (DIRX[IdxArry[I]].DTID < Pivot))
              THEN Swap(IdxArry[I],IdxArry[J]);
          Pivot := DIRX[IdxArry[J]].DTID;
          WHILE I < J DO
            BEGIN
              WHILE DIRX[IdxArry[I]].DTID < Pivot DO I := I+1;
              J := J-1;
              WHILE (I < J) AND (Pivot < DIRX[IdxArry[J]].DTID) DO J := J-1;
              IF I < J THEN Swap(IdxArry[I],IdxArry[J]);
            END;
          J := Right[SP];  Swap(IdxArry[I],IdxArry[J]);
          IF (I-Left[SP]) >= (Right[SP] - I)
            THEN BEGIN
              Left[SP+1] := Left[SP];  Right[SP+1] := I-1;  Left[SP] := I+1;
            END
            ELSE BEGIN
              Left[SP+1] := I+1;  Right[SP+1] := Right[SP];  Right[SP] := I-1;
            END;
          SP := SP+1;
      END;
    END;
END;
               
BEGIN
  FOR i := 1 TO TotlEntries DO
    BEGIN
      IdxArry[i] := i;  
      WITH DIRX[i] DO IF Length (DTID) > 0
        THEN BEGIN 
          TotlFiles := TotlFiles + 1;
          RoomLeft := RoomLeft - DLASTBLK + DFIRSTBLK;
        END
    END;
  NRQuickSort(1,DIRX[0].DLOADTIME);  SysNames := '';
END;


PROCEDURE WriteDate (Date: DateRec);
BEGIN
  WITH Date DO
    BEGIN
      WRITE(DAY:3,'-');
      CASE MONTH OF
        1: WRITE('Jan');
        2: WRITE('Feb');
        3: WRITE('Mar');
        4: WRITE('Apr');
        5: WRITE('May');
        6: WRITE('Jun');
        7: WRITE('Jul');
        8: WRITE('Aug');
        9: WRITE('Sep');
        10: WRITE('Oct');
        11: WRITE('Nov');
        12: WRITE('Dec');
      END {case};
      WRITE('-',YEAR:2);
    END {with};
END;


PROCEDURE Initialize;
VAR     Unitnum, i, j: integer;
        chbuf : char;
BEGIN
  WantsInAlphaOrder := true;  FoundSysFile := false;  UnusedLines := 0;
  Writeln(
'Type "-" if you want files listed in order present on disk (not alphabetized)'
  );
  Write('...then the unit number for the directory you wish --> ');
  REPEAT
    Read (keyboard, chbuf);  
    IF chbuf = '-' THEN BEGIN Write('-');  WantsInAlphaOrder := false END;
  UNTIL (chbuf IN ['4', '5', '9', '1']);
  Unitnum := ORD (chbuf) - ORD ('0');  
  IF Unitnum = 1
    THEN BEGIN
      Write(Unitnum);  REPEAT Read(keyboard,chbuf) UNTIL (chbuf IN ['0'..'2']);
      Unitnum := 10 + ORD(chbuf) - ORD('0')
    END;
  Write(Unitnum MOD 10);  UNITREAD(UNITNUM,DIRX[0],2024,2);
  SysNames := 'SYSTEM: ';  TotlFiles := 0;  DirLinesThatFit := LastLine - 2;
  IF IORESULT <> 0
    THEN
      BEGIN
        WRITELN('Unit No. ', Unitnum, ' is not on line.');
        EXIT(DIR);
      END;
  FOR i := 0 TO MaxDirEnt DO IdxArry[i] := 0;
  TotlEntries := DIRX[0].DLOADTIME;  i := 1;
  WHILE (Length(DIRX[i].DTID) = 0) AND (i < TotlEntries) DO i := i + 1;
  Gotoxy(0,LastLine);  Writeln;  Writeln;  Writeln;  Writeln;     {clear screen}
  j := ScreenWidth - 44;  IF Has40ColApple OR (j < 0) THEN j := 0;  
  Gotoxy (j DIV 2, 1);
  WITH DIRX[0] DO
    BEGIN
      WRITELN ('Directory of Unit #', Unitnum, ' -**- Volume ', DVID,':');
      RoomLeft := DBLOCKS- DIRX[i].DFIRSTBLOCK;  TotlBlocks := DBLOCKS;
    END;
  IF WantsInAlphaOrder THEN AlphabetizeDirectory
    ELSE BEGIN
      TotlFiles := 0;  PrevBlk := 10;
      i := 1;  WHILE Length(DIRX[i].DTID) = 0 DO i := i + 1;
      FOR i := i TO TotlEntries DO WITH DIRX[i] DO IF Length(DTID) > 0
        THEN BEGIN
          IF DFIRSTBLK > PrevBlk
            THEN BEGIN
              TotlFiles := TotlFiles + 1;  IdxArry[TotlFiles] := UnusedFlag;
              UnusedLines := UnusedLines + 1;
            END;
          TotlFiles := TotlFiles + 1;  IdxArry[TotlFiles] := i;
          PrevBlk := DLASTBLK;  RoomLeft := RoomLeft - DLASTBLK + DFIRSTBLK
        END;
      IF PrevBlk < TotlBlocks - 1
        THEN BEGIN
          TotlFiles := TotlFiles + 1;  IdxArry[TotlFiles] := LastUnusedFlag;
          UnusedLines := UnusedLines + 1;
        END;
    END;
END;


PROCEDURE WriteDirEntries;
VAR     ch: char;
        i,j,k: integer;
BEGIN
  FilesOnScrn := 0;  TotFilesListed := 0;  StartLine := 2;  PrevBlk := 10;
  FOR i:= 1 TO MaxDirEnt DO IF IdxArry[i] <> 0
    THEN BEGIN
      IF WantsInAlphaOrder
        THEN Gotoxy((FilesOnScrn DIV DirLinesThatFit)*27,
          (FilesOnScrn MOD DirLinesThatFit)+StartLine)
        ELSE Gotoxy((FilesOnScrn DIV DirLinesThatFit)*40,
          (FilesOnScrn MOD DirLinesThatFit)+StartLine);
      FilesOnScrn := FilesOnScrn + 1;  TotFilesListed := TotFilesListed + 1;
      IF IdxArry[i] = LastUnusedFlag
        THEN Write('  < unused >    ', TotlBlocks - PrevBlk:3, PrevBlk:16)
      ELSE IF IdxArry[i] = UnusedFlag
        THEN Write('  < unused >    ', DIRX[IdxArry[i+1]].DFIRSTBLK - PrevBlk:3,
          PrevBlk:16)
      ELSE WITH DIRX[IdxArry[i]] DO
        BEGIN
          j := DLASTBLK-DFIRSTBLK;  PrevBlk := DLASTBLK;
          WRITE(DTID,' ':16-LENGTH(DTID), j: 3, ' ');
          IF NOT WantsInAlphaOrder
            THEN BEGIN WriteDate(DACCESS);  Write(DFIRSTBLK:5) END
        END {else};
     IF (FilesOnScrn MOD DirLinesThatFit = 0)
       THEN IF (TotFilesListed < TotlFiles)
         AND ((WantsInAlphaOrder AND (FilesOnScrn = DirLinesThatFit * 3))
             OR (NOT WantsInAlphaOrder AND (FilesOnScrn = DirLinesThatFit * 2)))
       THEN BEGIN
         j := ScreenWidth - 42;  IF Has40ColApple OR (j < 0) THEN j := 0;
         GotoXY (j DIV 2, LastLine);
         Write ('tap <space bar> to continue, <esc> to quit...');
         REPEAT Read(keyboard,ch) UNTIL ch IN [' ',CHR(27)];
         GotoXY(0,LastLine);  Write(' ':screenWidth-2);
         IF ch = CHR(27) THEN EXIT(WriteDirEntries);
         k := TotlFiles - TotFilesListed;
         IF WantsInAlphaOrder
           THEN BEGIN j := k MOD 3;  k := k DIV 3 END
           ELSE BEGIN j := k MOD 2;  k := k DIV 2 END;
         IF j > 0 THEN k := k + 1;
         IF k > DirLinesThatFit THEN k := DirLinesThatFit;
         FilesOnScrn := 0;  FOR j := 1 TO k+1 DO Writeln;
         StartLine := DirLinesThatFit - k +2;  DirLinesThatFit := k;
       END;
    END {for}
END;


BEGIN
  Initialize;
  WriteDirEntries;
  IF FoundSysFile THEN BEGIN Gotoxy(0,LastLine -1);  Write(SysNames) END;
  I := ScreenWidth - 52;  IF Has40ColApple OR (I < 0) THEN I := 0;
  Gotoxy (I DIV 2, LastLine);  I := TotlFiles - UnusedLines;
  IF I = 1 THEN Write ('1 file; ') ELSE Write (I,' files; ');
  Write (TotlBlocks - RoomLeft, ' blocks used, ',
    RoomLeft, ' remaining, ', TotlBlocks, ' total.');
END.


========================================================================================
DOCUMENT :usus Folder:VOL08:disksort.text
========================================================================================

(*[B+,I=1,L=n,P=1] <== Formatter Directives *)
program disksort;

const
 n = 1000;
 
type
 shortstring = string[10];
 stringarray = array [1.. n] of shortstring;
 datafile = file of shortstring;
 
var
 liner: integer;
 buf: stringarray;
 a, b, c, d: datafile;
 era, erb, erc, erd: boolean;
 temp: shortstring;
 numruns: integer;
 numstrings: integer;
 

procedure sort(l, r: integer);
 
 var
  i, j: integer;
  x, w: shortstring;
  
 begin
  i := l;   j := r;   x := buf[(i + j) div 2];
  repeat
   while buf[i] < x do i := i + 1;   while x < buf[j] do j := j - 1;
   if i <= j then
    begin
     w := buf[i];   buf[i] := buf[j];   buf[j] := w;   i := i + 1;
     j := j - 1
    end
  until i > j;
  if l < j   then sort(l, j);   if i < r   then sort(i, r)
 end (*sort*);


procedure distribute;
 
 var
  i: integer;
  
 
 procedure copyruns(var x, y: datafile);
  
  begin
   numstrings := 0;
   while (not (eof(x))) and (not (numstrings >= n)) do
    begin
     numstrings := numstrings + 1;   buf[numstrings] := x ^;   get(x)
    end;
   sort(1, numstrings);
   for i := 1 to numstrings do begin y ^ := buf[i];   put(y) end
  end (*copyruns*);
 
 
 begin (*distribute*)
  repeat copyruns(c, a);   if not (eof(c))   then copyruns(c, b)
  until eof(c)
 end (*distribute*);


procedure mergeruns(var a, b, c, d: datafile; var era, erb, erc, erd:
 boolean);
 
 var
  buf: shortstring;
  
 
 procedure copyrecord(var a, b: datafile);
  
  begin buf := a ^;   get(a);   b ^ := buf;   put(b) end;
 
 
 procedure testendofrun(var a: datafile; var era: boolean);
  
  begin if eof(a)   then era := true   else era := buf > a ^ end;
 
 
 procedure mergeone(var a, b, c: datafile; var era, erb, erc: boolean);
  
  
  procedure copytail(var a, b: datafile; var era, erb: boolean);
   
   begin
    writeln('copytail');
    while not era do begin copyrecord(a, b);   testendofrun(a, era) end
   end (*copytail*);
  
  
  begin (*mergeone*)
   era := false;   erb := false;   writeln('mergeone');
   repeat
    if a ^ < b ^
    then begin copyrecord(a, c);   testendofrun(a, era) end
    else begin copyrecord(b, c);   testendofrun(b, erb) end
   until era or erb;
   if era   then writeln('era');   if erb   then writeln('erb');
   copytail(a, c, era, erc);   copytail(b, c, erb, erc);
  end (*mergeone*);
 
 
 procedure copyrest(var a, b, c: datafile; var era, erb, erc: boolean);
  
  begin
   writeln('copyrest');
   while not eof(a) do
    begin
     repeat copyrecord(a, b);   testendofrun(a, era)   until era;
     numruns := numruns + 1;
     if not eof(a) then
      begin
       repeat copyrecord(a, c);   testendofrun(a, era)   until era;
       numruns := numruns + 1
      end
    end
  end (*copyrest*);
 
 
 begin (*mergeruns*)
  repeat
   mergeone(a, b, c, era, erb, erc);   numruns := numruns + 1;
   if not (eof(a) or eof(b)) then
    begin mergeone(a, b, d, era, erb, erd);   numruns := numruns + 1
    end
  until eof(a) or eof(b);
  if odd(numruns)   then copyrest(a, d, c, era, erd, erc)
  else copyrest(a, c, d, era, erc, erd);
  if odd(numruns)   then copyrest(b, d, c, erb, erd, erc)
  else copyrest(b, c, d, erb, erc, erd);
  writeln('NUMBER OF RUNS = ', numruns);
 end (*mergeruns*);


begin (*disksort*)
 rewrite(a, 'file.a[120]');   rewrite(b, 'file.b[65]');
 reset(c, 'rawdata');   writeln('distribute');   distribute;
 close(c, lock);
 repeat
  numruns := 0;   writeln('Phase 1 started');   reset(a);   reset(b);
  rewrite(c, 'file.c[120]');   rewrite(d, 'file.d[65]');
  mergeruns(a, b, c, d, era, erb, erc, erd);
  if numruns <> 1
  then
   begin
    numruns := 2;   writeln('Phase 2 started');   close(a, purge);
    close(b, purge);   rewrite(a, 'file.a[120]');
    rewrite(b, 'file.b[65]');   reset(c);   reset(d);
    mergeruns(c, d, a, b, erc, erd, era, erb);   close(c, purge);
    close(d, purge)
   end
 until numruns = 1;
 close(c, lock);
end (*disksort*).

========================================================================================
DOCUMENT :usus Folder:VOL08:error.data.text
========================================================================================

10 file not found
7 bad file name
9 volume not found
3 illegal i/o request
100 Wild cards not allowed
101 Multiple files not allowed
8 no room on volume
14 bad input information
1 bad block or parity error (CRC)
12 file already open
13 file not open
17 illegal block
18 illegal buffer
5 volume went off line
2 illegal device #
4 data-com timeout
6 file lost in directory
11 duplicate directory entry
15 ring buffer overflow



========================================================================================
DOCUMENT :usus Folder:VOL08:exhalev2.1.text
========================================================================================

PROGRAM EXHALE;

{Program Exhale outputs a text file to be
 sent to another computer.  The program invokes the editor (in this
 case on a PR1ME 500) and places the editor in the input mode so that
 the remote computer thinks that a user is simply typing in the
 data from a terminal.  The program then outputs the user specified
 UCSD file.  When EOF is reached the program 'FILE's the program
 under the user specified name and returns to the UCSD command level.}

{by George Schreyer}


USES (*$U SCREENUNIT.CODE*)SCREENUNIT,
     (*$U FILEUNIT.CODE*)FILEUNIT;

VAR
   MODEM_IN,MODEM_OUT,DISK              :TEXT;
   JUNK,FILE_NAME,LINE_OF_DATA,OK      :STRING;
   
   
BEGIN  
   GETCRTINFO;
   GOTOXY(0,0);
   CRT(ERASEOS);
   REWRITE(MODEM_OUT,'REMOUT:');
   REWRITE(MODEM_IN,'REMIN:');
   WRITELN('     exhale     version 2.1    28 Apr 81');
   VER_SCREENUNIT;
   VER_FILEUNIT;
   OPNDSKREAD(DISK,'Please type filename to be exhaled.- - >',
              FILE_NAME,0,13);
   IF FILENAME = '' THEN EXIT(PROGRAM);
   GOTOXY(0,5);
   WRITELN(MODEM_OUT,'ED');
   READLN(MODEM_IN,JUNK);
   WHILE NOT EOF(DISK) DO
      BEGIN
         READLN(DISK,LINE_OF_DATA);
         IF LINE_OF_DATA<> '' THEN
            BEGIN
               WRITELN(MODEM_OUT,LINE_OF_DATA);
               WRITELN(LINE_OF_DATA);
            END;
      END;
   WRITELN(MODEM_OUT,CHR(13),'FILE ',FILE_NAME); {close file at host}
   CLOSE(DISK);
   CLOSE(MODEM_OUT);
   CLOSE(MODEM_IN);
END.


========================================================================================
DOCUMENT :usus Folder:VOL08:fast.seek.text
========================================================================================

{Copyright 1980 by
Stuart Lynne
1350 Clifton Ave.
Coquitlam, British Columbia,
Canada
V3J 5K6

Permission granted to use for noncommercial purposes.  All
other rights reserved}

  
{ fast.seek }
{$U-,S+}

{$I globals }

{
*
*       Fast Seek
*
*       Changes Copyright (c) 1980, by Stuart Lynne. All rights reserved.
*
*       This is a recoded version of the UCSD Pascal Seek algorithm. It
*       is 50 to 100 % faster than the original.
*
*
}
{$C Copyright (c) 1980, by Stuart Lynne. All rights reserved.}
(*----------------------------------------------------------*)

SEPARATE UNIT Unit_Seek;
INTERFACE
    
  PROCEDURE FSEEK(VAR F: FIB; RECNUM: INTEGER);
  
IMPLEMENTATION
    
  Procedure Super (A, B: integer; var Block, Byte: integer);
  
    var
         A_Hi, A_Mid, A_Low, B_Hi, B_Mid, B_Low,
         Little_Total, A_Mid_B_Low, A_Low_B_Mid, A_Low_B_Low: integer;
    
    begin         {of SUPER_DIV}
      
      A_Low := A Mod 32;
      B_Low := B Mod 32;
      
      A_Hi := A Div 1024;
      B_Hi := B Div 1024;
      
      A_Mid := (A mod 1024) DIV 32;
      B_Mid := (B mod 1024) DIV 32;
      
      A_Mid_B_Low := A_Mid * B_Low;
      A_Low_B_Mid := A_Low * B_Mid;
      A_Low_B_Low := A_Low * B_Low;
      
      
      Little_Total := (A_Mid_B_Low * 32 Mod 512) +
                      (A_Low_B_Mid * 32 Mod 512) +
                      (A_Low_B_Low      Mod 512);
      
      Byte := Little_Total Mod 512;
      
      Block := A_Hi * B_Hi * 2048  + A_Hi * B_Mid * 64    + A_Hi * B_Low * 2 
             + A_Mid * B_Hi * 64   + A_MiD * B_MiD * 2    + A_Mid_B_Low Div 16 
             + A_Low * B_Hi * 2    + A_Low_B_Mid Div 16   + A_Low_B_Low Div 512 
             + Little_Total div 512;
      
    end  {of Super};

  PROCEDURE FSEEK(*VAR F: FIB; RECNUM: INTEGER*);
    LABEL 1;
    VAR BYTE,BLOCK,N: INTEGER;
    
    
  BEGIN SYSCOM^.IORSLT := INOERROR;
    IF F.FISOPEN THEN
      WITH F,FHEADER DO
        BEGIN 
          IF (RECNUM < 0) OR NOT FSOFTBUF OR
                  ((DFKIND = TEXTFILE) AND (FRECSIZE = 1)) THEN
            GOTO 1; (*NO SEEK ALLOWED*)
          {
          * Block := RECNUM*FRECSIZE DIV FBLKSIZE + 1;
          * Byte  := RECNUM*FRECSIZE MOD FBLKSIZE;
          }
          Super (Recnum, Frecsize, Block, Byte);
          Block := Block + 1;
          IF BYTE = 0 THEN 
            BEGIN
              BYTE := FBLKSIZE;     
              BLOCK := BLOCK - 1;
              END;
          N := DLASTBLK-DFIRSTBLK;
          IF (BLOCK > N) OR ((BLOCK = N) AND (BYTE >= DLASTBYTE)) THEN
            BEGIN BLOCK := N; BYTE := DLASTBYTE END;
          IF BLOCK <> FNXTBLK THEN
            BEGIN
              IF FBUFCHNGD THEN
                BEGIN FBUFCHNGD := FALSE; FMODIFIED := TRUE;
                  UNITWRITE(FUNIT,FBUFFER,FBLKSIZE,DFIRSTBLK+FNXTBLK-1);
                  IF IORESULT <> ORD(INOERROR) THEN GOTO 1
                END;
              IF (BLOCK <= FMAXBLK) AND (BYTE <> FBLKSIZE) THEN
                BEGIN
                  UNITREAD(FUNIT,FBUFFER,FBLKSIZE,DFIRSTBLK+BLOCK-1);
                  IF IORESULT <> ORD(INOERROR) THEN GOTO 1
                END
            END;
          IF FNXTBLK > FMAXBLK THEN
            BEGIN FMAXBLK := FNXTBLK; FMAXBYTE := FNXTBYTE END
          ELSE
            IF (FNXTBLK = FMAXBLK) AND (FNXTBYTE > FMAXBYTE) THEN
              FMAXBYTE := FNXTBYTE;
          FEOF := FALSE; FEOLN := FALSE; FREPTCNT := 0;
          IF FSTATE <> FJANDW THEN FSTATE := FNEEDCHAR;
          FNXTBLK := BLOCK; FNXTBYTE := BYTE
        END
    ELSE SYSCOM^.IORSLT := INOTOPEN;
  1:
  END (*FSEEK*) ;


END { PASCALIO } ;

(*Dummy level 0 outerblock*)
BEGIN END.


========================================================================================
DOCUMENT :usus Folder:VOL08:fileunit.text
========================================================================================

{$S+}
UNIT FILEUNIT;

{                      George W. Schreyer   
                       412 North Maria Ave.
                       Redondo Beach, California, 90277
                       (213)-376-9348 
    
     This unit may be used for non-commercial purposes only.  Any commercial
use is prohibited without expressed written permission from the author.  
Except where noted this code is all original work. }
                       

INTERFACE

USES (*$U SCREENUNIT.CODE*)SCREENUNIT;

PROCEDURE VER_FILEUNIT;
PROCEDURE REWRT_DISK (VAR FILEID          : XFILE;
                      VAR FILENAME        : STRING;
                      VAR IORESLT         : INTEGER;
                      VAR REWROTE       : BOOLEAN);
PROCEDURE RESET_DISK (VAR FILEID        : XFILE;
                      VAR FILENAME      : STRING;
                      VAR IORESLT       : INTEGER);
PROCEDURE OPNDSKREAD (VAR FILEID        : TEXT;
                          PROMPT        : STRING;
                      VAR FILENAME      : STRING;
                          X             : INTEGER;
                          Y             : INTEGER);
PROCEDURE OPNDSKWRT ( VAR FILEID                : TEXT;
                          PROMPT                : STRING;
                      VAR FILENAME              : STRING;
                          X                     : INTEGER;
                          Y                     : INTEGER);
PROCEDURE GET_FILE_DATE (VAR FILENAME : STRING;
                         VAR DATE     : STRING);
PROCEDURE DIR;
{*****************}

IMPLEMENTATION
{$R-}
{$I-}

{*****************}

     {This record discribes the structure of a UCSD directory.  It was taken
      from Monaco and Soles' procedure DIR in volume 5 of the USUS library.}
     
TYPE 
     DATEREC = PACKED RECORD
                        MONTH: 0..12;
                        DAY: 0..31;
                        YEAR: 0..100
               END;

     DIRRANGE = 0..79;  {this is set to 79 instead of 77 to make the record
                         larger than 4 blocks.  This allows the directory
                         to be read with a blockread without memory allocation
                         problems.  The final two records (or parts of a 
                         record) cannot be accessed because DLOADTIME will 
                         never exceed 77.}

     VID = STRING[7];
     TID = STRING[15];
     FILEKIND = (UNTYPED,XDISK,CODE,TEXT,
                 INFO,DATA,GRAF,FOTO,SECUREDIR);

     DIRENTRY = RECORD
                  DFIRSTBLK: INTEGER;
                  DLASTBLK: INTEGER;
                  CASE DFKIND:FILEKIND OF
                    SECUREDIR,UNTYPED: 
                                       (DVID:VID;
                                        DEOVBLK,
                                        DLOADTIME,
                                        DBLOCKS:INTEGER;
                                        DLASTBOOT:DATEREC);
                    XDISK,CODE,TEXT,INFO,DATA,
                    GRAF,FOTO: 
                               (DTID:TID;
                                DLASTBYTE:1..512;
                                DACCESS:DATEREC)
                END;

     DIRECTORY = ARRAY[DIRRANGE] OF DIRENTRY;


{***************}

PROCEDURE VER_FILEUNIT;
BEGIN
   WRITELN('uses fileunit   version N      20-Jul-81');
END;
      
{****************}

PROCEDURE LEGAL_UNIT(VOLNAME : STRING; 
                     VAR BADUNIT : BOOLEAN);

BEGIN
   BADUNIT:=FALSE;
   IF (VOLNAME <> '') AND (VOLNAME[LENGTH(VOLNAME)] = ':' )   THEN
      BEGIN
        IF VOLNAME <> ':' THEN 
           BEGIN
             DELETE(VOLNAME,POS(':',VOLNAME),1);
             IF POS('#',VOLNAME) =1 THEN
                BEGIN
                  DELETE(VOLNAME,1,1);
                  IF (VOLNAME = '0') OR
                     (VOLNAME = '1') OR
                     (VOLNAME = '2') OR
                     (VOLNAME = '3') OR
                     (VOLNAME = '6') OR
                     (VOLNAME = '7') OR
                     (VOLNAME = '8') THEN BADUNIT:=TRUE; 
                END
              ELSE
                 IF (VOLNAME = 'CONSOLE') OR
                    (VOLNAME = 'SYSTERM') OR
                    (VOLNAME = 'GRAPHIC') OR
                   {(VOLNAME = 'PRINTER') OR}
                    (VOLNAME = 'REMIN') OR
                    (VOLNAME = 'REMOUT') THEN BADUNIT := TRUE;
          END;
    END;
END;
         
PROCEDURE LEGALNAME (VAR FILENAME : STRING;
                     VAR NAMEOK   : BOOLEAN);
VAR
   IORESLT        : INTEGER;
   BADUNIT        : BOOLEAN;
   TESTFILE       : XFILE;

BEGIN
   NAMEOK:=FALSE;
   BADUNIT:=FALSE;
   IF LENGTH(FILENAME)<>0 THEN 
      BEGIN
         LEGAL_UNIT(FILENAME,BADUNIT);
         IF NOT BADUNIT THEN
            BEGIN
              IF (POS('?',FILENAME)<>0) 
                 OR (POS('=',FILENAME)<>0)
                 OR (POS('$',FILENAME)<>0) THEN IO_ERROR(128,FILENAME)
              ELSE
                 IF(POS(',',FILENAME)<>0) THEN IO_ERROR(129,FILENAME)
                 ELSE
                    BEGIN
                      RESET(TESTFILE,FILENAME);
                      IORESLT:=IORESULT;
                      IF IORESLT<>7 THEN NAMEOK:=TRUE 
                         ELSE IO_ERROR(IORESLT,FILENAME);
                      CLOSE(TESTFILE);
                    END;
              END
        ELSE IO_ERROR(3,FILENAME);
     END;
END;    {legalname}

{*****************}

PROCEDURE ADD_TEXT (VAR FILENAME : STRING);

BEGIN
   IF POS('.TEXT',FILENAME)=0 THEN
      BEGIN
         FILENAME:=CONCAT(FILENAME,'.TEXT');
      END;
END;  {add_text}

{*****************}

PROCEDURE REMOVE_SPACES( VAR FILENAME : STRING);

BEGIN
   REPEAT
      DELETE(FILENAME,POS(' ',FILENAME),1);
   UNTIL POS(' ',FILENAME)=0;
END;  {remove_spaces}

{*****************}

PROCEDURE GETFILNAME (VAR FILENAME : STRING;
                          PROMPT   : STRING;
                      VAR X,Y      : INTEGER;
                      VAR GOTNAME  : BOOLEAN);

BEGIN
   GOTNAME:=FALSE;
   REPEAT
      GOTOXY(52,22);
      WRITE('<space> <ret> for directory');
      GOTOXY(65,23);
      WRITE('<ret> to leave');
      GOTOXY(X,Y);
      WRITE(PROMPT,' ');
      READLN(FILENAME);
      GOTOXY(0,22);
      CRT(ERASEOS);
      GOTOXY(X,Y);
      CRT(ERASEOL);
      IF FILENAME='' THEN 
         BEGIN
            GOTOXY(0,0);
            CRT(ERASEOS);
         END
      ELSE
         BEGIN
            IF FILENAME = ' ' THEN 
               BEGIN
                  GOTOXY(0,0);
                  CRT(ERASEOS);
                  DIR;
                  X:=0;
                  Y:=0;
                  GETFILNAME(FILENAME,PROMPT,X,Y,GOTNAME);
               END;
            REMOVE_SPACES(FILENAME);
            LEGALNAME(FILENAME,GOTNAME);
         END;
   UNTIL GOTNAME OR (FILENAME = '');
END;   {getfilname}

{*****************}

PROCEDURE REWRT_DISK{(VAR FILEID          : XFILE;
                      VAR FILENAME        : STRING;
                      VAR IORESLT         : INTEGER;
                      VAR REWROTE         : BOOLEAN)};
  VAR
     REPLY      : CHAR;
     DATE       : STRING;
     TEMP_NAME  : STRING;
     
BEGIN

   IORESLT:=0;
   REWROTE:=FALSE;
   IF FILENAME <> '' THEN 
      BEGIN
         RESET(FILEID,FILENAME);
         IORESLT:=IORESULT;
         CLOSE(FILEID);
         IF IORESLT=0 THEN
            BEGIN
               GOTOXY(0,23);
               TEMP_NAME:=FILENAME;
               GET_FILE_DATE(TEMP_NAME,DATE);
               WRITE(CHR(7),TEMP_NAME,' dated ',DATE,' already exists.  ');
               WRITE('Destroy it? (Y/N) ');
               READ(KEYBOARD,REPLY);
               GOTOXY(0,23);
               CRT(ERASEOL);
               IF REPLY IN [ 'Y','y']  THEN 
                  BEGIN
                     REWRITE(FILEID,FILENAME);
                     IORESLT:=IORESULT;
                     REWROTE:=TRUE;
                  END;
            END
          ELSE
             BEGIN
                REWRITE(FILEID,FILENAME);
                IORESLT:=IORESULT;
                REWROTE:=TRUE;
             END;
       END;
END;  {rewrt_disk}

{*****************}

PROCEDURE RESET_DISK{(VAR FILEID        : XFILE;
                      VAR FILENAME      : STRING;
                      VAR IORESLT       : INTEGER)};

VAR TEMP_NAME : STRING;
                      
   BEGIN
      TEMP_NAME:=FILENAME;
      RESET(FILEID,FILENAME);
      IORESLT:=IORESULT;
      IF IORESLT <> 0 THEN 
         BEGIN
            ADD_TEXT(FILENAME);
            RESET(FILEID,FILENAME);
            IORESLT:=IORESULT;
            IF IORESLT <> 0 THEN FILENAME:=TEMP_NAME;
         END;
   END {reset_disk};

{*****************}

PROCEDURE OPNDSKREAD {(VAR FILEID        : TEXT;
                           PROMPT        : STRING;
                       VAR FILENAME      : STRING;
                           X             : INTEGER;
                           Y             : INTEGER)};

 
VAR
   NAMEOK       :BOOLEAN;
   IORESLT      :INTEGER;
   DATE         :STRING;
   

BEGIN
   IORESLT:=0;
   DATE:='';
   REPEAT
      FILENAME:='';
      GETFILNAME(FILENAME,PROMPT,X,Y,NAMEOK);
      IF NAMEOK THEN 
         BEGIN
           RESET_DISK(FILEID,FILENAME,IORESLT);
           IF IORESLT <> 0 
             THEN IO_ERROR(IORESLT,FILENAME)
             ELSE GET_FILE_DATE(FILENAME,DATE);
         END
      ELSE FILENAME:='';
   UNTIL (IORESLT = 0) OR (FILENAME = '');
END;   {opndskread}

{*****************}

PROCEDURE OPNDSKWRT {( VAR FILEID                : TEXT;
                           PROMPT                : STRING;
                       VAR FILENAME              : STRING;
                           X                     : INTEGER;
                           Y                     : INTEGER)};


VAR
   REWROTE  : BOOLEAN;
   NAMEOK   : BOOLEAN;
   IORESLT  : INTEGER;
   DATE     : STRING;
   
BEGIN
   DATE:='';
   REWROTE:=FALSE;
   REPEAT
      FILENAME:='';
      GETFILNAME(FILENAME,PROMPT,X,Y,NAMEOK);
      IF NAMEOK THEN 
         BEGIN
           ADD_TEXT(FILENAME);
           REWRT_DISK(FILEID,FILENAME,IORESLT,REWROTE);
           IF (IORESLT <> 0) 
              THEN IO_ERROR(IORESLT,FILENAME)
              ELSE GET_FILE_DATE(FILENAME,DATE);
         END;
   UNTIL (REWROTE AND (IORESLT=0)) OR (FILENAME = '');
END;  {opndskwrt}

{****************}

PROCEDURE GET_FILE_DATE {(VAR FILENAME : STRING;
                         VAR DATE     : STRING)};
VAR DIRX : DIRECTORY;
    POS_COLON : INTEGER;
    TEMP_NAME : STRING;
    VOL_ID    : STRING;
    DIREC     : XFILE;
    H,K,Q     : INTEGER;
    MON       : STRING;
    IO_OK     : BOOLEAN;
    DAYSTRING : STRING;
    YEARSTRING: STRING;
    HI,LO     : INTEGER;
    BADUNIT   : BOOLEAN;
    MIS_MATCH : BOOLEAN;
    
          
PROCEDURE DECODE_DATE(DAY,MONTH,YEAR:INTEGER);
   BEGIN
    CASE MONTH OF
      1: MON:='Jan';
      2: MON:='Feb';
      3: MON:='Mar';
      4: MON:='Apr';
      5: MON:='May';
      6: MON:='Jun';
      7: MON:='Jul';
      8: MON:='Aug';
      9: MON:='Sep';
      10:MON:='Oct';
      11:MON:='Nov';
      12:MON:='Dec'
    END;
    STR(DAY,DAYSTRING);
    STR(YEAR,YEARSTRING);
 END;
                
BEGIN   {get_file_date}
   DATE:='';
   Q:=0;
   MON:='';
   DAYSTRING:='';
   YEARSTRING:='';
   LEGAL_UNIT(FILENAME,BADUNIT);
   IF (FILENAME <> '') AND (NOT BADUNIT) THEN
      BEGIN
        POS_COLON:=POS(':',FILENAME);
        IF POS('*',FILENAME) = 1 THEN
           BEGIN
              VOL_ID:='*';
              IF LENGTH(FILENAME) = 1 THEN TEMP_NAME:=''
              ELSE 
                 BEGIN
                    TEMP_NAME:=FILENAME;
                    DELETE(TEMP_NAME,1,1);
                 END;
           END
        ELSE
           BEGIN
              IF POS_COLON > 0 THEN
                 BEGIN
                    IF LENGTH(FILENAME) = 1 THEN
                       BEGIN
                          TEMP_NAME:='';
                          VOL_ID:=':';
                       END
                    ELSE
                       BEGIN
                          IF POS_COLON = LENGTH(FILENAME) THEN
                             BEGIN
                                VOL_ID:=FILENAME;
                                TEMP_NAME:='';
                             END
                          ELSE
                             BEGIN
                                TEMP_NAME:=COPY(FILENAME,POS_COLON+1,
                                   LENGTH(FILENAME)-POS_COLON);
                                VOL_ID:=COPY(FILENAME,1,POS_COLON);
                             END;
                       END;
                 END
              ELSE
                 BEGIN
                    VOL_ID:=':';
                    TEMP_NAME:=FILENAME;
                 END;
           END;
        RESET(DIREC,VOL_ID);
        FOR H:= 1 TO LENGTH(TEMP_NAME) DO
           IF TEMP_NAME[H] IN ['a'..'z'] THEN
              TEMP_NAME[H]:=CHR(ORD(TEMP_NAME[H])-32);
        IF IORESULT = 0 THEN 
           BEGIN
             K:=BLOCKREAD(DIREC,DIRX,4,2);
             IF IORESULT = 0 THEN
                BEGIN
                   IF FILENAME <> '' THEN
                      BEGIN
                         FOR K:=1 TO DIRX[0].DLOADTIME DO 
                            WITH DIRX[K] DO 
                               BEGIN
                                 MISMATCH:=FALSE;
                                 H:=0;
                                 REPEAT
                                    IF (DTID[H] = TEMP_NAME[H])
                                      THEN H:=H+1
                                      ELSE MISMATCH:=TRUE;
                                 UNTIL MIS_MATCH OR (H=LENGTH(DTID));
                                 IF NOT MISMATCH THEN Q:=K;
                               END;
                      END;
                   IF (VOL_ID = '*') AND (TEMP_NAME = '') THEN
                      WITH DIRX[0].DLASTBOOT DO
                        BEGIN
                           DECODE_DATE(DAY,MONTH,YEAR);
                           Q:=1;
                        END
                   ELSE WITH DIRX[Q].DACCESS DO 
                      DECODE_DATE(DAY,MONTH,YEAR); 
                   IF Q <> 0 THEN DATE:=CONCAT(DAYSTRING,'-',MON,'-',
                      YEARSTRING);
                   WITH DIRX[0] DO VOL_ID:=CONCAT(DVID,':');
                   FILENAME:=CONCAT(VOL_ID,TEMP_NAME);
                END;
           END;
      END;
   CLOSE(DIREC);
END;   {get_file_date}
  
{****************}

PROCEDURE DIR;

TYPE POINTER_ARRAY = ARRAY [DIRRANGE] OF INTEGER;

VAR DIRX : DIRECTORY;
    BADUNIT : BOOLEAN;
    ROW,COLUMN : INTEGER;
    VOLNAME : STRING;
    DIREC : XFILE;
    K,I: INTEGER;
    INDEX: POINTER_ARRAY;
    NAME_OK : BOOLEAN;



PROCEDURE SWAP(VAR P,Q : INTEGER);
VAR HOLD : INTEGER;
BEGIN
   HOLD:=P;
   P:=Q;
   Q:=HOLD;
END;

PROCEDURE NR_QUICK_SORT(VAR DIRX : DIRECTORY;
                        VAR INDEX : POINTER_ARRAY;
                            FIRST,LAST:INTEGER);

{this procedure was taken from "PASCAL PROGRAMS FOR SCIENTISTS AND ENGINEERS"
 by Alan R. Miller, published by SYBEX.  You ought to buy it, its a very good
 book}

VAR
   LEFT,RIGHT : ARRAY [1..20] OF INTEGER;
   I,J,SP,MID : INTEGER;
   PIVOT : STRING;
   
BEGIN
   LEFT[1]:=FIRST;
   RIGHT[1]:=LAST;
   SP:=1;
   WHILE SP > 0 DO
      BEGIN
         IF LEFT[SP]>= RIGHT[SP] THEN SP:=SP-1
         ELSE
            BEGIN
            I:=LEFT[SP];
            J:=RIGHT[SP];
            PIVOT:=DIRX[INDEX[J]].DTID;
            MID:=(I+J) DIV 2;
            IF (J-I) > 5 THEN
               IF ((DIRX[INDEX[MID]].DTID < PIVOT) AND
                   (DIRX[INDEX[MID]].DTID > DIRX[INDEX[I]].DTID)) OR
                  ((DIRX[INDEX[MID]].DTID > PIVOT) AND
                   (DIRX[INDEX[MID]].DTID < DIRX[INDEX[I]].DTID)) THEN
                   SWAP(INDEX[MID],INDEX[J])
               ELSE
                  IF ((DIRX[INDEX[I]].DTID < DIRX[INDEX[MID]].DTID) AND
                      (DIRX[INDEX[I]].DTID > PIVOT)) OR
                     ((DIRX[INDEX[I]].DTID > DIRX[INDEX[MID]].DTID) AND
                      (DIRX[INDEX[I]].DTID < PIVOT)) THEN
                      SWAP(INDEX[I],INDEX[J]);
             PIVOT:=DIRX[INDEX[J]].DTID;
             WHILE I < J DO
                BEGIN
                   WHILE DIRX[INDEX[I]].DTID < PIVOT DO I:=I+1;
                   J:=J-1;
                   WHILE (I < J) AND (PIVOT < DIRX[INDEX[J]].DTID) DO
                      J:=J-1;
                   IF I < J THEN SWAP(INDEX[I],INDEX[J]);
                END;
             J:=RIGHT[SP];
             SWAP(INDEX[I],INDEX[J]);
             IF (I-LEFT[SP]) >= (RIGHT[SP] - I) THEN
                BEGIN
                   LEFT[SP+1]:=LEFT[SP];
                   RIGHT[SP+1]:= I-1;
                   LEFT[SP]:=I+1;
                END
             ELSE
                BEGIN
                   LEFT[SP+1]:=I+1;
                   RIGHT[SP+1]:=RIGHT[SP];
                   RIGHT[SP]:=I-1;
                END;
             SP:=SP+1;
          END;
    END;
 END;
                
PROCEDURE ALPHABETIZE_DIRECTORY;

VAR I : INTEGER;

BEGIN
   FOR I:=1 TO DIRX[0].DLOADTIME DO INDEX[I]:=I;
   NR_QUICK_SORT(DIRX,INDEX,1,DIRX[0].DLOADTIME);
END;

PROCEDURE MAKE_LOWER_CASE( VAR STRG :STRING);
VAR QQ : INTEGER;
BEGIN
  FOR QQ:=1 TO LENGTH(STRG) DO
       IF STRG[QQ] IN ['A'..'Z'] THEN
         STRG[QQ]:=CHR(ORD(STRG[QQ])+32);
END;

PROCEDURE VOLUMES;

VAR
    I,K         : INTEGER;
    DISK        : XFILE;
    VOLID,STRG  : STRING;
    VOLNAME     : STRING;
    DATE        : STRING;

BEGIN
   GOTOXY(0,5);
   FOR I:=4 TO 12 DO IF I IN [4,5,9,10,11,12] THEN
      BEGIN
         STR(I,STRG);
         VOLNAME:=CONCAT('#',STRG,':');
         RESET(DISK,VOLNAME);
         IF IORESULT = 0 THEN
            BEGIN
               K:=BLOCKREAD(DISK,DIRX,4,2);
               IF IORESULT = 0 
                  THEN 
                     BEGIN
                        VOLID:=DIRX[0].DVID;
                        MAKE_LOWER_CASE(VOLID);
                        VOLID:=CONCAT('  ',VOLID,':');
                        WRITELN('#',I:2,VOLID);
                     END;
               CLOSE(DISK);
            END;
      END;
   WRITELN;
   VOLID:='*';
   GET_FILE_DATE(VOLID,DATE);
   WRITELN('  root volume is ',volid,'   system date is ',date);
   VOLID:=':';
   GET_FILE_DATE(VOLID,DATE);
   WRITELN('prefix volume is ',volid);
      
END;
      
BEGIN  {dir}
 
  REPEAT
     REPEAT
        VOLNAME:='';
        NAME_OK:=TRUE;
        GOTOXY(54,22);
        WRITE('<space> <ret> for volumes');
        GOTOXY(65,23);
        WRITE('<ret> to leave');
        GOTOXY(0,3);
        WRITE('volume of directory to display ? ');
        READLN(VOLNAME);
        GOTOXY(0,0);
        CRT(ERASEOS);
        IF VOLNAME = '' THEN EXIT(DIR);
        IF VOLNAME = ' ' THEN VOLUMES;
     UNTIL VOLNAME <> ' ';
     REMOVE_SPACES(VOLNAME);
     IF (POS(':',VOLNAME) <> LENGTH(VOLNAME)) AND
        (VOLNAME <> '*') THEN VOLNAME:=CONCAT(VOLNAME,':');
     LEGAL_UNIT(VOLNAME,BADUNIT);
     IF BADUNIT OR (VOLNAME='PRINTER:') THEN
        BEGIN
          GOTOXY(0,23);
          WRITE(CHR(7),'Unit ',VOLNAME,' has no directory');
          NAME_OK:=FALSE;
        END;
     IF NAME_OK THEN 
        BEGIN
          REMOVE_SPACES(VOLNAME);
          LEGALNAME(VOLNAME,NAME_OK);
          RESET(DIREC,VOLNAME);
          IF IORESULT <> 0
            THEN
              BEGIN
                 IO_ERROR(9,VOLNAME);
                 NAME_OK:=FALSE;
              END;
        END;
  UNTIL NAME_OK;
  K:=BLOCKREAD(DIREC,DIRX,4,2);
  CLOSE(DIREC);
  ALPHABETIZE_DIRECTORY;
  GOTOXY(0,2);
  WITH DIRX[0] DO
     BEGIN
        MAKE_LOWER_CASE(DVID);
        WRITELN('vol = ',DVID,':');
     END;
  ROW:=4;
  COLUMN:=0;
  FOR I:=1 TO DIRX[0].DLOADTIME DO
    BEGIN
      WITH DIRX[INDEX[I]] DO
         BEGIN
           GOTOXY(COLUMN,ROW);
           MAKE_LOWER_CASE(DTID);
           WRITE(DTID,' ':16-LENGTH(DTID));
           ROW:=ROW+1;
           IF (ROW MOD 22 = 0) OR ((COLUMN =0) AND (ROW = 21)) THEN
              BEGIN
                 COLUMN:=COLUMN+20;
                 ROW:=2;
              END;
         END;
    END;
END; 

END.



========================================================================================
DOCUMENT :usus Folder:VOL08:global.ii0.text
========================================================================================

(*$U-*)
    
{ This is an unpublished work copyright by The Regents of the University
  of California.  This item is the property of SofTech MicroSystems Inc.,
  and it may be used, copied, or distributed only as permitted in a 
  written license from that company.}

PROGRAM PASCALSYSTEM;

(************************************************)
(*                                              *)
(*    UCSD PASCAL OPERATING SYSTEM              *)
(*                                              *)
(*    RELEASE LEVEL:  I.3   AUGUST, 1977        *)
(*                    I.4   JANUARY, 1978       *)
(*                    I.5   SEPTEMBER, 1978     *)
(*                    II.0  FEBRUARY, 1978 BD   *)
(*                                              *)
(*    WRITTEN BY ROGER T. SUMNER                *)
(*    WINTER 1977                               *)
(*                                              *)
(*    INSTITUTE FOR INFORMATION SYSTEMS         *)
(*    UC SAN DIEGO, LA JOLLA, CA                *)
(*                                              *)
(*    KENNETH L. BOWLES, DIRECTOR               *)
(*                                              *)
(************************************************)

CONST
     MMAXINT = 32767;   (*MAXIMUM INTEGER VALUE*)
     MAXUNIT = 12;      (*MAXIMUM PHYSICAL UNIT # FOR UREAD*)
     MAXDIR = 77;       (*MAX NUMBER OF ENTRIES IN A DIRECTORY*)
     VIDLENG = 7;       (*NUMBER OF CHARS IN A VOLUME ID*)
     TIDLENG = 15;      (*NUMBER OF CHARS IN TITLE ID*)
     MAXSEG = 15;       (*MAX CODE SEGMENT NUMBER*)
     FBLKSIZE = 512;    (*STANDARD DISK BLOCK LENGTH*)
     DIRBLK = 2;        (*DISK ADDR OF DIRECTORY*)
     AGELIMIT = 300;    (*MAX AGE FOR GDIRP...IN TICKS*)
     EOL = 13;          (*END-OF-LINE...ASCII CR*)
     DLE = 16;          (*BLANK COMPRESSION CODE*)
     NAME_LEN = 23;     {Length of CONCAT(VIDLENG,':',TIDLENG)}
     FILL_LEN = 11;     {Maximum # of nulls in FILLER}

TYPE

     IORSLTWD = (INOERROR,IBADBLOCK,IBADUNIT,IBADMODE,ITIMEOUT,
                 ILOSTUNIT,ILOSTFILE,IBADTITLE,INOROOM,INOUNIT,
                 INOFILE,IDUPFILE,INOTCLOSED,INOTOPEN,IBADFORMAT,
                 ISTRGOVFL);

                                        (*COMMAND STATES...SEE GETCMD*)

     CMDSTATE = (HALTINIT,DEBUGCALL,
                 UPROGNOU,UPROGUOK,SYSPROG,
                 COMPONLY,COMPANDGO,COMPDEBUG,
                 LINKANDGO,LINKDEBUG);
     
                                        (*CODE FILES USED IN GETCMD*)
                                        
     SYSFILE = (ASSMBLER,COMPILER,EDITOR,FILER,LINKER);

                                        (*ARCHIVAL INFO...THE DATE*)

     DATEREC = PACKED RECORD
                 MONTH: 0..12;          (*0 IMPLIES DATE NOT MEANINGFUL*)
                 DAY: 0..31;            (*DAY OF MONTH*)
                 YEAR: 0..100           (*100 IS TEMP DISK FLAG*)
               END (*DATEREC*) ;

                                        (*VOLUME TABLES*)
     UNITNUM = 0..MAXUNIT;
     VID = STRING[VIDLENG];

                                        (*DISK DIRECTORIES*)
     DIRRANGE = 0..MAXDIR;
     TID = STRING[TIDLENG];
     FULL_ID = STRING[NAME_LEN];

     FILE_TABLE = ARRAY [SYSFILE] OF FULL_ID;
     
     FILEKIND = (UNTYPEDFILE,XDSKFILE,CODEFILE,TEXTFILE,
                 INFOFILE,DATAFILE,GRAFFILE,FOTOFILE,SECUREDIR);

     DIRENTRY = PACKED RECORD
                  DFIRSTBLK: INTEGER;   (*FIRST PHYSICAL DISK ADDR*)
                  DLASTBLK: INTEGER;    (*POINTS AT BLOCK FOLLOWING*)
                  CASE DFKIND: FILEKIND OF
                    SECUREDIR,
                    UNTYPEDFILE: (*ONLY IN DIR[0]...VOLUME INFO*)
                       (FILLER1 : 0..2048; {for downward compatibility,13 bits}
                        DVID: VID;              (*NAME OF DISK VOLUME*)
                        DEOVBLK: INTEGER;       (*LASTBLK OF VOLUME*)
                        DNUMFILES: DIRRANGE;    (*NUM FILES IN DIR*)
                        DLOADTIME: INTEGER;     (*TIME OF LAST ACCESS*)
                        DLASTBOOT: DATEREC);    (*MOST RECENT DATE SETTING*)
                    XDSKFILE,CODEFILE,TEXTFILE,INFOFILE,
                    DATAFILE,GRAFFILE,FOTOFILE:
                       (FILLER2 : 0..1024; {for downward compatibility}
                        STATUS : BOOLEAN;        {for FILER wildcards}
                        DTID: TID;              (*TITLE OF FILE*)
                        DLASTBYTE: 1..FBLKSIZE; (*NUM BYTES IN LAST BLOCK*)
                        DACCESS: DATEREC)       (*LAST MODIFICATION DATE*)
                END (*DIRENTRY*) ;

     DIRP = ^DIRECTORY;

     DIRECTORY = ARRAY [DIRRANGE] OF DIRENTRY;

                                        (*FILE INFORMATION*)

     CLOSETYPE = (CNORMAL,CLOCK,CPURGE,CCRUNCH);
     WINDOWP = ^WINDOW;
     WINDOW = PACKED ARRAY [0..0] OF CHAR;
     FIBP = ^FIB;

     FIB = RECORD
             FWINDOW: WINDOWP;  (*USER WINDOW...F^, USED BY GET-PUT*)
             FEOF,FEOLN: BOOLEAN;
             FSTATE: (FJANDW,FNEEDCHAR,FGOTCHAR);
             FRECSIZE: INTEGER; (*IN BYTES...0=>BLOCKFILE, 1=>CHARFILE*)
             CASE FISOPEN: BOOLEAN OF
               TRUE: (FISBLKD: BOOLEAN; (*FILE IS ON BLOCK DEVICE*)
                      FUNIT: UNITNUM;   (*PHYSICAL UNIT #*)
                      FVID: VID;        (*VOLUME NAME*)
                      FREPTCNT,         (* # TIMES F^ VALID W/O GET*)
                      FNXTBLK,          (*NEXT REL BLOCK TO IO*)
                      FMAXBLK: INTEGER; (*MAX REL BLOCK ACCESSED*)
                      FMODIFIED:BOOLEAN;(*PLEASE SET NEW DATE IN CLOSE*)
                      FHEADER: DIRENTRY;(*COPY OF DISK DIR ENTRY*)
                      CASE FSOFTBUF: BOOLEAN OF (*DISK GET-PUT STUFF*)
                        TRUE: (FNXTBYTE,FMAXBYTE: INTEGER;
                               FBUFCHNGD: BOOLEAN;
                               FBUFFER: PACKED ARRAY [0..FBLKSIZE] OF CHAR))
           END (*FIB*) ;

                                        (*USER WORKFILE STUFF*)

     INFOREC = RECORD
                 SYMFIBP,CODEFIBP: FIBP;        (*WORKFILES FOR SCRATCH*)
                 ERRSYM,ERRBLK,ERRNUM: INTEGER; (*ERROR STUFF IN EDIT*)
                 SLOWTERM,STUPID: BOOLEAN;      (*STUDENT PROGRAMMER ID!!*)
                 ALTMODE: CHAR;                 (*WASHOUT CHAR FOR COMPILER*)
                 GOTSYM,GOTCODE: BOOLEAN;       (*TITLES ARE MEANINGFUL*)
                 WORKVID,SYMVID,CODEVID: VID;   (*PERM&CUR WORKFILE VOLUMES*)
                 WORKTID,SYMTID,CODETID: TID    (*PERM&CUR WORKFILES TITLE*)
               END (*INFOREC*) ;

                                        (*CODE SEGMENT LAYOUTS*)

     SEGRANGE = 0..MAXSEG;
     SEGDESC = RECORD
                 DISKADDR: INTEGER;     (*REL BLK IN CODE...ABS IN SYSCOM^*)
                 CODELENG: INTEGER      (*# BYTES TO READ IN*)
               END (*SEGDESC*) ;

                                        (*DEBUGGER STUFF*)

     BYTERANGE = 0..255;
     TRICKARRAY = RECORD        {Memory diddling for execerror}
                    CASE BOOLEAN OF
                      TRUE : (WORD : ARRAY [0..0] OF INTEGER); 
                      FALSE : (BYTE : PACKED ARRAY [0..0] OF BYTERANGE)
                    END;
     MSCWP = ^ MSCW;            (*MARK STACK RECORD POINTER*)
     MSCW = RECORD
              STATLINK: MSCWP;  (*POINTER TO PARENT MSCW*)
              DYNLINK: MSCWP;   (*POINTER TO CALLER'S MSCW*)
              MSSEG,MSJTAB: ^TRICKARRAY;
              MSIPC: INTEGER;
              LOCALDATA: TRICKARRAY
            END (*MSCW*) ;

                                        (*SYSTEM COMMUNICATION AREA*)
                                        (*SEE INTERPRETERS...NOTE  *)
                                        (*THAT WE ASSUME BACKWARD  *)
                                        (*FIELD ALLOCATION IS DONE *)
     SYSCOMREC = RECORD
                   IORSLT: IORSLTWD;    (*RESULT OF LAST IO CALL*)
                   XEQERR: INTEGER;     (*REASON FOR EXECERROR CALL*)
                   SYSUNIT: UNITNUM;    (*PHYSICAL UNIT OF BOOTLOAD*)
                   BUGSTATE: INTEGER;   (*DEBUGGER INFO*)
                   GDIRP: DIRP;         (*GLOBAL DIR POINTER,SEE VOLSEARCH*)
                   LASTMP,STKBASE,BOMBP: MSCWP;
                   MEMTOP,SEG,JTAB: INTEGER;
                   BOMBIPC: INTEGER;    (*WHERE XEQERR BLOWUP WAS*)
                   HLTLINE: INTEGER;    (*MORE DEBUGGER STUFF*)
                   BRKPTS: ARRAY [0..3] OF INTEGER;
                   RETRIES: INTEGER;    (*DRIVERS PUT RETRY COUNTS*)
                   EXPANSION: ARRAY [0..8] OF INTEGER;
                   HIGHTIME,LOWTIME: INTEGER;
                   MISCINFO: PACKED RECORD
                               NOBREAK,STUPID,SLOWTERM,
                               HASXYCRT,HASLCCRT,HAS8510A,HASCLOCK: BOOLEAN;
                               USERKIND:(NORMAL, AQUIZ, BOOKER, PQUIZ);
                               IS_FLIPT : BOOLEAN
                             END;
                   CRTTYPE: INTEGER;
                   CRTCTRL: PACKED RECORD
                              RLF,NDFS,ERASEEOL,ERASEEOS,HOME,ESCAPE: CHAR;
                              BACKSPACE: CHAR;
                              FILLCOUNT: 0..255;
                              CLEARSCREEN, CLEARLINE: CHAR;
                              PREFIXED: PACKED ARRAY [0..8] OF BOOLEAN
                            END;
                   CRTINFO: PACKED RECORD
                              WIDTH,HEIGHT: INTEGER;
                              RIGHT,LEFT,DOWN,UP: CHAR;
                              BADCH,CHARDEL,STOP,BREAK,FLUSH,EOF: CHAR;
                              ALTMODE,LINEDEL: CHAR;
                              BACKSPACE,ETX,PREFIX: CHAR;
                              PREFIXED: PACKED ARRAY [0..13] OF BOOLEAN
                            END;
                   SEGTABLE: ARRAY [SEGRANGE] OF
                               RECORD
                                 CODEUNIT: UNITNUM;
                                 CODEDESC: SEGDESC
                               END
                 END (*SYSCOM*);

     MISCINFOREC = RECORD
                     MSYSCOM: SYSCOMREC
                   END;

VAR
    SYSCOM: ^SYSCOMREC;                 (*MAGIC PARAM...SET UP IN BOOT*)
    GFILES: ARRAY [0..5] OF FIBP;       (*GLOBAL FILES, 0=INPUT, 1=OUTPUT*)
    USERINFO: INFOREC;                  (*WORK STUFF FOR COMPILER ETC*)
    EMPTYHEAP: ^INTEGER;                (*HEAP MARK FOR MEM MANAGING*)
    INPUTFIB,OUTPUTFIB,                 (*CONSOLE FILES...GFILES ARE COPIES*)
    SYSTERM,SWAPFIB: FIBP;              (*CONTROL AND SWAPSPACE FILES*)
    SYVID,DKVID: VID;                   (*SYSUNIT VOLID & DEFAULT VOLID*)
    THEDATE: DATEREC;                   (*TODAY...SET IN FILER OR SIGN ON*)
    DEBUGINFO: ^INTEGER;                (*DEBUGGERS GLOBAL INFO WHILE RUNIN*)
    STATE: CMDSTATE;                    (*FOR GETCOMMAND*)
    PL: STRING;                         (*PROMPTLINE STRING...SEE PROMPT*)
    IPOT: ARRAY [0..4] OF INTEGER;      (*INTEGER POWERS OF TEN*)
    FILLER: STRING[FILL_LEN];           (*NULLS FOR CARRIAGE DELAY*)
    DIGITS: SET OF '0'..'9';
    UNITABLE: ARRAY [UNITNUM] OF (*0 NOT USED*)
                RECORD
                  UVID: VID;    (*VOLUME ID FOR UNIT*)
                  CASE UISBLKD: BOOLEAN OF
                    TRUE: (UEOVBLK: INTEGER)
                END (*UNITABLE*) ;
    FILENAME : FILE_TABLE;
    
(*-------------------------------------------------------------------------*)
(* SYSTEM PROCEDURE FORWARD DECLARATIONS *)
(* THESE ARE ADDRESSED BY OBJECT CODE... *)
(*  DO NOT MOVE WITHOUT CAREFUL THOUGHT  *)

PROCEDURE EXECERROR;
  FORWARD;
PROCEDURE FINIT(VAR F: FIB; WINDOW: WINDOWP; RECWORDS: INTEGER);
  FORWARD;
PROCEDURE FRESET(VAR F: FIB);
  FORWARD;
PROCEDURE FOPEN(VAR F: FIB; VAR FTITLE: STRING;
                FOPENOLD: BOOLEAN; JUNK: FIBP);
  FORWARD;
PROCEDURE FCLOSE(VAR F: FIB; FTYPE: CLOSETYPE);
  FORWARD;
PROCEDURE FGET(VAR F: FIB);
  FORWARD;
PROCEDURE FPUT(VAR F: FIB);
  FORWARD;
PROCEDURE XSEEK;
  FORWARD;
FUNCTION FEOF(VAR F: FIB): BOOLEAN;
  FORWARD;
FUNCTION FEOLN(VAR F: FIB): BOOLEAN;
  FORWARD;
PROCEDURE FREADINT(VAR F: FIB; VAR I: INTEGER);
  FORWARD;
PROCEDURE FWRITEINT(VAR F: FIB; I,RLENG: INTEGER);
  FORWARD;
PROCEDURE XREADREAL;
  FORWARD;
PROCEDURE XWRITEREAL;
  FORWARD;
PROCEDURE FREADCHAR(VAR F: FIB; VAR CH: CHAR);
  FORWARD;
PROCEDURE FWRITECHAR(VAR F: FIB; CH: CHAR; RLENG: INTEGER);
  FORWARD;
PROCEDURE FREADSTRING(VAR F: FIB; VAR S: STRING; SLENG: INTEGER);
  FORWARD;
PROCEDURE FWRITESTRING(VAR F: FIB; VAR S: STRING; RLENG: INTEGER);
  FORWARD;
PROCEDURE FWRITEBYTES(VAR F: FIB; VAR A: WINDOW; RLENG,ALENG: INTEGER);
  FORWARD;
PROCEDURE FREADLN(VAR F: FIB);
  FORWARD;
PROCEDURE FWRITELN(VAR F: FIB);
  FORWARD;
PROCEDURE SCONCAT(VAR DEST,SRC: STRING; DESTLENG: INTEGER);
  FORWARD;
PROCEDURE SINSERT(VAR SRC,DEST: STRING; DESTLENG,INSINX: INTEGER);
  FORWARD;
PROCEDURE SCOPY(VAR SRC,DEST: STRING; SRCINX,COPYLENG: INTEGER);
  FORWARD;
PROCEDURE SDELETE(VAR DEST: STRING; DELINX,DELLENG: INTEGER);
  FORWARD;
FUNCTION SPOS(VAR TARGET,SRC: STRING): INTEGER;
  FORWARD;
FUNCTION FBLOCKIO(VAR F: FIB; VAR A: WINDOW; I: INTEGER;
                  NBLOCKS,RBLOCK: INTEGER; DOREAD: BOOLEAN): INTEGER;
  FORWARD;
PROCEDURE FGOTOXY(X,Y: INTEGER);
  FORWARD;

(* NON FIXED FORWARD DECLARATIONS *)

FUNCTION VOLSEARCH(VAR FVID: VID; LOOKHARD: BOOLEAN;
                   VAR FDIR: DIRP): UNITNUM;
  FORWARD;
PROCEDURE WRITEDIR(FUNIT: UNITNUM; FDIR: DIRP);
  FORWARD;
FUNCTION DIRSEARCH(VAR FTID: TID; FINDPERM: BOOLEAN; FDIR: DIRP): DIRRANGE;
  FORWARD;
FUNCTION SCANTITLE(FTITLE: STRING; VAR FVID: VID; VAR FTID: TID;
                   VAR FSEGS: INTEGER; VAR FKIND: FILEKIND): BOOLEAN;
  FORWARD;
PROCEDURE DELENTRY(FINX: DIRRANGE; FDIR: DIRP);
  FORWARD;
PROCEDURE INSENTRY(VAR FENTRY: DIRENTRY; FINX: DIRRANGE; FDIR: DIRP);
  FORWARD;
PROCEDURE HOMECURSOR;
  FORWARD;
PROCEDURE CLEARSCREEN;
  FORWARD;
PROCEDURE CLEARLINE;
  FORWARD;
PROCEDURE PROMPT;
  FORWARD;
FUNCTION SPACEWAIT(FLUSH: BOOLEAN): BOOLEAN;
  FORWARD;
FUNCTION GETCHAR(FLUSH: BOOLEAN): CHAR;
  FORWARD;
FUNCTION FETCHDIR(FUNIT:UNITNUM) : BOOLEAN;
  FORWARD;
PROCEDURE COMMAND;
  FORWARD;



========================================================================================
DOCUMENT :usus Folder:VOL08:global.iii.text
========================================================================================

{$U-}
(***************************************************************
 *   Copyright (c) Western Digital, Newport Beach, CA, 1981.   *
 *   This documentation is provided for information purposes   *
 *   only.  Definitions may change in future versions of the   *
 *   Western Digital operating system.                         *
 ***************************************************************)

{***NOTE added by J. Gagne:  this file was originally in three parts:
   HEADER.TEXT, GLOBALS.TEXT, and FORWARDS.TEXT.  They have been
   combined for brevity and clarity; points where new files began are
   noted.  This portion was called HEADER.TEXT.
}

    { **************************************************************** }
    {                                                                  }
    {   Copyright (c) 1979 Regents of the University of California.    }
    {   Permission to copy or distribute this software or documen-     }
    {   tation in hard or soft copy granted only by written license    } 
    {   obtained from the Institute for Information Systems.           }
    {                                                                  }
    { **************************************************************** }
    
program pascalsystem;

{ ********************************************** }
{                                                }
{     UCSD PASCAL OPERATING SYSTEM               }
{                                                }
{     RELEASE LEVEL:  I.3   AUGUST, 1977         }
{ 		      I.4   JANUARY, 1978	 }
{                     I.5   SEPTEMBER, 1978      }
{		    III.0   JANUARY, 1979        }     
{                                                }                     
{     WRITTEN BY ROGER T. SUMNER                 }
{     WINTER 1977                                }
{                                                }
{     INSTITUTE FOR INFORMATION SYSTEMS          }
{     UC SAN DIEGO, LA JOLLA, CA                 }
{                                                }
{     KENNETH L. BOWLES, DIRECTOR                }
{                                                }
{ ********************************************** }

{***NOTE:  This next section had been called GLOBALS.TEXT}

const
     mmaxint  = 32767; { maximum integer value }
     maxunit  =    16; { maximum physical unit # for uread }
     maxdir   =    77; { max number of entries in a directory }
     vidleng  =     7; { number of chars in a volume id }
     tidleng  =    15; { number of chars in title id }
     maxseg   =    15; { max code segment number }
     fblksize =   512; { standard disk block length }
     dirblk   =     2; { disk addr of directory }
     agelimit =   300; { max age for gdirp...in ticks }
     eol      =    13; { end-of-line ...ASCII cr }
     dle      =    16; { blank compression code }
     maxq     =    79; { type-ahead queue index limit }
     maxqp1   =    80; { type-ahead queue length }
     maxretry =    10; { retry count for disk drivers }
     
     hiiopriority  = 250; { kbddriver (serial in) processes  }
     midiopriority = 245; { disk in/out, parallel out, serial out }
     lowiopriority = 240; { enabler process for kbddrivers }

TYPE

     iorsltwd = (inoerror,ibadblock,ibadunit,ibadmode,itimeout,
                 ilostunit,ilostfile,ibadtitle,inoroom,inounit,
                 inofile,idupfile,inotclosed,inotopen,ibadformat,
                 istrgovfl);

                                        { COMMAND STATES...SEE GETCMD }

     cmdstate = (haltinit,debugcall,
                 uprognou,uproguok,sysprog,
                 componly,compandgo,compdebug,
                 linkandgo,linkdebug);
     
                                        { CODE FILES USED IN GETCMD }

     sysfile = (assmbler,compiler,editor,filer,linker);

                                        { ARCHIVAL INFO...THE DATE }

     daterec = packed record
                 month: 0..12;  	{ 0 IMPLIES DATE NOT MEANINGFUL } 
                 day:   0..31;  	{ DAY OF MONTH } 
                 year:  0..100  	{ 100 IS TEMP DISK FLAG }
               end { DATEREC } ;

                                        { VOLUME TABLES }
     unitnum = 0..maxunit;
     vid = string[vidleng];

                                        { DISK DIRECTORIES }
     dirrange = 0..maxdir;
     tid = string[tidleng];

     filekind = (untypedfile,xdskfile,codefile,textfile,
                 infofile,datafile,graffile,fotofile,securedir);

     direntry = record
                  dfirstblk: integer; { FIRST PHYSICAL DISK ADDR }
                  dlastblk: integer;  { POINTS AT BLOCK FOLLOWING } 
                  case dfkind: filekind of
                    securedir,
                    untypedfile: { ONLY IN DIR[0]...VOLUME INFO }
                       (dvid: vid;            	{ NAME OF DISK VOLUME } 
                        deovblk: integer;     { LASTBLK OF VOLUME }
                        dnumfiles: dirrange;  { NUM FILES IN DIR } 
                        dloadtime: integer;   { TIME OF LAST ACCESS }
                        dlastboot: daterec);  { MOST RECENT DATE SETTING } 
                    xdskfile,codefile,textfile,infofile,
                    datafile,graffile,fotofile:
                       (dtid: tid;              	{ TITLE OF FILE } 
                        dlastbyte: 1..fblksize; { NUM BYTES IN LAST BLOCK }
                        daccess: daterec)       { LAST MODIFICATION DATE }
                end { DIRENTRY } ;

     dirp = ^directory;

     directory = array [dirrange] of direntry;

                                        { FILE INFORMATION }

     closetype = (cnormal,clock,cpurge,ccrunch);
     windowp = ^window;
     window = packed array [0..0] of char;
     fibp = ^fib;

     fib = record
             fwindow: windowp;    { USER WINDOW...F^, USED BY GET-PUT } 
             feof,feoln: boolean;
             fstate: (fjandw,fneedchar,fgotchar);
             frecsize: integer;   { IN BYTES...0=>BLOCKFILE, 1=>CHARFILE }
             case fisopen: boolean of
               true: (fisblkd: boolean;  { FILE IS ON BLOCK DEVICE } 
                      funit: unitnum;    { PHYSICAL UNIT # } 
                      fvid: vid;         { VOLUME NAME }
                      freptcnt,          { # TIMES F^ VALID W/O GET } 
                      fnxtblk,           	{ NEXT REL BLOCK TO IO }
                      fmaxblk: integer;  { MAX REL BLOCK ACCESSED } 
                      fmodified:boolean; { SET NEW DATE IN CLOSE }
                      fheader: direntry; { COPY OF DISK DIR ENTRY } 
                      case fsoftbuf: boolean of { DISK GET-PUT STUFF }
                        true: (fnxtbyte,fmaxbyte: integer;
                               fbufchngd: boolean;
                               fbuffer: packed array [0..fblksize] of char))
           end { FIB } ;

                                        { USER WORKFILE STUFF }

     inforec = record
                 symfibp,codefibp: fibp;        { WORKFILES FOR SCRATCH } 
                 errsym,errblk,errnum: integer; { ERROR STUFF IN EDIT }
                 slowterm,stupid: boolean;      { STUDENT PROGRAMMER ID!! } 
                 altmode: char;                 		{ WASHOUT CHAR FOR COMPILER }
                 gotsym,gotcode: boolean;       { TITLES ARE MEANINGFUL }   
                 workvid,symvid,codevid: vid;   { PERM&CUR WORKFILE VOLUMES }
                 worktid,symtid,codetid: tid;   { PERM&CUR WORKFILES TITLE }
               end { INFOREC } ;

                                        { SYSTEM COMMUNICATION AREA }
                                        { SEE INTERPRETERS...NOTE   }
                                        { THAT WE ASSUME BACKWARD   }
                                        { FIELD ALLOCATION IS DONE  }
     syscomrec = record
                   iorslt: iorsltwd;   { RESULT OF LAST IO CALL }
                   xeqerr: integer;    { REASON FOR EXECERROR CALL } 
                   sysunit: unitnum;   { PHYSICAL UNIT OF BOOTLOAD }
                   rwtable: ^integer;  { PASCAL res words for idsearch } 
                   gdirp: dirp;        	{ GLOBAL DIR POINTER,SEE VOLSEARCH } 
                   diskinfo: packed record
                               dseekrate: integer; {STEP RATE FOR DISK DRIVE} 
                               dreadrate: integer; {DISK READ COMMAND}
                               dwriterate: integer;{DISK WRITE COMMAND}
                             end;
                   expansone:  array [0..17] of integer;  {spare} 
                   auxcrtinfo: packed record
                                 verdlaychar: char
                               end;        
                   hightime,lowtime: integer; 
                   miscinfo: packed record
                               nobreak,stupid,slowterm,
                               hasxycrt,haslccrt,has8510a,hasclock: boolean;
                               userkind:(normal, aquiz, booker, pquiz) 
                             end; 
                   crttype: integer;
                   crtctrl: packed record
                              rlf,ndfs,eraseeol,eraseeos,home,escape: char; 
                              backspace: char;
                              fillcount: 0..255;
                              clearscreen, clearline: char;
                              prefixed: packed array [0..8] of boolean
                            end;
                   crtinfo: packed record
                              width,height: integer;
                              right,left,down,up: char;
                              badch,chardel,stop,break,flush,eof: char; 
                              altmode,linedel: char;
                              backspace,etx,prefix: char;
                              prefixed: packed array [0..13] of boolean
                            end
                 end { SYSCOM };

     miscinforec = record
                     msyscom: syscomrec
                   end;

     memlinkp = ^memlink;
     memlink = record
                 nextavail: memlinkp;
                 nwords: integer
               end { memlink } ;

     markp = ^marknode;
     marknode = record
                  prevmark: markp;
                  availlist: memlinkp
                end { marknode } ;

     byte      = 0..255;
     integerp  = ^integer; 
     queue     = packed array [0..maxq] of byte;
     bytearray = packed array [0..0] of byte; 
     codeseg   = record case boolean of
                   true:  (int: packed array [0..0] of integer);
                   false: (byt: bytearray);
                 end;
     
     sibp = ^sib;
     sibvec = array [0..0] of sibp;
     sib = record { segment info block }
             segbase: ^codeseg;{ memory address of seg }
             segleng: integer; { # words in segment }
             segrefs: integer; { active calls - microcode maintained }
             segaddr: integer; { absolute disk address }
             segunit: unitnum; { physical disk unit } 
             prevsp:  integerp;{ SP saved by getseg for relseg cut back }
           end { sib } ;

     mscwp = ^mscw; 
     mscw = packed record  { mark stack control word }
              msstat: mscwp;   { lexical parent pointer }
              msdynl: mscwp;   { ptr to caller's mscw }
              msipc:  integer; { byte index in return code seg }
              msseg:  byte;    { seg # of caller code }
              msflag: byte
            end { mscw } ;

     semp = ^semtrix;
     tibp = ^tib;
     tib = record { Task Information Block }
             regs: packed record
                     waitq: tibp;     { QUEUE LINK FOR SEMAPHORES }
                     prior: byte;     { TASK'S CPU PRIORITY }
                     flags: byte;     { STATE FLAGS...NOT DEFINED YET }
                     splow: integerp; { LOWER STACK POINTER LIMIT }
                     spupr: integerp; { UPPER LIMIT ON STACK }
                     sp: integerp;    { ACTUAL TOP-OF-STACK POINTER }
                     mp: mscwp;       { ACTIVE PROCEDURE MSCW PTR }
                     bp: mscwp;       { BASE ADDRESSING ENVIRONMENT PTR }
                     ipc: integer;    { BYTE PTR IN CURRENT CODE SEG } 
                     segb: ^codeseg;  { PTR TO SEG CURRENTLY RUNNING } 
                     hangp: semp;     { WHICH TASK IS WAITING ON }
                     xxx: integer;    { NOT USED } 
                     sibs: ^sibvec    { ARRAY OF SIBS FOR 128..255 } 
                   end { REGS } ;
             maintask: boolean;
             startmscw: mscwp
           end { TIB } ;
     
     semtrix = record case integer of
                 0: (sem: semaphore);
                 1: (fakesem: record
                                count: integer; { outstanding signals }
                                waitq: tibp     { task queue }
                              end); 
               end { sem } ;
 
     ports = (a,b);
 
     statcmdrec = record case boolean of
                    true : (command : integer); 
                    false : (status : packed array[0..7] of boolean);
                  end;  { for devices that use same reg for stat and cmd }
     whole = 0..maxint; 
     paralrec = record 
                  porta : statcmdrec;
                  portb : integer;
                  portc : statcmdrec;
                  pcontrol : integer;
                end;
     
     floppyrec = record
                   fstatcom : statcmdrec; 
                   track : integer; 
                   sector : integer;
                   data : integer;
                   filler : array[0..3] of whole;
                   {  dma fields   }
                   dcontrol : integer;
                   dstatus : statcmdrec;
                   trcountl : integer;
                   trcounth : integer;
                   bufaddl : integer;
                   bufaddh : integer;
                   memex : integer;
                   intid : integer
                 end;

     serialrec = record
                   data : integer;
                   statsyndle : statcmdrec;
                   control2 : integer;
                   control1 : integer;
                   filler : array[0..3] of integer;
                   switch : statcmdrec;
                 end;

     sercontrol = record
                    readsem, writebell,
                    writesem, havch, qlock : semaphore; 
                    (* wrlock : semtrix; *)
                    front, rear : integer;
                    chq : queue;
                    serialtrix: record case integer of 
                                  0: (sdevadd: integer);
                                  1: (serial: ^serialrec);
                                end; 
                 end;
                
     decmax = integer[36]; 
     longtrix = record case integer of 
                  0: (intar: array [0..0] of integer);
                  1: (BCDar: packed array [0..0] of 0..15); 
                end {longtrix};
     
     memtrix = record case boolean of
                 true:  (addr: integer);
                 false: (loc:  integerp);
               end;
      
VAR 
    syscom: ^syscomrec;           		{ MAGIC PARAM...SET UP IN BOOT } 
    gfiles: array [0..5] of fibp; { GLOBAL FILES, 0=INPUT, 1=OUTPUT }
    userinfo: inforec;            		{ WORK STUFF FOR COMPILER ETC } 
    ostibp: tibp;                 			{ taskinfo block of op sys prog }
    emptyheap: ^integer;          	{ HEAP MARK FOR MEM MANAGING } 
    inputfib,outputfib,           		{ CONSOLE FILES...GFILES ARE COPIES }
    systerm,swapfib: fibp;        	{ CONTROL AND SWAPSPACE FILES } 
    syvid,dkvid: vid;             		{ SYSUNIT VOLID & DEFAULT VOLID }
    thedate: daterec;             		{ TODAY...SET IN FILER OR SIGN ON }
    state: cmdstate;              { FOR GETCOMMAND }
    heapinfo: record    { heap management } 
                lock: semaphore;
                topmark,
                heaptop: markp
              end { heapinfo } ;
    taskinfo: record    { stuff for task management } 
                lock: semaphore;
                taskdone: semaphore;
                ntasks: integer
              end { taskinfo } ;
    ipot: array [0..4] of integer; { INTEGER POWERS OF TEN }
    filler: string[41];            		{ NULLS FOR CARRIAGE DELAY } 
    digits: set of '0'..'9';
    pl: string;
    unitable: array [unitnum] of { 0 NOT USED }
                record
                  uvid: vid;       { VOLUME ID FOR UNIT }
                  case uisblkd: boolean of
                    true: (ueovblk: integer)
                end { unitable } ;
    filename: array [sysfile] of string[23];
    topofsibs: ^integer;
    
    safediskmode : boolean; 
    { if true, volsearch will not fetch new dir if gdirp matches unit table } 

{..........Variable access by system U- programs ends here..........}

    port : array [ports] of sercontrol; 
    
    paraltrix : record case boolean of
                  true : (pdevadd : integer); 
                  false : (parallel : ^paralrec);
                end;
    floppytrix : record case boolean of
                   true : (fdevadd : integer); 
                   false : (floppy : ^floppyrec);
                 end;
    
    dmasem, parsem, stst : semaphore; 
    (* pariolock, diskiolock : semtrix; *)
    iolock, enableint : semaphore; 
    sflag,fflag,wflag : boolean; { start/stop, flush, and waiting }
    enabletrix : memtrix;        { for enabling interrupts }

{***NOTE:  The next section had been called FORWARDS.TEXT}

{ ------------------------------------------------------------------------- }
{  SYSTEM PROCEDURE FORWARD DECLARATIONS  }
{  THESE ARE ADDRESSED BY OBJECT CODE...  }
{   DO NOT MOVE WITHOUT CAREFUL THOUGHT   }

segment procedure userprog;
  forward;

segment procedure syscode;
  forward;

segment procedure cspcode;
  forward;

segment procedure syscode;

  segment procedure printerror (var xeqerr: integer; iorslt: integer);
    forward;

  segment procedure initialize;
    forward;

  segment procedure getcmd(lastst: cmdstate; var nextst: cmdstate);
    forward;

  segment procedure debugger(var xeqerr: integer;
                             theseg,theproc, theipc, theptr: integer); 
    forward;
  
  procedure execerror(err: integer); 
    forward;
  procedure finit(var f: fib; window: windowp; recwords: integer);
    forward;
  procedure freset(var f: fib);
    forward;
  procedure fopen(var f: fib; var ftitle: string;
                  fopenold: boolean; junk: fibp);
    forward;
  procedure fclose(var f: fib; ftype: closetype);
    forward; 
  procedure fget(var f: fib);
    forward;
  procedure fput(var f: fib);
    forward;
  procedure fseek(var f: fib; recnum: integer);
    forward;
  function feof(var f: fib): boolean;
    forward;
  function feoln(var f: fib): boolean;
    forward;
  procedure freadint(var f: fib; var i: integer);
    forward;
  procedure fwriteint(var f: fib; i,rleng: integer);
    forward;
  procedure freadreal(var f: fib; var x: real);
    forward;
  procedure fwritereal(var f: fib; x: real; w, d: integer);
    forward;
  procedure freadchar(var f: fib; var ch: char);
    forward;
  procedure fwritechar(var f: fib; ch: char; rleng: integer);
    forward;
  procedure freadstring(var f: fib; var s: string; sleng: integer);
    forward;
  procedure fwritestring(var f: fib; var s: string; rleng: integer);
    forward;
  procedure fwritebytes(var f: fib; var a: window; rleng,aleng: integer);
    forward;
  procedure freadln(var f: fib);
    forward;
  procedure fwriteln(var f: fib);
    forward;
  procedure sconcat(var dest,src: string; destleng: integer); 
    forward;
  procedure sinsert(var src,dest: string; destleng,insinx: integer);
    forward; 
  procedure scopy(var src,dest: string; srcinx,copyleng: integer);
    forward;
  procedure sdelete(var dest: string; delinx,delleng: integer);
    forward;
  function spos(var target,src: string): integer;
    forward;
  function fblockio(var f: fib; var a: window; inx: integer;
                    nblocks,rblock: integer; doread: boolean): integer;
    forward;
  procedure fgotoxy(x,y: integer);
    forward;
  
  {  NON FIXED FORWARD DECLARATIONS  }
  
  function volsearch(var fvid: vid; lookhard: boolean;
                     var fdir: dirp): unitnum;
    forward;
  procedure writedir(funit: unitnum; fdir: dirp);
    forward;
  function dirsearch(var ftid: tid; findperm: boolean; fdir: dirp): dirrange;
    forward;
  function scantitle(ftitle: string; var fvid: vid; var ftid: tid;
                     var fsegs: integer; var fkind: filekind): boolean;
    forward;
  procedure delentry(finx: dirrange; fdir: dirp);
    forward;
  procedure insentry(var fentry: direntry; finx: dirrange; fdir: dirp); 
    forward;
  procedure homecursor;
    forward;
  procedure clearscreen; 
    forward;
  procedure clearline;
    forward;
  procedure prompt;
    forward;
  function spacewait(flush: boolean): boolean;
    forward;
  function getchar(flush: boolean): char;
    forward;
  procedure command;
    forward;
  process enabler;
    forward;
  process bellprocess (lport: ports);
    forward;
  process kbddriver (lport: ports; funit: integer);
    forward;


========================================================================================
DOCUMENT :usus Folder:VOL08:linecount.text
========================================================================================

PROGRAM LINECOUNTER;

{by Sandy and George Schreyer}

{use this program to do a very fast line count of one or several files.
 you must make a text file of the filenames that you wish to count if you
 want to count more than one file at a time}
 
USES (*$U SCREENUNIT.CODE*)SCREENUNIT,
     (*$U FILEUNIT.CODE*) FILEUNIT,
     (*$U PRINTRUNIT.CODE*)PRINTERUNIT;

VAR DIRF:TEXT; {Directory file}
    DISK:FILE; {Text file to be line-counted}
    FILENAME:STRING; {Name of text file}
    LINES:INTEGER; {Number of lines in one text file}
    PRNT:TEXT; {Output to printer}
    TRANSACTION:CHAR; {What program is to do}
    
PROCEDURE DO_COUNT;
{ Count the lines of text file FILENAME.  The answer is LINES. }
VAR POSITION,INDEX,BLOCKS,DATA_LEFT : INTEGER;
    DATA : PACKED ARRAY[0..17407] OF CHAR;
{$R-}
BEGIN
   LINES:=0;
   INDEX:=0;
   WRITELN('counting ... ',FILENAME);
   BLOCKS:=BLOCKREAD(DISK,DATA,34,2);
   DATA_LEFT:=512*BLOCKS;
   REPEAT
      POSITION:=SCAN(DATA_LEFT,=CHR(13),DATA[INDEX]);
      LINES:=SUCC(LINES);
      INDEX:=INDEX+POSITION+1;
      DATA_LEFT:=DATA_LEFT-POSITION;
   UNTIL DATA_LEFT <= 0;
   LINES:=LINES-1;
END {DO_COUNT};
{$R+}

PROCEDURE COUNT_ONE;
{ Count the number of lines in one file. }
BEGIN
   OPNDSKREAD(DISK,'Count lines in which text file? ',FILENAME,0,5);
   IF FILENAME='' THEN EXIT(COUNT_ONE);
   GOTOXY(0,0);
   CRT(ERASEOS);
   WRITELN;
   DO_COUNT;
   WRITELN;
   WRITELN('Your file ',FILENAME,' has ',LINES,' lines.');
   CLOSE(DISK,LOCK);
END {COUNT_ONE};

PROCEDURE COUNT_MANY;
{ Count the number of lines in a group of files. }
VAR DATE:STRING;
    DIREOF:BOOLEAN;
    DIR_NAME:STRING;
    IORSLT:INTEGER;
    STAR:STRING;
    TOT_LINES:INTEGER;
BEGIN
   OPNDSKREAD(DIRF,'What is the name of your directory? ',DIR_NAME,0,5);
   IF DIR_NAME='' THEN EXIT(COUNT_MANY);
   TOT_LINES:=0;
   PAGE(PRNT);
   WRITELN(PRNT,'Line counts for directory ',DIR_NAME);
   STAR:='*';
   GET_FILE_DATE(STAR,DATE);
   WRITELN(PRNT,'     on ',DATE);
   WRITELN(PRNT);
   WRITELN(PRNT);
   GOTOXY(0,0);
   CRT(ERASEOS);
   REPEAT
      READLN(DIRF,FILENAME);
      DIREOF:=EOF(DIRF);
      IF (NOT DIREOF) AND (FILENAME<>'') THEN
         BEGIN
         {$I-}
         RESET(DISK,FILENAME);
         IORSLT:=IORESULT;
         {$I+}
         IF IORSLT<>0 THEN
            WRITELN(PRNT,FILENAME,' can not be opened.')
         ELSE
            BEGIN
            DO_COUNT;
            FILENAME:=CONCAT(FILENAME,'                                   ');
            WRITELN(PRNT,COPY(FILENAME,1,30),LINES:10);
            TOT_LINES:=TOT_LINES+LINES;
            WAIT_FOR_DC1;
            END;
         END;
      CLOSE(DISK,LOCK);
   UNTIL DIREOF;
   WRITELN(PRNT);
   WRITELN(PRNT,'TOTAL',' ':25,TOT_LINES:10);
   CLOSE(DIRF,LOCK);
END {COUNT_MANY};

BEGIN {LINECOUNTER}
   INITPT;
   GETCRTINFO;
   REWRITE(PRNT,'PRINTER:');
   GOTOXY(0,0);
   CRT(ERASEOS);
   WRITELN('LINE COUNTER   version 2      22-Jul-81');
   WRITELN;
   VER_SCREENUNIT;
   VER_FILEUNIT;
   VER_PRTUNIT;
   REPEAT
      GOTOXY(0,15);
      WRITELN('A)  Count lines in one file');
      WRITELN('B)  Count lines for all files in directory');
      WRITELN;
      WRITELN('Q)  Quit');
      REPEAT
         GOTOXY(0,12);
         WRITE('Enter letter of desired menu item: ');
         READ(TRANSACTION);
      UNTIL TRANSACTION IN ['A','B','Q','a','b','q'];
      GOTOXY(0,0);
      CRT(ERASEOS);
      CASE (TRANSACTION) OF
         'A','a': COUNT_ONE;
         'B','b': COUNT_MANY;
         'Q','q': ;
      END {case};
      GOTOXY(0,0);
      CRT(ERASEOS);
   UNTIL TRANSACTION IN ['Q','q'];
END. {LINECOUNTER}


========================================================================================
DOCUMENT :usus Folder:VOL08:lisp.text
========================================================================================

(* NTIS LISP interpreter by L. A. Cox, Jr. and W. P.
Taylor of the Lawrence Livermore Laboratory, modified for
UCSD Pascal by David Mundie.  NTIS #UCRL-52417. *)
                                 
{$G+}
program lisp;
label 1,2;
const maxnodes = 100;
type alfa = string[10];
     inputsymbol = (atom,period,lparen,rparen); 
     rsrvdwrds = (replhsym,repltsym,headsym,
      tailsym,eqsym,quotesym,atomsym,condsym,labelsym,
      lambdasym,copysym,appendsym,concsym,conssym);
     statustype = (unmarked,left,right,marked);
     symbexpptr = ^symbolicExpression;
     symbolicExpression = record 
      status: statustype; 
      next: symbexpptr;
      case anatom:boolean of 
       true: (name: alfa; case isareservedword: boolean of 
              true: (ressym: rsrvdwrds));
       false: (head,tail: symbexpptr)
     end;
 var lookaheadsym,sym: inputsymbol;
     errorflag: boolean;
     id: alfa; alreadypeeked: boolean; ch:char;  
     ptr: symbexpptr;
     freelist,nodelist,alist: symbexpptr; 
     nilnode,tnode: symbolicExpression;
     resword: rsrvdwrds;
     reserved: boolean;
     reswords: array [rsrvdwrds] of alfa;
     freenodes,numberofgcs: integer;
procedure error(number: integer); forward;
 procedure garbageman; 
  procedure mark(list:symbexpptr);
  var father,son,current: symbexpptr;      
  begin father := nil; current := list; son := current;                  
   while current <> nil do with current^ do 
   case status of 
    unmarked: if anatom then status := marked 
     else if (head^.status <> unmarked) or (head=current) then
      if (tail^.status <>unmarked) or (tail = current) then
       status := marked 
      else begin status := right; son := tail; 
       tail := father; father := current; current := son
      end else begin 
       status := left; son := head; head := father; 
       father := current; current := son 
      end;
    left: if tail^.status <> unmarked then 
     begin status := marked; father := head; head := son; 
      son := current 
     end else begin 
      status := right; current := tail; tail := head; 
      head := son; son := current 
     end;
    right: begin status := marked; father := tail; 
     tail := son; son := current end;
    marked: current := father
   end
  end; {mark}
  procedure collectfreenodes; 
  var temp: symbexpptr;
  begin writeln('number of free nodes before collection = ',             
   freenodes:1,'.');  
   freelist := nil; freenodes := 0; temp := nodelist;     
   while temp <> nil do 
    begin if temp^.status <> unmarked then 
     temp^.status := unmarked  
     else begin freenodes := freenodes + 1;
     temp^.head := freelist; freelist := temp end;
     temp := temp^.next
    end;
   writeln('Nodes free after collection = ',freenodes:1,'.')
  end;
 begin {garbageman}
  numberofgcs := numberofgcs + 1; writeln;
  writeln('Garbage collection.'); writeln; 
  mark(alist); if ptr <> nil then mark(ptr); 
  collectfreenodes
 end;
procedure pop(var sptr:symbexpptr);
begin if freelist = nil then 
 begin writeln('Not enough space to evaluate.');  
  exit(lisp)
 end; freenodes := freenodes - 1; 
 sptr := freelist; freelist := freelist^.head   
end;
procedure backupinput; 
 begin alreadypeeked := true; lookaheadsym := sym; 
  sym := lparen
 end;
procedure nextsym;   
var i: integer;
begin if alreadypeeked then     
 begin sym := lookaheadsym; alreadypeeked := false       
 end else 
 begin while ch = ' ' do begin 
  if eoln then writeln; read(ch); 
  end; if ch in ['(','.',')'] then  
   begin case ch of 
    '(': sym := lparen; 
    '.': sym := period;
    ')': sym := rparen
   end;
   if eoln then writeln; read(ch);
  end else 
  begin sym := atom; id := '         '; i := 0;
   repeat i := i + 1; 
    if i < 11 then id[i] := ch; 
    if eoln then writeln;
    read(ch); 
   until ch in [' ','(','.',')'];  
   resword := replhsym; 
   while (id<>reswords[resword]) and (resword<>conssym) do 
    resword := succ(resword); 
   reserved := id = reswords[resword]
  end
 end
end;
procedure readexpr( var sptr: symbexpptr);
var nxt: symbexpptr;
begin pop(sptr); nxt := sptr^.next;
 case sym of  
  rparen,period: error(1);
  atom: with sptr^ do begin 
        anatom := true; name := id; 
        isareservedword := reserved;       
        if reserved then ressym := resword  
        end;
  lparen: with sptr^ do begin nextsym;              
        if sym = period then error(2)
        else if sym = rparen then sptr^ := nilnode
        else begin 
         anatom := false; readexpr(head); nextsym; 
         if sym = period then begin 
          nextsym; readexpr(tail); nextsym; 
          if sym<>rparen then error(4)
         end else begin
          backupinput; readexpr(tail) end 
         end
        end {with}
       end; {case}
      sptr^.next := nxt
 end;
 procedure printname(name: alfa);
 begin write(name,' ') end;
 procedure printexpr(sptr: symbexpptr);
 label 1;
 begin if sptr^.anatom then printname(sptr^.name)
  else begin 
   write('(');
  1: with sptr^ do 
   begin printexpr(head); 
    if tail^.anatom and (tail^.name = 'nil       ') then
     write(') ')
    else if tail^.anatom then 
     begin write(' . '); printexpr( tail ); write(') ')
     end else 
     begin sptr := tail; goto 1
     end
    end
   end
  end; {printexpr}
  function eval(e,alist:symbexpptr):symbexpptr; 
 var temp,carofe,caarofe: symbexpptr;    
function replaceh(sptr1,sptr2:symbexpptr):symbexpptr;  
begin if sptr1^.anatom then error(5) 
 else sptr1^.head := sptr2; replaceh := sptr1 
end;
function replacet(sptr1,sptr2: symbexpptr):symbexpptr;
begin if sptr1^.anatom then error(6) 
 else sptr1^.tail := sptr2; replacet := sptr1
end;
function head(sptr: symbexpptr):symbexpptr;
begin if sptr^.anatom then error(7)
 else head := sptr^.head
end;
function tail(sptr:symbexpptr):symbexpptr;
begin if sptr^.anatom then error(8) 
 else tail := sptr^.tail
end;
function cons(sptr1,sptr2:symbexpptr):symbexpptr;
var temp:symbexpptr;
begin pop(temp); temp^.anatom := false;
 temp^.head := sptr1; temp^.tail := sptr2;
 cons := temp; writeln('cons')
end; 
function copy(sptr:symbexpptr):symbexpptr;
var temp,nxt: symbexpptr;
begin if sptr^.anatom then 
 begin pop(temp); nxt := temp^.next;
  temp^ := sptr^; temp^.next := nxt;
  copy := temp; writeln('copy')
 end else copy := cons(copy(sptr^.head),copy(sptr^.tail)) 
end;
function append(sptr1,sptr2: symbexpptr): symbexpptr;    
begin if sptr1^.anatom then     
 if sptr1^.name <> 'nil       ' then error(9)
 else append := sptr2 
else
 append := cons(copy(sptr1^.head),append(sptr1^.tail,sptr2))
end;
function conc(sptr1:symbexpptr):symbexpptr;
var sptr2,nilptr: symbexpptr;
begin 
if sym <> rparen then 
 begin nextsym; readexpr(sptr2); nextsym; 
  conc := cons(sptr1,conc(sptr2))
 end else if sym = rparen then 
 begin new(nilptr); with nilptr^ do 
  begin anatom := true; name := 'nil       '
  end; conc := cons(sptr1,nilptr)
 end else error(10)
end;
function eqq(sptr1,sptr2: symbexpptr):symbexpptr;
var temp,nxt: symbexpptr; 
begin pop(temp); nxt := temp^.next;
 if sptr1^.anatom and sptr2^.anatom then 
  if sptr1^.name = sptr2^.name then temp^ := tnode
  else temp^ := nilnode
 else if sptr1 = sptr2 then 
  temp^ := tnode
 else temp^ := nilnode; 
 eqq := temp
end;
function atom(sptr: symbexpptr):symbexpptr;    
var temp,nxt: symbexpptr;
begin pop(temp); writeln('atom');      
 nxt := temp^.next;
 if sptr^.anatom then temp^:=tnode
 else temp^ := nilnode;
 temp^.next := nxt; atom := temp        
end;
function lookup(key,alist: symbexpptr):symbexpptr;
var temp: symbexpptr;
begin temp := eqq(head(head(alist)),key); 
 if temp^.name = 't         ' then 
  lookup := tail(head(alist))
 else lookup := lookup(key,tail(alist))
end;
function bindargs(names,values:symbexpptr):symbexpptr;
var temp,temp2: symbexpptr;
begin if names^.anatom and (names^.name = 'nil       ') then 
 bindargs := alist
 else begin 
  temp := cons(head(names),eval(head(values),alist));
  temp2 := bindargs(tail(names),tail(values));
  bindargs := cons(temp,temp2)
 end
end;
function evcon(condpairs: symbexpptr):symbexpptr;
var temp: symbexpptr;
begin temp := eval(head(head(condpairs)),alist);
 if temp^.anatom and (temp^.name = 'nil       ') then 
  evcon := evcon(tail(condpairs))
 else evcon := eval(head(tail(head(condpairs))),alist)
end;
begin {eval} writeln('EVAL');  
if e^.anatom then eval := lookup(e,alist)            
else 
 begin carofe := head(e);
  if carofe^.anatom then 
   if not carofe^.isareservedword then         
    eval := eval(cons(lookup(carofe,alist),tail(e)),alist)
   else case carofe^.ressym of 
    labelsym,lambdasym: error(3);
    quotesym: eval := head(tail(e));
    atomsym: eval := atom(eval(head(tail(e)),alist));
    eqsym: eval := eqq(eval(head(tail(e)),alist),
                       eval(head(tail(tail(e))),alist));
    headsym: eval := head(eval(head(tail(e)),alist));
    tailsym: eval := tail(eval(head(tail(e)),alist));
    conssym: eval := cons(eval(head(tail(e)),alist),
                          eval(head(tail(tail(e))),alist));
    condsym: eval := evcon(tail(e));
    concsym:;
    appendsym: eval := append(eval(head(tail(e)),alist),
                              eval(head(tail(tail(e))),alist));
    replhsym: eval := replaceh(eval(head(tail(e)),alist),
                            eval(head(tail(tail(e))),alist));
    repltsym: eval := replacet(eval(head(tail(e)),alist),
                           eval(head(tail(tail(e))),alist));
     end {case}
  else begin 
   caarofe := head(carofe);   
    if caarofe^.anatom and caarofe^.isareservedword then   
     if not(caarofe^.ressym in [labelsym,lambdasym]) then 
      error(12) 
     else case caarofe^.ressym of 
      labelsym: begin temp := cons(cons(head(tail(carofe)),
                  head(tail(tail(carofe)))),alist);
                  eval := eval(cons(head(tail(tail(carofe))),
                      tail(e)),temp)
                end;
      lambdasym: begin 
                  temp := bindargs(head(tail(carofe)),tail(e));
                  eval := eval(head(tail(tail(carofe))),temp)
                 end
      end {case}
    else eval := eval(cons(eval(carofe,alist),tail(e)),alist)
   end
  end
 end; {eval}
 procedure initialize;
 var i: integer; temp,nxt: symbexpptr;
 begin alreadypeeked := false; read(ch);
 numberofgcs := 0; freenodes := maxnodes; 
  with nilnode do begin 
   anatom := true; next := nil; name := 'nil       ';
   status := unmarked; isareservedword := false
  end;
  with tnode do begin 
   anatom := true; next := nil; name := 't         ';    
   status := unmarked; isareservedword := false
  end;
  freelist := nil; for i := 1 to maxnodes do 
   begin new(nodelist); 
    nodelist^.next := freelist;
    nodelist^.head := freelist;
    nodelist^.status := unmarked; freelist := nodelist
   end;
  reswords[replhsym] := 'replaceh  ';
  reswords[repltsym] := 'replacet  ';
  reswords[headsym ] := 'car       ';
  reswords[tailsym ] := 'cdr       ';
  reswords[copysym ] := 'copy      ';
  reswords[appendsym]:= 'append    ';
  reswords[concsym ] := 'conc      ';
  reswords[conssym ] := 'cons      ';
  reswords[eqsym]    := 'eq        ';
  reswords[quotesym] := 'quote     ';
  reswords[atomsym]  := 'atom      ';
  reswords[condsym]  := 'cond      ';
  reswords[labelsym] := 'label     ';
  reswords[lambdasym]:= 'lambda    ';
  pop(alist);
  alist^.anatom := false;
  alist^.status := unmarked;
  pop(alist^.tail); 
  nxt := alist^.tail^.next;
  alist^.tail^ := nilnode;
  alist^.tail^.next := nxt;
  pop(alist^.head);  
  with alist^.head^ do    
   begin anatom := false; status := unmarked;
   pop(head); nxt := head^.next;
   head^ := nilnode;   
   head^.next := nxt;            
   pop(tail); nxt := tail^.next;
   tail^ := nilnode; 
   tail^.next := nxt
  end; 
  pop(temp); 
  temp^.anatom := false;  
  temp^.status := unmarked;
  temp^.tail := alist;
  alist := temp;
  pop(alist^.head); 
  with alist^.head^ do 
   begin anatom := false; status := unmarked;
   pop(head); nxt := head^.next;
   head^ := tnode;
   head^.next := nxt;
   pop(tail);
   nxt := tail^.next;
   tail^ := tnode; tail^.next := nxt
  end
 end;
procedure showexpr;
begin printexpr(eval(ptr,alist)) 
end;  
procedure error;  
begin writeln; writeln('Error number ',number);
 errorflag := true; if number = 11 then exit(lisp)
 else if number in [1,2,4] then exit(readexpr)
 else if number in [3,12,5,6,7,8,9,10] then exit(showexpr) 
end;
 begin {lisp}  
  writeln('***eval '); initialize;
  nextsym; readexpr(ptr); readln; writeln;
  while not ptr^.anatom or (ptr^.name <>'fin         ') do 
   begin writeln; writeln(' *value* ');
   showexpr;                  
   1: errorflag := false; writeln; writeln;
   if eof(input) then error(11);
   ptr := nil;
   garbageman; 
   writeln; writeln; writeln('  *eval*  '); 
   nextsym; readexpr(ptr); if errorflag then goto 1;
   readln; writeln
  end;
  writeln('Total number of garbage collections',numberofgcs);
  writeln('Free nodes left on exit ',freenodes)
 end.

========================================================================================
DOCUMENT :usus Folder:VOL08:lister.text
========================================================================================

  {Copyright 1980 by
  Stuart Lynne
  1350 Clifton Ave.
  Coquitlam, British Columbia,
  Canada
  V3J 5K6
  
  Permission granted to use for noncommercial purposes.  All
  other rights reserved}
  
  

{$I globals}


segment procedure userprogram;
  var
    lineno, pageno: integer;
    dy, yr: integer;
    mth: string[10];
    line: string[255];
    comment: string[40];
    finame, foname: string[20];
    Fi, Fo: text;
  
  procedure set_month;
    begin
      with thedate do
        begin
          dy := day;
          yr := year;
          case month of
             1: mth := 'January';
             2: mth := 'Febuary';
             3: mth := 'March';
             4: mth := 'April';
             5: mth := 'May';
             6: mth := 'June';
             7: mth := 'July';
             8: mth := 'August';
             9: mth := 'September';
            10: mth := 'October';
            11: mth := 'November';
            12: mth := 'December'
          end
        end
    end;
  
  procedure pageject;
    begin
      pageno := pageno + 1;
      lineno := 0;
      page (Fo);
      writeln (Fo,
               'File: ''',
               finame,
               '''',
               '':17-length(finame),
               comment,
               '':46-length(comment),
               mth,
               ' ',
               dy:2,
               ', 19',
               yr:2,
               '':11-length(mth),
               'pg.',
               pageno:3);
      writeln (Fo)
    end;
  
  function check: boolean;
    const
      FF = 12;
    var
      S: string[1];
    begin
      S := ' ';
      S[1] := chr (FF);
      check := (pos ('$P', line) <> 0) or 
               (pos ('.pag', line) = 1) or
               (pos (S, line) <> 0)
    end;
    
  begin
    setmonth;
    writeln;
    writeln ('File Lister');
    write ('What file? ');
    readln (finame);
    finame := concat (finame, '.text');
    write ('To where? ');
    readln (foname);
    write ('Comment? ');
    readln (comment);
    reset (Fi, finame);
    rewrite (Fo, foname);
    pageno := 0;
    lineno := 0;
    while not eof (Fi) do
      begin
        
        readln (Fi, line);
        if ((lineno mod 60) = 0) or check  then
          pageject;
        writeln (Fo, line);
        lineno := lineno + 1
        
      end;
    page (Fo)
  end;
  
begin
end.

========================================================================================
DOCUMENT :usus Folder:VOL08:mailer.doc.text
========================================================================================

     MAILER DOCUMENTATION

     MAILER is a simple mailing-list maintenance program.
It creates and updates two fundamental data structures:
(1) a file of mailing records with fields for name, street,
city, state, zipcode, and phone number; and (2) an unbalanced
binary tree of keys, used to sort the records and to locate
a given record in the file.  The keys may be any of the
fields in the mailing records, at the user's discretion.

     When entered, the program prompts for the name of the
file to be handled.  If the file doesn't exist, the program
creates one, and initializes all its records to empty.  It
then prompts for the field which is to be used to sort and
search the file.

     Once this initialization is done, the user is given
a prompt line with seven options:

 A(dd M(odify P(rint F(ile N(ewsort S(et Q(uit

The use of these seven options is as follows.

     ADD:  Permits the user to add a new record to the file.

     MODIFY:  Allows modification of an existing record.
The user is asked for a target string, and the tree of
keys is searched for a match.  Matching is done by substrings,
so the string need not be complete; "Kirk", for example, will
match "Kirkwood" and "Kirkstein".  The record numbers and
keys of all matches are displayed; if more than one record is
found, the user is prompted for a particular record number.
Then the record may be modified on a field-by-field basis.
Two special inputs are recognized: <cr> leaves the given
field unchanged, while <cntrl-x> skips the rest of the
record.  Note: MODIFY can be used simply to examine a given
record by entering <cntrl-x> as the first response.

     PRINT produces a printout of the mailing list to an
arbitrary textfile, sorted according to the key field in
effect at the time.  The user may choose to print only
a subset of the file, by entering one of three options:
ALL prints everything in the file; ONLY prints only those
records whose keyfields contain the user-specified target
string; EXCEPT prints everything except those records whose
keyfields contain the user-specified target strings.  For
example, specifying "ONLY" and the target string "CA", if
the state keyfield is in effect, will list only those records
whose state is California.  Not all fields of the record need
be printed; see the SET option.  NOTE: Names may be entered 
last-name-first, to aid alphabetization, but they will be 
printed out first-name-first.  Thus "Mundie, David" is printed 
out as "David Mundie".


     FILE closes the current address file, and opens a new one.

     NEWSORT is used to change the field used for sorting and
accessing records.  For example, if the fields are currently
being sorted by name, the user may type N(ewsort, then
Z(ip to sort them by zipcode.

     SET is used to set the print fields used by PRINT.  The
default is to print everything except the phone number. The
new set of fields to be printed is specified by entering a
string containing the appropriate letters; for example, entering
'np' will cause PRINT only to print out the name and the
phone number.

     QUIT, obviously, is used to exit the program.


     -NOTE-

     No explicit provision is made for deleting records.  The
same effect, however, can be had by MODIFYing the records to
contain a special field, such as @.  PRINTing with an 
except '@' option will ignore deleted records; they may be
reused by a MODIFY using '@' as the target. 

========================================================================================
DOCUMENT :usus Folder:VOL08:mailer.text
========================================================================================

(*[B+, E=3, G=1, I=1, L=1, P=1, W=1-75] FORMATTER DIRECTIVES*)
program mailer;

const
 stringlength = 25;
 maxentries = 100;
 
type
 shortstring = string[stringlength];
 index = 0.. maxentries;
 entry = record
          name, street, city, phone: shortstring;
          state: string[2];
          zipcode: string[8]
         end;
 field =
  (nam, str, cit, pho, sta, zip);
 fieldset = set of field;
 pointer = ^ node;
 node = record
         key: shortstring;
         number: index;
         left, right: pointer
        end;
 
var
 topentry: index;
 keyfield: field;
 adds: file of entry;
 printfields: fieldset;
 heap: ^ integer;
 root: pointer;
 empty: string;
 modified: boolean;
 
function upper(ch: char): char;
 
 begin
  if ch in ['a' .. 'z']   then upper := chr(ord(ch) - 32)
  else upper := ch
 end (*upper*);

function f(ch: char): field;
 
 begin
  case ch of
   'N': f := nam;
   'S': f := str;
   'C': f := cit;
   'P': f := pho;
   'T': f := sta;
   'Z': f := zip
  end (*CASE*);
 end (*f*);

procedure saferead(var thestring: string; len: integer);
 
 var
  s: string;
  
 begin
  readln(s);
  while length(s) > len do
   begin
    writeln('Max of ', len, ' characters; re-enter: ');
    write('|': len + 1, chr(141));   readln(s)
   end;
  thestring := s
 end (*saferead*);

procedure initfield(var fld: field);
 
 var
  ch: char;
  
 begin
  repeat
   write('Sort by N(ame S(treet C(ity P(hone sT(ate Z(ip: ');   read(ch);
   writeln;   ch := upper(ch);
  until ch in ['N', 'S', 'C', 'P', 'T', 'Z'];
  fld := f(ch)
 end (*initfield*);

procedure initset(var fs: fieldset);
 
 var
  s: string;
  i: integer;
  
 begin
  fs := [];
  repeat
   writeln('Enter a string with desired field codes;');
   write('N(ame S(treet C(ity P(hone sT(ate Z(ip: ');   readln(s);
   for i := 1 to length(s) do
    if upper(s[i]) in ['N', 'S', 'C', 'P', 'T', 'Z']
    then fs := fs + [f(upper(s[i]))]
  until fs <> []
 end (*initset*);

procedure initfile;
 
 var
  i: index;
  addsname: string;
  
 begin
  close(adds, lock);   write('Name of address file: ');   readln(addsname);
(*$I-*)
  reset(adds, addsname);
(*$I+*)
  if ioresult > 0
  then
   begin
    rewrite(adds, addsname);
    writeln('Creating new file ', addsname, '.');
    for i := 0 to maxentries do
     begin seek(adds, i);   adds ^.name := empty;   put(adds) end
   end (*if*)
 end (*initfile*);

procedure key(keyfield: field; ent: entry; n: index);
 
 var
  s: shortstring;
  
 procedure enter(var p: pointer);
  
  begin
   if p = nil
   then
    begin
     new(p);   p ^.key := s;   p ^.number := n;
     writeln(p ^.number, ' ', p ^.key);   p ^.left := nil;
     p ^.right := nil
    end
   else if s < p ^.key   then enter(p ^.left)   else enter(p ^.right)
  end (*enter*);
 
 begin (*key*)
  case keyfield of
   nam: s := ent.name;
   str: s := ent.street;
   cit: s := ent.city;
   sta: s := ent.state;
   zip: s := ent.zipcode;
   pho: s := ent.phone
  end (*case*);
  enter(root)
 end (*key*);

procedure initkeys;
 
 begin (*initkeys*)
  release(heap);   writeln;   writeln('Sorting...');   writeln;
  root := nil;   topentry := 0;   reset(adds);   seek(adds, 0);
  get(adds);
  while adds ^.name <> empty do
   begin
    key(keyfield, adds ^, topentry);   topentry := topentry + 1;
    seek(adds, topentry);   get(adds);
   end (*while*);
  writeln;   modified := false
 end (*initkeys*);

procedure addarecord;
 
 begin
  if topentry >= maxentries
  then begin writeln('File full.');   exit(addarecord) end;
  seek(adds, topentry);
  with adds ^ do
   begin
    write('Name: ');   saferead(name, stringlength);   write('Street: ');
    saferead(street, stringlength);   write('City: ');
    saferead(city, stringlength);   write('State: ');   saferead(state, 2);
    write('Zipcode: ');   saferead(zipcode, 8);   write('Phone: ');
    saferead(phone, stringlength);
   end;
  key(keyfield, adds ^, topentry);   put(adds);   topentry := topentry + 1
 end (*addarecord*);

procedure printrecords;
 
 var
  searchmode:
   (all, only, except);
  ch: char;
  target, foutname: string;
  fout: text;
  
 function wanted(s: string): boolean;
  
  begin
   case searchmode of
    all: wanted := true;
    only: wanted := pos(target, s) <> 0;
    except: wanted := pos(target, s) = 0
   end (*CASE*)
  end (*wanted*);
 
 procedure printone(number: index);
  
  procedure print(s: string);
   
   var
    i: integer;
    lastname: string;
    
   begin
    i := pos(',', s);
    if i in [0, length(s)]   then writeln(fout, s)
    else
     begin
      lastname := copy(s, 1, i - 1);   delete(s, 1, i);
      while (s[1] = ' ') and (length(s) > 1) do delete(s, 1, 1);
      writeln(fout, s, ' ', lastname)
     end
   end (*print*);
  
  begin (*printone*)
   seek(adds, number);   get(adds);
   with adds ^ do
    begin
     if nam in printfields   then print(name);
     if str in printfields   then writeln(fout, street, ' ');
     if cit in printfields   then write(fout, city, ' ');
     if sta in printfields   then write(fout, state, ' ');
     if zip in printfields   then write(fout, zipcode);
     if printfields * [cit, sta, zip] <> []   then writeln;
     if pho in printfields   then writeln(phone);   writeln
    end
  end (*printone*);
 
 procedure postorder(p: pointer);
  
  begin
   if p <> nil then
    begin
     postorder(p ^.left);   if wanted(p ^.key)   then printone(p ^.number);
     postorder(p ^.right)
    end;
  end (*postorder*);
 
 begin (*printrecords*)
  write('Output file: ');   readln(foutname);   rewrite(fout, foutname);
  repeat
   write('A(ll O(nly E(xcept: ');   read(ch);   writeln;   ch := upper(ch);
  until ch in ['A', 'O', 'E'];
  case ch of
   'A': searchmode := all;
   'O': searchmode := only;
   'E': searchmode := except
  end (*CASE*);
  if ch in ['O', 'E']   then begin write('Target: ');   readln(target) end;
  writeln;   if modified   then initkeys;   postorder(root);
  close(fout, lock)
 end (*printrecords*);

procedure modifyarecord;
 
 var
  entrynum, count: index;
  target: string;
  
 procedure preorder(p: pointer);
  
  begin
   if p <> nil
   then
    begin
     if pos(target, p ^.key) <> 0 then
      begin
       count := count + 1;   writeln(p ^.number, ' ', p ^.key);
       entrynum := p ^.number
      end;
     preorder(p ^.left);   preorder(p ^.right)
    end
  end (*preorder*);
 
 procedure change(entrynum: index);
  
  const
   esc = 24;
   
  var
   s: shortstring;
   buf: entry;
   
  procedure exitmod;
   
   begin
    adds ^ := buf;   seek(adds, entrynum);   put(adds);
    exit(modifyarecord)
   end (*exitmod*);
  
  procedure modone(prompt: string; f: field; var old: string; len: integer)
   ;
   
   var
    s: string;
    ch: char;
    
   begin
    write('New ', prompt, ': ');   get(input);
    if input ^ = chr(esc)   then begin read(ch);   writeln;   exitmod end;
    saferead(s, len);
    if s = ''   then exit(modone)
    else
     if s[1] = chr(esc)   then exitmod
     else begin old := s;   if f = keyfield   then modified := true end
   end (*modone*);
  
  begin (*change*)
   seek(adds, entrynum);   get(adds);   buf := adds ^;
   with buf do
    begin
     writeln('Name: ', name);   writeln('Street: ', street);
     writeln('City state zip: ', city, ' ', state, ' ', zipcode);
     writeln('Phone: ', phone);   writeln;
     modone('name', nam, name, stringlength);
     modone('street', str, street, stringlength);
     modone('city', cit, city, stringlength);
     modone('state', sta, state, 2);   modone('zip', zip, zipcode, 8);
     modone('phone', pho, phone, stringlength);   exitmod
    end
  end (*change*);
 
 begin (*modifyarecord*)
  count := 0;   write('Target: ');   readln(target);   preorder(root);
  if count = 0   then writeln('Not in file.')
  else
   begin
    if count > 1
    then begin write('Specify record number: ');   readln(entrynum) end;
    change(entrynum)
   end
 end (*modifyarecord*);

procedure doacommand;
 
 var
  com: char;
  
 begin
  repeat
   write('A(dd M(odify F(ilechange P(rint N(ewsort S(et Q(uit: ');
   read(com);   writeln;   com := upper(com);
   case com of
    'A': addarecord;
    'M': modifyarecord;
    'N': begin initfield(keyfield);   initkeys end;
    'P': printrecords;
    'F': begin initfiles;   initkeys end;
    'Q': begin close(adds, lock);   exit(mailer) end;
    'S': initset(printfields);
   end (*CASE*)
  until false
 end (*doacommand*);

begin (*mailer*)
 mark(heap);   empty := ' ';   empty[1] := chr(0);   initfile;
 initfield(keyfield);   initkeys;   printfields := [nam .. cit, sta, zip];
 repeat doacommand   until false
end (*mailer*).

========================================================================================
DOCUMENT :usus Folder:VOL08:modemv2.2.text
========================================================================================

PROGRAM MODEM;

     {Program Modem magically turns your expensive computer into a lowly dumb
terminal.  I believe that this program may be processor dependant on a PDP-11
as it uses the UNITBUSY function.  The users manual for the version II.0
system says that UNITBUSY is only implemented on DEC computers.  Since
UNITBUSY is the heart of this nearly trivial program, if you havn't got it
then you're simply out of luck (SOL).  Modem has been tested up to 300 baud
with an LSI-11 and it works fine.  Timing tests indicate that it might work at
over 1200 baud but it has not been tested there.  When running with no work to
do it loops at over 1300 loops/second.  It loops at 770 loops/second when the
modem port is receiving data at 30 cps.  Since the user cannot type at more
than 10 cps, the program would probably loop fast enough to handle 1200 baud
(120 cps).

     To use it you need a modem connected to the REMIN: and REMOUT: ports.
These are addresses of 177520 thru 177526 and a vector of 120 for typical PDP-
11.  The program enters a loop and trys to read a character from either the
the KEYBOARD: or REMIN:. If one is not found it checks the other port.  When
one is found it checks for special characters and usually sends it to REMOUT:
or CONSOLE: respectivly.  Control-C from the console halts the program. Line
feeds from the modem are ignored as the system inserts one. Nulls cannot be
sent out and are ignored if recieved. Modem will not generate any spurious
characters when started or stopped.  Breaks cannot be generated as they cannot 
be represented as a character.  Half duplex could be handled by doing the
UNITREAD and UNITBUSY from port 1 instead of port 2.

Written 14-Nov-80 by George Schreyer}
 
VAR
  DATA_IN,DATA_OUT :PACKED ARRAY[0..1] OF CHAR;
  CONTINUE : BOOLEAN;
  
BEGIN
 CONTINUE:=TRUE;
 DATA_OUT[0]:=CHR(0);
 DATA_IN[0]:=CHR(0);
 WRITELN;
 WRITELN('modem version 2.2  30-Apr-81           Type CNTL-C when finished');
 UNITCLEAR(2);
 UNITCLEAR(7);
 WHILE CONTINUE DO
  BEGIN
  IF NOT UNITBUSY(2) THEN
   BEGIN
    UNITREAD(2,DATA_OUT[0],1,,1);
    IF DATA_OUT[0] = CHR(3) THEN
     BEGIN
      CONTINUE:=FALSE;
     END
    ELSE
     BEGIN
      IF DATA_OUT[0] <> CHR(0) THEN UNITWRITE(8,DATA_OUT[0],1,,1);
     END;
   END;
   IF NOT UNITBUSY(7) THEN
    BEGIN
     UNITREAD(7,DATA_IN[0],1,,1);
     IF (DATA_IN[0]<>CHR(10)) AND (DATA_IN[0]<>CHR(0)) 
        THEN UNITWRITE(1,DATA_IN[0],1,,1); 
    END;
  END;
END.



========================================================================================
DOCUMENT :usus Folder:VOL08:muldiv.z80.text
========================================================================================

; muldiv.text
;
; This procedure is specifically designed to meet the needs of the 
; UCSD Pascal Seek Algorithm by calculating the block and byte offset
; given the record number, and the record size.
;
; Copyright (c) 1980, by Stuart Lynne. All rights reserved.
;
;
;Procedure MULDIV - BLOCK:=(RECNUM*RECSIZ) DIV 512;
;                 - BYTE :=(RECNUM*RECSIZ) MOD 512;
                  

;PROCEDURE MULDIV(VAR BYTE:INTEGER;VAR BLOCK:INTEGER;REC,SIZ:INTEGER);

.PROC MULDIV,4
        POP     IX      ;Save return
        POP     HL
        POP     DE      ;Get Size and record #
        CALL    MUL    ;HLDE:= HL*DE
        LD      A,L     ;Assume 24 bit max result
        POP     HL      ;HL-> destination for block #
        PUSH    DE      ;Save remainder for byte
        SRL     A       ;
        RR      D       ;LD div 2 = Block #
        LD      (HL),D
        INC     HL
        LD      (HL),A
        POP     DE      ;Get remainder
        LD      A,1
        AND     D       ;Mask out lower 9 bits (512)
        POP     HL      ;HL=> destination of BYTE
        LD      (HL),E
        INC     HL
        LD      (HL),A
        JP      (IX)    ;Return
        
;Multiply routine
;unsigned HLDE = HL*DE
MUL:
        PUSH    AF
        PUSH    BC
        LD      A,17.
        LD      C,L
        LD      B,H
        LD      HL,0
MUL1    OR     A               ;Clear carry
        RR      H
        RR      L
        RR      D
        RR      E
        JP      NC,MUL2
        ADD     HL,BC
MUL2    DEC     A
        JP      NZ,MUL1
        POP     BC
        POP     AF
        RET
        
.END



========================================================================================
DOCUMENT :usus Folder:VOL08:perusev4.6.text
========================================================================================

(*$I-*)
(*$R-*)
program perusepage;

USES (*$U SCREENUNIT.CODE*)SCREENUNIT,
     (*$U FILEUNIT.CODE*)FILEUNIT;
{*****************}

CONST VERSION = 'peruse     version 4.6    13-Jul-81';
      MAXBYTES = 18431;

(*
                      G.W. Schreyer

     Peruse is an update of Monaco's original version in Volume 2A of the USUS
library, however it is so heavily modified that only the 'program perusepage',
'begin' and 'end.' of his original code remains.  This version incorporates
several units to handle the error free opening of the source file.  The units
may be over-kill for this little program, but they sure are easy to use.  See
FILEUNIT.DOC for a discription of the units.  

     The program runs about ten to fifteen times faster than the original.
It reads up the whole file in one chunk and uses SCAN to count out 22 lines.
It then dumps the whole 22 lines to the screen with one unitwrite.  I believe
this is the way the editor does its page function as peruse goes just as fast
as the editor. Also like the editor, there is a size limit to the file which
can be perused.  I set it at 36 blocks (with the header page) as this is the
largest file which the editor on my system can read.  If you can use more (and
have the memory avaiable!) then change the blockread statement and the
declaration for the packed array accordingly. 

     The read function uses an incredibly large amount of time to execute, so
invoking that function to read characters one at a time is very costly. Writes
go much quicker, but still they waste a fair amount of time so the unitwrite
significantly speeds things along.  Of course, these 'features' are non-
standard so that this program can only be used in the UCSD system. This
version will back up in the file by 44 lines then it will display 22 lines if
you should desire it.

     There is a perversity in the DLE expansion when using unitwrites in my
system. I don't know if this is a general problem, or just specific to my
particular computer (SCREENTEST says that there is a problem with the DLE
expansion). Lines which have leading blanks and are spaced with the DLE
expansion are spaced one too few spaces.  If some lines use the DLE expansion
and some lines are padded with leading blanks, the columns won't line up.  I
believe that this is problem with the operating system because the same thing 
happens when do a T)ransfer to the console with the F)iler.

     If you want to you may convert all of the lines padded with leading
blanks to the DLE expansion.  Go into the editor and enter A)djust mode. 
Then step thru the file with the down arrow (repeat factors work). This will
convert each line without moving it.  It may also make the file smaller, so
if you are running out if room, you can conserve a little space this way.

     Peruse will also open a device and read 36 blocks starting at any block
you choose.  This allows you to look through a disk for a lost text file and
see it in a readable format faster than PATCH can do it.  Use this feature in
conjunction with RECOVER and to see if a unused region on the disk is the file
that you want. But be carful, if you read in a code file, you will see
garbage. Some of that garbage may put your terminal into some weird mode and
anything may happen. It is best to reset your terminal after such an occurance
or the operating system may not work right.*)


VAR
 i,K,BLOCK      :INTEGER;
 SOURCE         :FILE;
 CHARARRAY      :PACKED ARRAY [0..MAXBYTES] OF CHAR;
 FILENAME       :STRING;
 MAXBLOCKS      :INTEGER;
 CH             :CHAR;
 ARRAYSIZE      :INTEGER;
 INDEX          :INTEGER;
 ANCHOR         :INTEGER;
 POSITION       : INTEGER;
 BLOCKS         : INTEGER;
 NEWFILE        :BOOLEAN;

PROCEDURE SKIP_HEADER;

BEGIN
   IF POS('.TEXT',FILENAME) <> 0 
      THEN 
         BEGIN
            BLOCKS:=34;
            BLOCK:=2 
         END
      ELSE 
         BEGIN
            BLOCKS:=36;
            BLOCK:=0;
         END;
END;

PROCEDURE BACKUP;
BEGIN
   IF INDEX > 1 THEN INDEX:=INDEX-2;
   FOR I:=1 TO 44 DO
      BEGIN
         POSITION:=SCAN(-1*INDEX,=CHR(13),CHARARRAY[INDEX]);
         INDEX:=INDEX + POSITION-1;
         IF INDEX < 0 THEN INDEX := 0;
      END;
   IF INDEX > 0 THEN INDEX:=INDEX+1;
END;


begin
GETCRTINFO;
FILENAME:='';
GOTOXY(0,0);
FILLCHAR(CHARARRAY,SIZEOF(CHARARRAY),CHR(0));
CRT(ERASEOS);
WRITELN('     ',VERSION);
VER_SCREENUNIT;
VER_FILEUNIT;
REPEAT
   I := 0;
   BLOCK:=0;
   OPNDSKREAD(SOURCE,'enter file or volume to be perused - -> ',FILENAME,0,10);
   GOTOXY(0,0);
   CRT(ERASEOS);
   IF FILENAME='' THEN EXIT(PROGRAM);
   NEWFILE:=FALSE;
   IF (POS(':',FILENAME) = LENGTH(FILENAME)) OR (FILENAME = '*') 
      THEN
         BEGIN
             MAXBLOCKS:=SIZEOF(CHARARRAY) DIV 512;
             GOTOXY(10,12);
             WRITE('read how many blocks (',MAXBLOCKS,' max) ? ');
             READLN(BLOCKS);
             GOTOXY(0,12);
             CRT(ERASEOL);
             IF BLOCKS <> 0 THEN
                BEGIN
                  IF (BLOCKS < 0 ) OR (BLOCKS > MAXBLOCKS) THEN
                     BLOCKS := MAXBLOCKS;
                  GOTOXY(10,12);
                  WRITE('read ',BLOCKS,' blocks starting at block ? ');
                  READLN(BLOCK);
                  IF BLOCK < 0 THEN 
                     BEGIN
                        BLOCKS:=0;
                        BLOCK:=0;
                     END;
                END
             ELSE BLOCKS :=0;
             GOTOXY(0,0);
             CRT(ERASEOS);
          END
       ELSE SKIP_HEADER;
   WRITELN;
   K:=BLOCKREAD(SOURCE,CHARARRAY,BLOCKS,BLOCK);
   CLOSE(SOURCE);
   ARRAYSIZE:=512*K;
   INDEX:=0;
   REPEAT
      ANCHOR:=INDEX;
      FOR I:=1 TO 22 DO
         BEGIN
            POSITION:=SCAN(ARRAYSIZE-INDEX,=CHR(13),CHARARRAY[INDEX]);
            INDEX:=POSITION+INDEX+1;
         END;
      UNITWRITE(1,CHARARRAY[ANCHOR],INDEX-ANCHOR,,1);
      GOTOXY(0,0);
      CRT(ERASEOL);
      WRITE('M)ore, B)ack-up, N)ew file or Q)uit ? ');
      READ(KEYBOARD,CH);
      GOTOXY(0,0);
      CRT(ERASEOS);
      WRITELN;
      CASE CH OF
        'Q','q' : EXIT(PROGRAM);
        'B','b' : BACKUP;
        'M','m' : ;
        'N','n' : NEWFILE:=TRUE;
      END; 
   UNTIL ((INDEX >= ARRAYSIZE)) OR NEWFILE; 
UNTIL NOT NEWFILE;
end.


========================================================================================
DOCUMENT :usus Folder:VOL08:recover.text
========================================================================================

PROGRAM RECOVER;

USES (*$U screenunit.code*)SCREENUNIT,
     (*$U fileunit.code*)FILEUNIT;

{by George Schreyer}

VAR NUM,I,P,J,K,X,Y : INTEGER;
    NUM_BLOCKS : INTEGER;
    DISK : FILE;
    VOLNAME  :STRING;
    DATA : PACKED ARRAY[0..511] OF CHAR;
    PR : TEXT;

procedure instructions;
   begin
     writeln;
     writeln('Recover scans all the blocks on the specified volume for');
     writeln('programs.  It looks for the reserved word ''PROGRAM'' in the');
     writeln('first 30 bytes of each block and prints the program name and');
     writeln('number of the start of where the header block should be if it');
     writeln('finds the reserved word.  As it is, it won''t find units but');
     writeln('that is easily changed if necessary.');
     writeln('Use PERUSE or PATCH to examine the data at each potential');
     writeln('location to find the most recent version');
   end;
   
BEGIN
   GETCRTINFO;
   GOTOXY(0,0);
   CRT(ERASEOS);
   WRITELN('     recover    version 1.0    13-Jun-81');
   ver_screenunit;
   ver_fileunit;
   instructions;
   REWRITE(PR,'PRINTER:');
   OPNDSKREAD(DISK,'Volume to scan for programs ? ',VOLNAME,0,16);
   IF VOLNAME='' THEN EXIT(PROGRAM);
   PAGE(PR);
   gotoxy(0,0);
   crt(eraseos);
   writeln('searching  ...  ');
   i:=0;
   while not eof(disk) do
      BEGIN
         K:=BLOCKREAD(DISK,DATA,1,I);
         P:=SCAN(30,='P',DATA[0]);
         IF P < 31 THEN
           IF (DATA[P+1] = 'R') AND
              (DATA[P+2] = 'O') AND
              (DATA[P+3] = 'G') AND
              (DATA[P+4] = 'R') AND
              (DATA[P+5] = 'A') AND
              (DATA[P+6] = 'M') THEN
                 BEGIN
                    X:=1;
                    WRITE('Program ');
                    WRITE(PR,'Program ');
                    REPEAT
                       IF DATA[P+6+X] <> ';' THEN 
                          begin
                            WRITE(PR,DATA[P+6+X]);
                            WRITE(DATA[P+6+X]);
                          end;
                       X:=X+1;
                    UNTIL (DATA[P+6+X] = ';') OR (X > 20);
                    WRITELN(PR,' exists at block ',I-2);
                    WRITELN(' exists at block ',I-2);
                 END;
          i:=i+1;
       END;
END.
         

========================================================================================
DOCUMENT :usus Folder:VOL08:rem.term.text
========================================================================================

PROGRAM TERMINAL ;  {$S+}   {xL PRINTER: }
(*
  COPYRIGHT 1980, 1981 BY ROBERT W. PETERSON.
                ALL RIGHTS RESERVED.
                
  THIS PROGRAM TALKS TO THE REMIN: AND REMOUT: AND HAS THE
  FOLLOWING CAPABILITIES:
    1. DUMB TERMINAL EMULATION.
    2. LOGGING TO A FILE THE TEXT RECEIVED.
    3. TRANSMITTING DOWN THE LINE A FILE.
    4. ECHOING OR NOT ECHOING THE CHARACTERS TYPED/TRANSMITTED.
    5. SELECTING THE NAME OF THE LOG FILE DYNAMICALLY.
    6. TRANSMITTING A PREDEFINED LOGON SEQUENCE TO REMOUT:

  IN ADDITION, THIS PROGRAM IS OPTIONALLY VIDEOTEXT COMPATIBLE.
*)


USES {$U TI.UNIT.CODE } REMUNIT ;


CONST
  ARROW_DOWN    =   139 ;
  ARROW_LEFT    =     8 ;
  ARROW_RIGHT   =   138 ;
  ARROW_UP      =   137 ;
  BACKSPACE     =     8 ;
  CLEAR_EOLN    =   141 ;
  CLEAR_EOS     =   152 ;
  CLEAR_SCREEN  =    12 ;
  CR            =    13 ;
  ESCAPE        =    27 ;
  FORMFEED      =    12 ;
  HOME_CURSOR   =   130 ;
  KB            =     2 ;
  LINEFEED      =    10 ;
  LOGLIMIT      = 20000 ;
  PRINTER       =     6 ;
  REMIN         =     7 ;
  REMOUT        =     8 ;
  RUBOUT        =   127 ;
  SCREENDEPTH   =    24 ;
  VERSION       = ' VERSION 1.02  9 June 81  USUS remote unit/911 CRT';

  
  
VAR
  C             : CHAR ;
  DONE          : BOOLEAN ;
  ECHO          : BOOLEAN ;
  FILTERCONTROL : BOOLEAN ;
  FILTERSET     : SET OF CHAR ;
  LOGARRAY      : PACKED ARRAY [ 0 .. LOGLIMIT ] OF CHAR ;
  LOGFILE       : TEXT ;
  LOGFILENAME   : STRING[ 30 ] ;
  LOGINDEX      : 0 .. LOGLIMIT ;
  LOGON1        : STRING ;
  LOGON2        : STRING ;
  LOGOPEN       : BOOLEAN ;
  LOGPROMPT     : CHAR ;
  LOGTEXT       : BOOLEAN ;
  NEARLY        : 0 .. LOGLIMIT ;
  VIDEOTEXT     : BOOLEAN ;


PROCEDURE LOGIT( C : CHAR ) ;
BEGIN
  IF ORD( C ) IN [BACKSPACE, RUBOUT]
    THEN
      IF LOGINDEX > 0
        THEN
          LOGINDEX := LOGINDEX - 1
        ELSE
          { NULL STATEMENT }
    ELSE
      LOGARRAY[ LOGINDEX ] := C ;
  IF LOGINDEX = NEARLY
    THEN
      BEGIN
      WRITELN ;
      WRITELN( ' ***> CURRENTLY AT 80% OF LOG SPACE <***' ) ;
      WRITELN ;
      END ;
  IF LOGINDEX >= LOGLIMIT 
    THEN
      BEGIN
      WRITELN ;
      WRITELN( ' >* LOGLIMIT EXCEEDED *< ', CHR(7), CHR(7) ) ;
      WRITELN ;
      LOGINDEX := 0 ;
      END
    ELSE
      LOGINDEX := LOGINDEX + 1 ;
END ;


PROCEDURE DISPLAY( C : CHAR ) ;
VAR
  ORD_C         : INTEGER ;
PROCEDURE V_GOTOXY ;
VAR
  C     : CHAR ;
  X     : INTEGER ;
  Y     : INTEGER ;
BEGIN
  REPEAT
  UNTIL CR_REMSTAT OR CR_KBSTAT ;
  IF CR_KBSTAT
    THEN
      BEGIN
      C := CR_GETKB ;
      EXIT( DISPLAY ) ;
      END ;
  C := CR_GETREM ;
  Y := ORD( C ) - 31 ;
  
  REPEAT
  UNTIL CR_REMSTAT OR CR_KBSTAT ;
  IF CR_KBSTAT
    THEN
      BEGIN
      C := CR_GETKB ;
      EXIT( DISPLAY ) ;
      END ;
  C := CR_GETREM ;
  X := ORD( C ) - 31 ;

  GOTOXY( X, Y ) ;

END ; { V_GOTOXY }

BEGIN

  IF VIDEOTEXT AND (C = CHR( ESCAPE ) )
    THEN
      BEGIN
      REPEAT
      UNTIL CR_REMSTAT OR CR_KBSTAT ;
      IF CR_KBSTAT
        THEN
          BEGIN
          C := CR_GETKB ;
          EXIT( DISPLAY ) ;
          END ;
      C := CR_GETREM ;
      ORD_C := 0 ;
      CASE C OF 
        'm',
        'l'      : ; { Wide character/Normal character }
        'A'      : ORD_C := ARROW_UP ; { Up arrow }
        'B'      : ORD_C := ARROW_DOWN ; { Down arrow }
        'C'      : ORD_C := ARROW_RIGHT ; { Right arrow }
        'D'      : ORD_C := ARROW_LEFT ; { Left arrow }
        'H'      : ORD_C := HOME_CURSOR ; { Home }
        'K'      : ORD_C := CLEAR_EOLN ; { Clear to end of line }
        'J'      : ORD_C := CLEAR_EOS ; { Clear to end of screen }
        'j'      : ORD_C := CLEAR_SCREEN ; { Clear screen }
        'Y'      : V_GOTOXY ; { VIDEOTEXT's GOTOXY }
        END ; { CASE ORD_C OF }
        IF ORD_C <> 0
          THEN
            WRITE( CHR( ORD_C ) ) ;
      END
    ELSE
      BEGIN
      ORD_C := ORD( C ) ;
      IF ORD_C > RUBOUT
        THEN
          C := CHR( ORD_C - (RUBOUT + 1) ) ;
      IF FILTERCONTROL
        THEN
          IF C IN FILTERSET
            THEN
              C := CHR( 0 ) ;
      IF C <> CHR( LINEFEED )
        THEN
          WRITE( C ) ;
      IF LOGTEXT
        THEN
          LOGIT( C ) ;
      END ;
END ;
        
    
FUNCTION QUESTION( PROMPT : STRING ) : BOOLEAN ;
VAR
  C             : CHAR ;
BEGIN
  WRITELN ;
  WRITELN ;
  WRITE  ( PROMPT, '(Y or N)?' ) ;
  REPEAT
    READ( KEYBOARD, C ) ;
  UNTIL C IN [ 'y', 'n', 'Y', 'N' ] ;
  WRITE( C ) ;
  QUESTION := C IN ['y', 'Y'] ;
END ;


PROCEDURE OPTIONS ;
BEGIN
  FILTERCONTROL := QUESTION( 
                 'DO YOU WISH TO FILTER CONTROL CHARACTERS' ) ;
  LOGTEXT := QUESTION( 'DO YOU WISH TO LOG THE TEXT' ) ;
  ECHO    := QUESTION( 'DO YOU WISH TO ECHO THE KEYBOARD' ) ;
  VIDEOTEXT := QUESTION(
        'DO YOU WISH TO RESPOND TO VIDEOTEXT CONTROL CODES' ) ;
  WRITELN ;
  WRITELN ;
  WRITELN ;
END ;


PROCEDURE INITIALIZE ;
VAR
  AUTOLOGON    : BOOLEAN ;
  B            : BOOLEAN ;
  C            : CHAR ;
  HAVEDIAL     : BOOLEAN ;
  HAVEREM      : BOOLEAN ;
  RESULT       : CR_BAUD_RESULT ;
BEGIN

  WRITELN ;
  WRITELN( 'TERMINAL PROGRAM.', VERSION ) ;
  WRITELN( 'COPYRIGHT 1980, 1981 BY ROBERT W. PETERSON' ) ;
  WRITELN( 'BYTES AVAILABLE = ', MEMAVAIL * 2 ) ;
  WRITELN( 'LOG BUFFER      = ', LOGLIMIT ) ;
  
  DONE      := FALSE ;
  FILTERSET := [ CHR( 0 ) .. CHR( BACKSPACE-1 ), 
                 CHR( BACKSPACE+1 ) .. CHR( CR-1 ), 
                 CHR( CR+1 ) .. CHR( 31 ), 
                 CHR( RUBOUT ) ] ;
  NEARLY    := (LOGLIMIT DIV 100) * 80 ;
  
  WRITELN ;
  IF QUESTION('Is <control E> a suitable attention character')
    THEN
      C := CHR( 5 )
    ELSE
      REPEAT
        B := FALSE ;
        REPEAT
          WRITE( 'What character will be used? ' ) ;
          WHILE NOT CR_KBSTAT DO ;
          C := CR_GETKB ;
          WRITELN( '<', ORD( C ), '>' ) ;
          IF C IN [' '..'~']
            THEN
              WRITELN( 
                      'You cannot use a displayable character')
            ELSE
              B := QUESTION( 'Is this correct' ) ;
        UNTIL B ;
      UNTIL NOT (C IN [' '..'~']) ;
  WRITELN ;
  
  LOGON1 := '' ;
  LOGON2 := LOGON1 ;
  
  CR_COMMINIT( CR_ORIG, C, HAVEREM, HAVEDIAL ) ;
  IF NOT HAVEREM
    THEN
      BEGIN
      WRITELN( ' REMOTE not supported in current environment.' ) ;
      WRITELN( ' Program is terminating.' ) ;
      EXIT( TERMINAL ) ;
      END ;
  
  OPTIONS ;
  
  CR_SETCOMMUNICATIONS( 
                TRUE,
                TRUE,
                300,
                7,
                1,
                CR_ORIG,
                '990/5',
                RESULT ) ;
  
  WRITELN ;
  WRITELN( 'Proceed when connection has been made.' ) ;
  CR_ANSWER ;
  
  WRITELN ;
  WRITELN ;
  
END ;

PROCEDURE CLOSELOG ;
VAR
  RESULT        : INTEGER ;
BEGIN
  IF LOGOPEN
    THEN
      BEGIN
      CLOSE( LOGFILE, LOCK ) ;
      RESULT := IORESULT ;
      WRITE( LOGFILENAME ) ;
      IF RESULT = 0
        THEN
          WRITELN(' HAS BEEN CLOSED.' )
        ELSE
          WRITELN(' FAILED TO CLOSE.  IORESULT = ', RESULT ) ;
      END ;
END ;


PROCEDURE SETLOGFILENAME ;
VAR
  RESULT        : INTEGER ;
BEGIN

  WRITELN ;
  CLOSELOG ;
  
(*$I-*)

  REPEAT
    WRITELN ;
    WRITE  ( 'WHAT IS THE NEW LOG FILENAME? ') ;
    READLN ( LOGFILENAME ) ;
    IF (LOGFILENAME = 'PRINTER:') OR (LOGFILENAME = 'CONSOLE:') OR
       (LOGFILENAME = 'printer:') OR (LOGFILENAME = 'console:')
      THEN
        RESULT := 1
      ELSE
        BEGIN
        RESET  ( LOGFILE, LOGFILENAME ) ;
        RESULT := IORESULT ;
        END ;
    IF RESULT = 0
      THEN
        BEGIN
        CLOSE( LOGFILE, LOCK ) ;
        RESULT := 1 ;
        WRITELN ;
        WRITELN( LOGFILENAME, ' EXISTS!' ) ;
        END
      ELSE
        IF LENGTH( LOGFILENAME ) > 0
          THEN
            BEGIN
            WRITE( 'OPEN OF ', LOGFILENAME, ' ' ) ;
            REWRITE( LOGFILE, LOGFILENAME ) ;
            RESULT := IORESULT ;
            LOGOPEN := RESULT = 0 ;
            IF NOT LOGOPEN
              THEN
                WRITELN( ' FAILED.  REWRITE RESULT = ', RESULT )
              ELSE
                WRITELN( ' WAS SUCCESSFUL.' ) ;
            END ;
  UNTIL LOGOPEN OR (LENGTH( LOGFILENAME ) = 0 ) ;
  WRITELN ;

(*$I+*)

END ;


PROCEDURE CLEARLOG ;
BEGIN
  IF QUESTION( 'CLEAR LOG: ARE YOU SURE' )
    THEN
      LOGINDEX := 0
END ;


PROCEDURE SAVELOG ;
CONST
  BLANK         = ' ' ;
  RETURNCHAR    =  13 ;
VAR
  C             : CHAR ;
  I             : 0 .. LOGLIMIT ;
  LINECOUNT     : INTEGER ;
  LINESPERPAGE  : INTEGER ;
  RESULT        : INTEGER ;
  TILDE         : CHAR ;
  TRASH         : CHAR ;
  UNITFILE      : BOOLEAN ;
  WRITTEN       : BOOLEAN ;
BEGIN
  WRITELN ;
  TILDE := '~' ;
  IF NOT LOGOPEN
    THEN
      BEGIN
      WRITELN( 'THE LOG FILE IS NOT OPEN!' ) ;
      WRITELN ;
      EXIT( SAVELOG ) ;
      END ;
  
  WRITELN( 'THERE ARE ', LOGINDEX, ' CHARACTERS IN THE LOG.');
  
  UNITFILE := (LOGFILENAME = 'CONSOLE:') 
           OR (LOGFILENAME = 'PRINTER:')
           OR (LOGFILENAME = 'console:')
           OR (LOGFILENAME = 'printer:') ;
  IF UNITFILE
    THEN
      BEGIN
      IF (LOGFILENAME = 'PRINTER:') OR (LOGFILENAME = 'printer:')
        THEN
          LINESPERPAGE := 32767
        ELSE
          LINESPERPAGE := SCREENDEPTH - 2 ;
      PAGE( LOGFILE ) ;
      WRITELN( 'WRITING LOG TO ', LOGFILENAME )
      END
    ELSE
      BEGIN
      WRITELN( 'WRITING LOG (', LOGFILENAME, ').' ) ;
      WRITE  ( ' ':11 ) ;
      END ;
  LINECOUNT     := 0 ;
  
  FOR I := 0 TO LOGINDEX-1 DO
    BEGIN
    C := LOGARRAY[ I ] ;
    IF    (C >= BLANK)
      AND (C <= TILDE)
      THEN
        BEGIN
        WRITTEN := TRUE ;
        WRITE( LOGFILE, C ) ;
        END
      ELSE
        IF C = CHR( RETURNCHAR )
          THEN
            IF WRITTEN
              THEN
                IF UNITFILE
                  THEN
                    BEGIN
                    WRITELN( LOGFILE ) ;
                    IF LINECOUNT >= LINESPERPAGE
                      THEN
                        BEGIN
                        WRITE( 'PRESS ANY KEY TO CONTINUE' ) ;
                        REPEAT
                        UNTIL CR_KBSTAT ;
                        TRASH := CR_GETKB ;
                        LINECOUNT := 0 ;
                        PAGE( LOGFILE ) ;
                        END
                      ELSE
                        LINECOUNT := LINECOUNT + 1 ;
                    END
                  ELSE
                    BEGIN
                    IF LINECOUNT >= 50
                      THEN
                        BEGIN
                        WRITELN ;
                        WRITE( ' ':11 ) ;
                        LINECOUNT := 1 ; 
                        END
                      ELSE
                        LINECOUNT := LINECOUNT + 1 ;
                    WRITE( '.' ) ;
                    WRITELN( LOGFILE ) ;
                    END ;
  
    RESULT := IORESULT ;
    IF RESULT <> 0
      THEN
        BEGIN
        WRITELN ;
        WRITELN( 'BAD RETURN IN SAVELOG: ', RESULT ) ;
        WRITELN( 'TERMINATING LOG SAVE' ) ;
        WRITELN ;
        EXIT( SAVELOG ) ;
        END ;
    END ; (* FOR *)
  
  WRITELN ;
  
  CLEARLOG ;
  
(*$I+*)

END ;


PROCEDURE SENDLOGON ;
VAR
  I             : 0 .. LOGLIMIT ;
BEGIN
  WRITELN ;
  WRITELN( 'TRANSMITTNG LOGON' ) ;
  FOR I := 1 TO LENGTH( LOGON1 ) DO
    BEGIN
    CR_PUTREM( LOGON1[ I ] ) ;
    REPEAT
    UNTIL CR_REMSTAT OR CR_KBSTAT ;
    IF CR_REMSTAT
      THEN
        DISPLAY( CR_GETREM ) ;
    END ;
  CR_PUTREM( CHR(13) ) ; (* CR *)
  REPEAT
    IF CR_REMSTAT
      THEN
        BEGIN
        C := CR_GETREM ;
        DISPLAY( C ) ;
        END
      ELSE
        C := CHR( 0 ) ;
  UNTIL (C = LOGPROMPT) OR CR_KBSTAT ;
  FOR I := 1 TO LENGTH( LOGON2 ) DO
    CR_PUTREM( LOGON2[ I ] ) ;
  CR_PUTREM( CHR(13) ) ; (* CR *)
END ;


PROCEDURE DUMPFILE ;
CONST
  CR           = 13 ;
  LF           = 10 ;
  
VAR
  I            : INTEGER ;
  LINEFEED     : BOOLEAN ;
  LOGSTATUS    : BOOLEAN ;
  PACE         : BOOLEAN ;
  READBUFFER   : STRING ;
  RESULT       : INTEGER ;
  WAIT_CHARACTER : CHAR ;
  WAIT_CR      : BOOLEAN ;
  XMITFILE     : TEXT ;
  XMITNAME     : STRING ;


PROCEDURE DUMPIT ;
BEGIN

  WRITELN ;
  WRITELN( 'TRANSMITTING ', XMITNAME ) ;
  WRITELN( 'USE ^E TO ABORT TRANSMISSION' ) ;
  WHILE NOT EOF( XMITFILE ) DO
    BEGIN
    READLN( XMITFILE, READBUFFER ) ;
    FOR I := 1 TO LENGTH( READBUFFER ) DO
      BEGIN
      IF NOT CR_CARRIER
        THEN
          BEGIN
          WRITELN ;
          WRITELN( 'LOST CARRIER.  TRANSMITTING ABORTED.' ) ;
          EXIT( DUMPIT ) ;
          END ;
      CR_PUTREM( READBUFFER[ I ] ) ;
      IF PACE
        THEN
          REPEAT
          UNTIL CR_REMSTAT OR CR_KBSTAT ;
      IF CR_REMSTAT
        THEN
          DISPLAY( CR_GETREM ) ;
      END ;
    CR_PUTREM( CHR( CR ) ) ;
    IF LINEFEED
      THEN
        CR_PUTREM( CHR( LF ) ) ;
    IF WAIT_CR
      THEN
        REPEAT
          IF CR_REMSTAT
            THEN
              BEGIN
              C := CR_GETREM ;
              DISPLAY( C ) ;
              END
            ELSE
              C := CHR( 0 ) ;
        UNTIL (C = WAIT_CHARACTER) OR CR_KBSTAT ;
    IF CR_KBSTAT
      THEN
        IF CR_GETKB = CR_ATTENCHAR
          THEN
            EXIT( DUMPIT ) ;
    END

END ;

  
BEGIN

(*$I-*)

  LOGSTATUS := LOGTEXT ;
  
  WRITELN ;
  WRITELN( 'DUMP A FILE TO REMOUT:' ) ;
  WRITELN( 'To quit, enter an empty filename.' ) ;
  WRITELN ;
  LOGTEXT  := FALSE ; { TURN OFF LOGGING }
  LINEFEED := QUESTION( 'TRANSMIT LINEFEED AFTER EACH CARRIAGE RETURN ' ) ;
  PACE     := QUESTION( 'WAIT FOR EACH CHARACTER TO BE ECHOED ' ) ;
  WAIT_CR  := QUESTION( 'WAIT FOR A RETURNED CHARACTER AFTER EACH LINE ' ) ;
  IF WAIT_CR
    THEN
      REPEAT
        WRITELN ;
        WRITE( 'ENTER THE CHARACTER TO WAIT FOR:' ) ;
        READ( KEYBOARD, WAIT_CHARACTER ) ;
        IF EOLN 
          THEN 
            WAIT_CHARACTER := CHR( CR ) ;
        IF WAIT_CHARACTER IN [' '..'~']
          THEN
            WRITELN( WAIT_CHARACTER )
          ELSE
            WRITELN( '<', ORD(WAIT_CHARACTER), '>' ) ;
      UNTIL QUESTION( 'IS THIS THE CORRECT CHARACTER ' )
    ELSE
      WAIT_CHARACTER := CHR( 0 ) ;
  
    REPEAT
      WRITELN ;
      WRITE  ( 'WHAT IS THE TRANSMIT FILENAME? ') ;
      READLN ( XMITNAME ) ;
      IF LENGTH( XMITNAME ) <> 0
        THEN
          BEGIN
          RESET  ( XMITFILE, CONCAT( XMITNAME, '.TEXT' ) ) ;
          RESULT := IORESULT ;
          IF RESULT = 0
            THEN
              BEGIN
              DUMPIT ;
              WRITE( XMITNAME, ' COMPLETED.' ) ;
              END
            ELSE
              BEGIN
              RESET  ( XMITFILE, XMITNAME ) ;
              RESULT := IORESULT ;
              IF RESULT = 0
                THEN
                  BEGIN
                  DUMPIT ;
                  WRITE( XMITNAME, ' COMPLETED.' ) ;
                  END
                ELSE
                  BEGIN
                  WRITELN ;
                  WRITELN( 'CANNOT FIND ', XMITNAME ) ;
                  END ;
              END ;
          END ;
  UNTIL (LENGTH( XMITNAME ) = 0 ) ;
  
(*$I+*)

  LOGTEXT := LOGSTATUS ; { Restore original logging status }

END ;



PROCEDURE MENU ;
CONST
  OUTPUTLOGON           = '5' ;
  QUIT                  = '6' ;
  RETURNTOTERMINAL      = '8' ;
VAR
  GOOD                  : BOOLEAN ;
  O                     : CHAR ;
BEGIN
  REPEAT
    WRITELN ;
    WRITELN( 'TERMINAL PROGRAM. ', VERSION ) ;
    WRITELN( 'COPYRIGHT 1980, 1981 BY ROBERT W. PETERSON' ) ;
    IF LOGTEXT
      THEN
        WRITELN( 'TOTAL LOG SPACE = ', LOGLIMIT,
                 '.  SPACE USED = ', LOGINDEX,
                  ' (', LOGINDEX DIV (LOGLIMIT DIV 100),
                  '%)' ) ;
    WRITELN( '1. SET OPTIONS' ) ;
    WRITELN( '2. SELECT LOG FILENAME' ) ;
    WRITELN( '3. SAVE LOG' ) ;
    WRITELN( '4. RESET (CLEAR) LOG' ) ;
    WRITELN( '5. SEND LOGON STRING' ) ;
    WRITELN( '6. QUIT TERMINAL PROGRAM' ) ;
    WRITELN( '7. TRANSMIT FILE' ) ;
    WRITELN( '8. QUIT OPTIONS' ) ;
    WRITELN( '9. REINITIALIZE' ) ;
    WRITELN ;
    WRITE  ( 'SELECT OPTION NUMBER:' ) ;
    READ   ( O ) ;
    GOOD := O IN [ '1' .. '9' ] ;
    IF GOOD
      THEN
        CASE O OF
          '1' : OPTIONS ;
          '2' : SETLOGFILENAME ;
          '3' : SAVELOG ;
          '4' : CLEARLOG ;
          OUTPUTLOGON : SENDLOGON ;
          QUIT: DONE := TRUE ;
          '7' : DUMPFILE ;
          RETURNTOTERMINAL : ;
          '9' : INITIALIZE ;
          END ;
  UNTIL O IN [ OUTPUTLOGON, RETURNTOTERMINAL, QUIT, '7' ] ;
  WRITELN ;
END ;



BEGIN

  LOGINDEX  :=     0 ;
  LOGOPEN   := FALSE ;
  
  INITIALIZE ;
  
  REPEAT
    IF CR_KBSTAT
      THEN
        BEGIN
        C := CR_GETKB ;
        IF C = CR_ATTENCHAR
          THEN
            BEGIN
            MENU ;
            IF NOT (CR_CARRIER OR DONE)
              THEN
                CR_ANSWER ;
            END
          ELSE
            BEGIN
            CR_PUTREM( C ) ;
            IF ECHO
              THEN
                DISPLAY( C ) ;
            END ;
        END ;
    IF NOT CR_CARRIER
      THEN
        BEGIN
        WRITELN ;
        WRITELN('LOST CARRIER');
        WRITELN ;
        MENU ;
        IF NOT (CR_CARRIER OR DONE)
          THEN
            CR_ANSWER ;
        END
      ELSE
        IF CR_REMSTAT
          THEN
            DISPLAY( CR_GETREM ) ;

  UNTIL DONE ;

  IF LOGINDEX > 0
    THEN
      BEGIN
      WRITELN ;
      WRITE  ( 'You have ', LOGINDEX, ' characters in the log which have not' );
      WRITELN( ' been written to disk.');
      IF QUESTION( 'Do you wish to write the log ' )
        THEN
          BEGIN
          IF NOT LOGOPEN
            THEN
              SETLOGFILENAME ;
          SAVELOG ;
          END ;
      END ;
  
  CLOSELOG ;

  CR_COMMQUIT ;

END.


========================================================================================
DOCUMENT :usus Folder:VOL08:rem.unit.text
========================================================================================

program AUNIT ; { This is REMUNIT for a TI-990 }
{xL printer: }
{$S+}

unit REMUNIT ;
interface


{============== Copyright Notice =============================================}
{$c Copyright 1980, 1981 by Robert W. Peterson }
{============== Copyright Notice =============================================}


{ 
  This is a separate compilation unit intended to stand between application
  code and a communications line.  Implementation of this unit follows the
  specifications and suggestions set out in the January 1981 draft of the 
  USUS remote unit specification.
  
  This unit is designed to interface to the following model codes:
     DS1
     DS2
     990
     990/4
     990/5
     990/10
     990/12

  This unit assumes the compiler understands and the BIOS (or SBIOS)
  implements UNITSTATUS in the standard manner.
  
}

type
  CR_DIALRESULT     = ( CR_OFF_HOOK, CR_DIALERROR, CR_NOAUTODIAL ) ;
  CR_BAUD_RESULT    = ( CR_BAD_PARAMETER, 
                        CR_BAD_RATE, 
                        CR_RATE_SET_OK, 
                        CR_SELECT_NOT_SUPPORTED ) ;
  CR_WHOAMI         = ( CR_ORIG, CR_ANS ) ;
  CR_REM_PORT       = packed record
                        PART1 : integer ;
                        PART2 : integer ;
                        end ; { T_REM_PORT }
                        
var
  CR_ATTENCHAR      : char ;
  CR_CURRENT_PORT   : CR_REM_PORT ;

{    Initialization and termination. }
procedure CR_COMMINIT(   DIR                 : CR_WHOAMI ;
                         ATTENTION_CHARACTER : char ;
                     var REMOTE_EXISTS       : boolean ;
                     var DIALER_EXISTS       : boolean ) ;

procedure CR_COMMQUIT ;


{    Input status. }
function  CR_KBSTAT                 : boolean ;
function  CR_REMSTAT                : boolean ;


{    Input/Output operations. }
function  CR_GETKB                  : char ;
function  CR_GETREM                 : char ;
procedure CR_PUTREM(   C            : char ) ;


{    Control procedures.      }
procedure CR_ANSWER ;
procedure CR_BREAK ;
function  CR_CARRIER                : boolean ;
function  CR_CLEARTOSEND            : boolean ;
procedure CR_DELAY( TENTHS          : integer ) ;
procedure CR_DIAL( NUMBER           : string ;
                WAITCHAR            : char ;
            var RESULT              : CR_DIALRESULT ) ;
procedure CR_HOOK( ON_HOOK          : boolean ) ;
procedure CR_SETADDRESS( HIGHADDR   : integer ;
                         LOWADDR    : integer ;
                         VECTOR     : integer ) ;
procedure CR_SETCOMMUNICATIONS(
                PARITY              : boolean ;
                EVEN                : boolean ;
                RATE                : integer ;
                CHARBITS            : integer ;
                STOPBITS            : integer ;
                DIR                 : CR_WHOAMI ;
                MODEL               : string ;
            var RESULT              : CR_BAUD_RESULT ) ;
                
implementation

const
  DEFAULT_RATE     = 300 ;
  DEFAULT_MODE     = TRUE ; { Default is with parity enabled. }
  DEFAULT_PARITY   = TRUE ; { Default is even parity enabled. }
  DEFAULT_CHARBITS = 7 ;    { Default to 7 data bits.         }
  DEFAULT_STOPBITS = 2 ;    { Default to 2 stop bits.         }
  KB_UNIT          = 2 ;
  REMIN_UNIT       = 7 ;
  REMOUT_UNIT      = 8 ;
  TIMER            = 500 ;
  
type
  T_CLOCK = record
            case boolean of 
              { NOTE: TI uses binary representation for long integers.  }
              true  : ( ticks      : integer[ 4 ] ) ;
              false : ( hitime     : integer ;
                        lotime     : integer ) ;
              end ; { case }
  
  TRICK   = packed record
            case integer of 
            1 : ( A : packed array[ 0..80 ] of char ) ;
            2 : ( S : string[ 80 ] ) ;
            3 : ( I : integer ;
                  J : integer ) ;
            4 : ( L : array [0 .. 39] of integer ) ;
            5 : ( B : array [0 .. 39] of boolean ) ;
            6 : ( C : packed record
                      CHARL : char ;
                      CHARR : char ;
                      end ) ;
            end ; { P }

var
  BAUD_SETTABLE : boolean ;
  CONTROL       : integer ;
  CURRENT_BAUD  : integer ;
  MODEL_ID      : string ;
  OFF_HOOK      : boolean ;
  
{  --------------------------------------------------------------------------  }
{                              EXTERNAL PROCEDURES                             }
{  --------------------------------------------------------------------------  }

procedure CLEARBIT( I : integer ) ;             external ;
procedure LOADCRU ( I : integer ;
                    J : integer ) ;             external ;
procedure SETBASE ( I : integer ) ;             external ;
procedure SETBIT  ( I : integer ) ;             external ;


{  --------------------------------------------------------------------------  }
{                              CONTROL PROCEDURES                              }
{  --------------------------------------------------------------------------  }

procedure CR_ANSWER ;
var
  WAITING      : boolean ;

begin
  WAITING := true ;
  while WAITING do
    begin
    WAITING := not CR_CARRIER ;
    if WAITING
      then
        if CR_KBSTAT
          then
            WAITING := CR_GETKB <> CR_ATTENCHAR ;
    end ;
  OFF_HOOK := not WAITING ;
  if not WAITING
    then
      begin
      unitclear( REMIN_UNIT ) ;
      unitclear( REMOUT_UNIT ) ;
      end ;
end ; { CR_ANSWER }

procedure CR_BREAK ;
const
  BASE_5  = { 1740H } 5952 ;       { This is the base address. }
  BREAK_5 = 17 ;                   { This is the bit number. }
begin
  if (MODEL_ID = '990/5') or (MODEL_ID = 'DS2')
    then
      begin
      SETBASE ( BASE_5  ) ;
      SETBIT  ( BREAK_5 ) ;
      CLEARBIT( BREAK_5 ) ;
      end ;
end ;

function  CR_CARRIER{: boolean};
var
  P       : TRICK ;
begin
  unitstatus( REMIN_UNIT, P.L, 0 ) ;
  CR_CARRIER  := P.B[1] ;
  OFF_HOOK    := P.B[1] ;
end ; { CR_CARRIER }

function CR_CLEARTOSEND {: boolean } ;
begin
  CR_CLEARTOSEND := CR_CARRIER ;
end ; { CR_CLEARTOSEND }

procedure CR_DELAY{ TENTHS : integer } ;
{ Purpose: delay 0.1 seconds for each tenth requested. }
var
  clock        : T_CLOCK ;
  I            : integer ;
  target       : integer[ 4 ] ;
begin
  
  if TIMER <= 1
    then
      exit( CR_DELAY ) ;
  I := TIMER ;
  time( CLOCK.HITIME, CLOCK.LOTIME ) ;
  TARGET := CLOCK.TICKS + 6 * TENTHS ; { 6 is 0.1 * 60 ticks/second }
  repeat
    I := I - 1 ;
    time( CLOCK.HITIME, CLOCK.LOTIME ) ;
  until (I = 0) or (CLOCK.TICKS >= TARGET) ;
end ; { CR_DELAY }

procedure CR_DIAL{ NUMBER   : string ;
               var RESULT   : CR_DIALRESULT } ;
begin
  RESULT := CR_NOAUTODIAL ;
end ; { DIAL }

procedure CR_HOOK{ ON_HOOK : boolean } ;
begin
  OFF_HOOK := not ON_HOOK ;
end ; { CR_HOOK }


{  --------------------------------------------------------------------------  }
{                               STATUS PROCEDURES                              }
{  --------------------------------------------------------------------------  }

function CR_KBSTAT {: boolean} ;
var
  P       : TRICK ;
begin
  unitstatus( KB_UNIT, P.S,  1 ) ;
  CR_KBSTAT := (P.I > 0) ;
end ; { CR_KBSTAT }

function CR_REMSTAT {: boolean} ;
var
  P       : TRICK ;
begin
  unitstatus( REMIN_UNIT, P.S,  1 ) ;
  CR_REMSTAT := P.I > 0 ;
end ; { CR_REMSTAT }



{  --------------------------------------------------------------------------  }
{                            INPUT/OUTPUT OPERATIONS                           }
{  --------------------------------------------------------------------------  }

procedure IOERR( UNIT_NUM, ERR : integer ) ;
begin
  if ERR <> 0
    then
      begin
      writeln ;
      writeln( 'UNIT = ', UNIT_NUM:1, ' IOERROR = ', ERR:4, '   ' ) ;
      writeln ;
      end ;
end ; { IOERR }

function CR_GETKB {: char} ;
var
  ARAY         : TRICK ;
begin 
  repeat
  until CR_KBSTAT ;
  
  unitread( KB_UNIT, ARAY.A, 1 ) ;
  CR_GETKB := ARAY.A[0] ;
  IOERR( KB_UNIT, ioresult ) ;
end ;


function CR_GETREM {: char} ;
var
  P         : TRICK ;
begin
(*----------------------- DELETED --------------------------------------
  repeat
  until REMSTAT ;
----------------------------------------------------------------------*)
  
  unitread( REMIN_UNIT, P.A, 1, 0, CONTROL ) ;
  CR_GETREM := P.A[0] ;

(*----------------------- DELETED --------------------------------------
  IOERR( REMIN_UNIT, ioresult ) ;
----------------------------------------------------------------------*)
end ; { CR_GETREM }

procedure CR_PUTREM{ C : char } ;
var
  P         : TRICK ;
begin
  if CR_CARRIER
    then
      begin
      P.A[0] := C ;
      unitwrite( REMOUT_UNIT, P.A, 1, 0, CONTROL ) ;
      IOERR( REMOUT_UNIT, ioresult ) ;
      end ;
end ; { CR_PUTREM }



{  --------------------------------------------------------------------------  }
{                         INITIALIZATION/TERMINATION                           }
{  --------------------------------------------------------------------------  }

procedure CR_SETADDRESS{ HIGHADDR      : integer ;
                         LOWADDR       : integer ;
                         VECTOR        : integer } ;
begin
  with CR_CURRENT_PORT do
    begin
    PART1 := HIGHADDR ;
    PART2 := LOWADDR  ;
    end ;
end ; { CR_SETADDRESS }

procedure CR_SETCOMMUNICATIONS{
                      PARITY        : boolean ;
                      EVEN          : boolean ;
                      RATE          : integer ;
                      CHARBITS      : integer ;
                      STOPBITS      : integer ;
                      DIR           : CR_WHOAMI ;
                      MODEL         : string ;
                  var RESULT        : CR_BAUD_RESULT } ;

procedure SETDS1 ;

const
  CRUBASE      =   0 ;    { Plug P6; P7 = 352 }
  LOADRG       =   8 ;
      
var
  BAUD_WORD    : INTEGER ;

begin

  MODEL_ID := MODEL ;
  
  if PARITY
    then
      if EVEN
        then
          CONTROL := 16396
        else
          begin
          RESULT := CR_BAD_PARAMETER ;
          exit( SETDS1 ) ;
          end
    else
      CONTROL := 12 ;
      
  SETBASE(CRUBASE);
  
  if RATE = 9600
    then BAUD_WORD := 2048
  else
  if RATE = 4800
    then BAUD_WORD := 2304
  else
  if RATE = 2400
    then BAUD_WORD := 2560
  else
  if RATE = 1200
    then BAUD_WORD := 2816
  else 
  if RATE = 600
    then BAUD_WORD := 3072
  else
  if RATE = 300
    then BAUD_WORD := 3328
  else
  if RATE = 150
    then BAUD_WORD := 7168
  else
  if RATE = 110
    then BAUD_WORD := -31232
  else
  if RATE = 75
    then BAUD_WORD := 3840
      else
        begin
        RESULT := CR_BAD_RATE ;
        exit( SETDS1 ) ;
        end ;
  
  SETBIT(LOADRG);
  LOADCRU(BAUD_WORD,8);
  CLEARBIT(LOADRG);

  RESULT := CR_RATE_SET_OK ;

  BAUD_SETTABLE := true ;
  
end ; { SET1 }

procedure SET990_5 ;{ Set the 990/5's second RS-232
                  port's baud rate.              }

const
  BASE                  =  { >1740 }   5952 ;
  BAUD_BIT_COUNT        =                12 ;
  B110                  =  { >0638 }   1592 ;
  B300                  =  { >04D0 }   1232 ;
  B1200                 =  { >01A1 }    417 ;
  B2400                 =  { >00D0 }    208 ;
  B4800                 =  { >0068 }    104 ;
  B9600                 =  { >0034 }     52 ;
  B19200                =  { >001A }     26 ;
  MODE_BIT_COUNT        =                 8 ;
  MODE_TRANSPARENT      =  { >4B00 }  19200 ;{ 2 stop bits, no parity, 4Mhz,
                                               8 data bits                     }
  MODE_EVEN_PARITY      =  { >AA00 } -22016 ;{ 1 stop bit, even parity, 4Mhz,
                                               7 data bits                     }
  MODE_ODD_PARITY       =  { >BA00 } -17920 ;{ 1 stop bit, odd parity, 4Mhz,
                                               7 data bits                     }
  RESET_PORT            =                31 ;
  TIMER_BIT             =                13 ;
  
var
  BAUD          : integer ;
  
begin

  MODEL_ID := MODEL ;
  
  RESULT := CR_RATE_SET_OK ;
  
  if RATE = 110 then BAUD := B110
    else
    if RATE =   300 then BAUD :=   B300
    else
    if RATE =  1200 then BAUD :=  B1200
    else
    if RATE =  2400 then BAUD :=  B2400
    else
    if RATE =  4800 then BAUD :=  B4800
    else
    if RATE =  9600 then BAUD :=  B9600
    else
    if RATE = 19200 then BAUD := B19200
    else
      begin
      RESULT := CR_BAD_RATE ;
      exit( SET990_5 ) ;          { Get out if not a valid speed.         }
      end ;
  
  SETBASE( BASE ) ;             { Set base address of second /5 port.   }

  SETBIT ( RESET_PORT ) ;       { Reset the port.                       }

  if PARITY
    then
      begin
      CONTROL := 12 ;
      LOADCRU( MODE_TRANSPARENT,
               MODE_BIT_COUNT ) ;{ Set for transparent mode.            }
      end
    else
      if EVEN
        then
          begin
          CONTROL := 16396 ;
          LOADCRU( MODE_EVEN_PARITY,
               MODE_BIT_COUNT ) ;{ Set for even parity (IMS).           }
          end
        else
          begin
          CONTROL := 12 ;
          LOADCRU( MODE_ODD_PARITY,
               MODE_BIT_COUNT ) ;{ Set for odd parity.                  }
          end ;
  CLEARBIT( TIMER_BIT ) ;       { Turn off the timer.                   }
  
  LOADCRU( BAUD, BAUD_BIT_COUNT ) ;{ Set the baud rate.                 }
  
  SETBIT  ( 16 ) ;              { Misc. settings                        }
  SETBIT  ( 18 ) ;
  CLEARBIT( 19 ) ;
  CLEARBIT( 20 ) ;
  CLEARBIT( 21 ) ;
  
  BAUD_SETTABLE := true ;
  
end ; { SET5 }

procedure SET990 ;
begin
  if PARITY
    then
      if EVEN
        then
          CONTROL := 16396 
        else
          CONTROL := 12
    else
      CONTROL := 12 ;
  RESULT := CR_RATE_SET_OK ;
end ; { SET990 }

begin

  MODEL_ID := '' ;

  BAUD_SETTABLE := false ;
  
  RESULT := CR_SELECT_NOT_SUPPORTED ;

  if MODEL = 'DS1'
    then
      SETDS1
    else if (MODEL = 'DS2') OR (MODEL = '990/5')
    then
      SET990_5
    else if length( MODEL )>2 then if (copy(MODEL,1,3) = '990')
    then
      SET990
    else
      CONTROL := 12 ;
  
end ; { CR_SETCOMMUNICATIONS }

procedure NOT_IMPLEMENTED( UNIT_NUM : integer ;
                       var NOT_THERE : boolean ) ;
var
  RESULT       : integer ;
begin
  unitclear( UNIT_NUM ) ;
  RESULT := ioresult ;
  if RESULT <> 0
    then
      begin
      writeln ;
      writeln ;
      if RESULT = 9
        then
          begin
          writeln( 'Unit ', UNIT_NUM, ' not implemented!' ) ;
          end
        else
          begin
          writeln( 'Error in UNITCLEAR(', UNIT_NUM, ') : ', RESULT ) ;
          end ;
      NOT_THERE := true ;
      end 
    else
      NOT_THERE := false ;
end ;

procedure CR_COMMINIT{ DIRECTION           : CR_WHOAMI ;
                       ATTENTION_CHARACTER : char ;
                   var REMOTE_EXISTS       : boolean ;
                   var DIALER_EXISTS       : boolean } ;

var
  RESULT          : CR_BAUD_RESULT ;
  UNIT_NOT_THERE  : boolean ;

begin
  { Set no auto-dial. }
  DIALER_EXISTS := false ;
  
  { Check that the required units are implemented. }
  REMOTE_EXISTS := true ;
  NOT_IMPLEMENTED( REMIN_UNIT, UNIT_NOT_THERE ) ;
  if UNIT_NOT_THERE
    then
      begin
      REMOTE_EXISTS := false ;
      exit( CR_COMMINIT ) ;
      end ;
  NOT_IMPLEMENTED( REMOUT_UNIT, UNIT_NOT_THERE ) ;
  if UNIT_NOT_THERE
    then
      begin
      REMOTE_EXISTS := false ;
      exit( CR_COMMINIT ) ;
      end ;

  MODEL_ID := '' ;
  
  OFF_HOOK := false ;
  
  BAUD_SETTABLE := false ;
  
  CR_ATTENCHAR := ATTENTION_CHAR ;
  
  CR_SETCOMMUNICATIONS( DEFAULT_MODE,
                        DEFAULT_PARITY,
                        DEFAULT_RATE,
                        DEFAULT_CHARBITS,
                        DEFAULT_STOPBITS,
                        DIR,
                        MODEL_ID,
                        RESULT ) ;

end ;

procedure CR_COMMQUIT ;
var
  RESULT        : CR_BAUD_RESULT ;
begin
  OFF_HOOK := false ;
  if BAUD_SETTABLE
    then
      CR_SETCOMMUNICATIONS( DEFAULT_PARITY, 
                            DEFAULT_MODE, 
                            DEFAULT_RATE, 
                            DEFAULT_CHARBITS,
                            DEFAULT_STOPBITS,
                            CR_ORIG,
                            MODEL_ID,
                            RESULT ) ;
end;

end.



========================================================================================
DOCUMENT :usus Folder:VOL08:screen.text
========================================================================================

{$s+}     
{$i header }
{$i globals } 
{$i forwards }

unit screencontrol; 

interface
  
  type months = 0..12;
       days   = 0..31;
       years  = 0..99;
  
  procedure home; 
  procedure cleareos;
  procedure cleareol;
  procedure date (var m: months; var d: days; var  y: years);
  function  screenwidth: integer; 
  function  screenheight: integer;  
  
implementation
  
  procedure home;
  begin
    homecursor;
  end;

  procedure cleareos;
    var c: char;
  begin 
    with syscom^ do
      begin
        if crtctrl.eraseeos <> chr(0) then
          begin
            if crtctrl.prefixed[3] then
              begin
                c := crtctrl.escape; 
                unitwrite(1,c,1,,4); {no DLE expansion}
              end;
            write(crtctrl.eraseeos); 
            if length(filler) > 0 then write(filler); 
          end;
      end;
  end {cleareos};    
  
  procedure cleareol; 
  begin
    clearline;
  end;
  
  procedure date {var m: months; var d: days; var y: years}; 
  begin
    m := thedate.month;     
    d := thedate.day; 
    y := thedate.year;
  end; 
  
  function screenwidth {: integer}; 
  begin
    screenwidth := syscom^.crtinfo.width;
  end;
  
  function screenheight {: integer};  
  begin
    screenheight := syscom^.crtinfo.height; 
  end;
  
end {screencontrol};

begin { syscode } end;

begin  { pascal system } end.


========================================================================================
DOCUMENT :usus Folder:VOL08:screenunit.text
========================================================================================

UNIT SCREENUNIT;

INTERFACE
                   {these declarations must be global}
TYPE XFILE = FILE;
     CRTCOMMAND = (ERASEOS,ERASEOL,UP,DOWN,RIGHT,LEFT,LEADIN);

VAR CRTINFO:   PACKED ARRAY[CRTCOMMAND] OF CHAR;
    PREFIXED:  ARRAY[CRTCOMMAND] OF BOOLEAN;

PROCEDURE GETCRTINFO;
PROCEDURE CRT ( C : CRTCOMMAND );
PROCEDURE VER_SCREENUNIT;
PROCEDURE IO_ERROR( IORESLT         : INTEGER;
                    FILENAME        : STRING);
PROCEDURE BAD_IO(VAR  FILEID           :XFILE;
                       FILENAME         :STRING;
                       IORESLT          :INTEGER;
                       RSET             :BOOLEAN;
                  VAR  IO_OK            :BOOLEAN);

IMPLEMENTATION
(*$I-*)
(*$R-*)

{**************}

PROCEDURE VER_SCREENUNIT;

BEGIN
   WRITELN('uses screenunit version 5      18-Jul-81');
END;

PROCEDURE GETCRTINFO; {adapted from Roger Soles version in the USUS library}

TYPE BYTE = PACKED ARRAY[0..7] OF BOOLEAN;
     SWITCH = (CH,BOOL);
     
     DUMMY = RECORD
        CASE SWITCH OF
           CH : (CH_VAL : CHAR);
           BOOL : (BOOL_VAL : BYTE);
        END;
VAR 
    BITS : BYTE;
    BLOCK: PACKED ARRAY[0..511] OF CHAR;
    K: INTEGER;
    DISK : XFILE;
    DUM : DUMMY;

BEGIN
  RESET(DISK,'*SYSTEM.MISCINFO');
  IF IORESULT = 0 THEN K := BLOCKREAD(DISK,BLOCK,1)
     ELSE WRITE('can''t find *SYSTEM.MISCINFO');
  CLOSE(DISK);
  IF K=1 THEN 
     BEGIN
       DUM.CH_VAL:=BLOCK[72];
       BITS:=DUM.BOOL_VAL;
       CRTINFO[LEADIN] := BLOCK[62];
       PREFIXED[LEADIN] := FALSE;
       CRTINFO[ERASEOS] := BLOCK[64];
       PREFIXED[ERASEOS] := BITS[3];
       CRTINFO[ERASEOL] := BLOCK[65];
       PREFIXED[ERASEOL] := BITS[2];
       CRTINFO[RIGHT] := BLOCK[66];
       PREFIXED[RIGHT] := BITS[1];
       CRTINFO[UP] := BLOCK[67];
       PREFIXED[UP] := BITS[0];
       CRTINFO[LEFT] := BLOCK[68];
       PREFIXED[LEFT] := BITS[5];
       CRTINFO[DOWN] := CHR(10);
       PREFIXED[DOWN] := FALSE;
    END;
END;


PROCEDURE CRT{C: CRTCOMMAND }; {adapted from Roger Soles version in the
                                  USUS library.  Call GETCRTINFO before
                                  using this procedure.}
BEGIN
  IF PREFIXED[C] THEN UNITWRITE(1,CRTINFO[LEADIN],1,0,12);
  UNITWRITE(1,CRTINFO[C],1,0,12);
END;



PROCEDURE IO_ERROR{( IORESLT         : INTEGER;
                    FILENAME        : STRING)};

type entry = record
   number : integer;
   message : packed array[0..21] of char;
end;

var buff : array[0..21] of entry;
    disk : xfile;
    k    : integer;
    
    
BEGIN
   IF IORESLT<>0 THEN
      BEGIN
         GOTOXY(0,22);
         WRITE(CHR(7));  
         WRITELN('I/O Error on ',FILENAME);
         reset(disk,'*errordata');
         k:=blockread(disk,buff,1);
         close(disk);
         write('ioresult = ',ioreslt);
         gotoxy(0,23);
         if k = 1 then
           for k:=1 to 20 do
              if ioreslt = buff[k].number then
                 unitwrite(1,buff[k].message,22,,1);
   END;  
END;  {io_error}
         
{*****************}

PROCEDURE BAD_IO{(VAR  FILEID           :XFILE;
                       FILENAME         :STRING;
                       IORESLT          :INTEGER;
                       RSET             :BOOLEAN;
                  VAR  IO_OK            :BOOLEAN)};

VAR CH      : CHAR;
    GOTFILE : BOOLEAN;

BEGIN
   IF IORESLT = 0 THEN IO_OK:=TRUE ELSE
      BEGIN
         GOTOXY(0,22);
         CRT(ERASEOS);
         IO_OK:=FALSE;
         IO_ERROR(IORESLT,FILENAME);
         GOTOXY(48,22);
         WRITE('type L)ock to close and exit or');
         GOTOXY(48,23);
         WRITE('<space> to ');
         IF RSET THEN WRITE('reset and ');
         WRITE('continue');
         READ(KEYBOARD,CH);
         IF (CH='L') OR (CH='l') THEN
            BEGIN
               CLOSE(FILEID,LOCK);
               EXIT(PROGRAM);
            END
         ELSE
            IF RSET THEN
               BEGIN
                  CLOSE(FILEID);
                  RESET(FILEID,FILENAME);
               END;
         GOTOXY(0,22);
         CRT(ERASEOS);
      END;
END;  {bad_i/o}
      

END.  {screenunit}



========================================================================================
DOCUMENT :usus Folder:VOL08:units.doc.text
========================================================================================

{This file describes three units which are extensively used in the other 
programs on this disk.  They are FILEUNIT, SCREENUNIT, and PRINTERUNIT.

     Unit FILEUNIT is a collection of procedures intended to aid in the error
free opening of files for input and output.  The procedures are very modular
so that use and modification of the unit is straight-forward.

     OPENDSKREAD and OPNDSKWRT are the most general procedures.  They act as
"one-liner" file openers in the calling program.  These procedures are the
normal entry point to this unit and they in turn call other procedures to
actually do the work.  The parameters they require are the fileid (type text
or file), a prompt string, and the x and y coordinates (type integer) where
the prompt string is to be displayed on the console.  They will return the
filename (type string) that was actually opened or a null string if no file
was opened.  OPNDSKWRT always opens a text file.  If you want any other kind
of file, then call REWRT_DISK directly.

     Procedure GETFILNAME is a routine which is called by OPNDSKREAD and
OPNDSKWRT. This procedure actually outputs the prompt and reads a filename.
It then calls REMOVE_SPACES to (naturally) remove any spaces.  It then calls
LEGALNAME to check for the occurance of any illegal characters. GETFILNAME
will continue to loop until LEGALNAME says that the filename is is legal in
its construction.  GETFILENAME then returns the legal filename to OPNDSKREAD
or OPNDSKWRT.  The boolean GOTNAME indicates a valid name. GETFILNAME will
allow the user to look through his directorys if desired.  To do this, it
calls DIR.

     Procedure LEGALNAME actually tries to reset the file and if the operating
system says that the name is legal (IORESULT=7), it exits.  If the name is not
legal the procedure IO_ERROR is called to display an error message at the
bottom of the screen and then it exits to GETFILNAME with a boolean variable
indicating whether or not the name was legal.  If the name was legal and the
file existed it is now open, so LEGALNAME closes the file so that later
procedures won't get confused. 

     Procedure LEGALUNIT checks for legal volume names.  It is used by DIR,
GET_FILE_DATE, and LEGALNAME.  This procedure prevents the possibility of 
reading from REMOUT: for example and causing the system to hang.  One 
exception is made.  The user is allowed to reference PRINTER: ( but not #6:) 
to allow the printer to be opened for output instead of a file.  You can, of 
course, use this loophole to intentally screw up the system, but I couldn't 
think of a better way to do it.

     Procedure IO_ERROR, in SCREENUNIT, simply displays an entry from the
table of I/O error messages which is found the UCSD System Users Guide.  It is
helpful in determining the actual cause of the error. If no error is indicated
when this procedure is called (IORESULT=0), then the procedure exits to the
caller with no action.  To save codefile space, the text of the messages are
contained in a structured file on disk instead of in-line in the procedure. 
While this method is slower, it is one block smaller in each program in which
FILEUNIT is used. The disk file is named ERRORDATA and if not present, the
value of IORESULT is displayed instead.  There are some extra error messages
and corresponding values of IORESULT in the file.  These are for additional
error messages than the UCSD system has because FILEUNIT is more picky about
characters in filenames than the system.  The new values of IORESULT start at
128 so that there will (probably) never be a conflict in the numbering.

     Procedures RESET_DISK and REWRT_DISK actually do the work of opening a
file. These procedures are declared to be global so that they may be called 
directly by the user in the case where a good filename is already known.

     RESET_DISK tries to reset the file with the filename as is and if
successful it exits with the value of ioresult.  If it is not successful it
calls ADD_TEXT to append '.TEXT' to the filename (only if it doesn't have a
'.TEXT' extension) and tries again.  If it is successful it leaves the file
open and exits with the new filename and the value of ioresult.  If the reset
fails a second time, it then exits with a non-zero ioresult.

     REWRT_DISK first tries to reset the file to see if it already exists and
if so it prompts the user to be sure that he really wants to rewrite an
existing file.  If the user says yes it goes ahead and rewites the file and
the previous file of the same name is forever lost. If the file to be
rewritten is not found it is then rewritten.  The variable REWROTE is then set
true to indicate that an attempt was made.  If any errors occur in rewriting
the file then the procedure exits with the value if ioresult.  OPNDSKWRT
detects the value of ioresult, calls IO_ERROR to disply a message and then
calls GETFILNAME to get another name. If the rewrite was successful then the
file is left open for use by the calling program and REWRT_DISK exits with the
filename actually opened and IORESLT=0. It is the users responsibility to
close and lock the file when he is through writing to it.

     An isolated procedure ,BAD_IO (also found in SCREENUNIT), exists which is
not used in the opening of files.  This procedure is used with the I/O
statements used in reading or writing files.  It receives as parameters the
fileid, the filename, a boolean (RSET), and IORESULT.  It passes back out the
boolean IO_OK to indicate if the value of IORESULT was zero or not.  If
IORESULT was non-zero it calls IO_ERROR to display the type of error and
prompt for a course of action.  The action taken depends on the value of
RSET.  If RSET is true the file can be reset to start over at the beginning. 
If RSET is false then the file will not be reset.  This allows the user who
has been keeping track of the exact blocks he has been accessing to restart at
the beginning of the block where the error occured.  If the user feels that
the error was fatal to his program he, can immediatly EXIT(PROGRAM).  This
procedure should be used in conjunction with I/O checking ( the (*$I-*) )
compiler option and a repeat loop around the read or write startment in
question.  For example, if a file was opened sucessfully and the user pulls
out the floppy before it has been completely read, this procedure will allow
the user to re-insert the disk and continue without a run- time error which
would normally bomb the program.  If the file was being written, and the user
elects to exit the program, BAD_IO closes his file with the LOCK option so
that whatever was already written is saved.  
     
     Procedure DIR will display the contents of a directory on one screen.
Only the filenames are shown as this procedure is intended to aid in the 
selection of a file to be opened by OPNDSKREAD and OPNDSKWRT.  The procedure
is a combination of Monaco's and Gagne's work on Volume 5 and a neat quicksort 
procedure taken from a SYBEX book by Alan Miller.

     Procedure GET_FILE_DATE will get the date of the last update of any file
on any disk.  You pass it the file name and it passes back the date and the
filename with the volume id of the volume prefixed.  If you pass it a string
variable containing a star(*), it will pass back the volume id of the root
volume and the current system date.  If you pass it the volume id of any other
volume or a non-existant filename, a null string will be returned for the
date. GET_FILE_DATE is declared to be global so that is can be called by the
user.

     Some degree of terminal independance is possible by the use of two 
procedures by Roger Soles.  These procedures, GETCRTINFO and CRT (found in 
SCREENUNIT), were taken from the unit UNIT.GOOD found on Volume 5 of the USUS
library.  If you have a standard size screen, no screen formatting changes
are required to the unit. SCREENUNIT must be compiled and available before
FILEUNIT is compiled. No attempt has been made to accomadate terminals with
screens smaller than 80 x 24.  Since many of the procedures write messages to
absolute screen positions, major surgery may be required to make the unit fit
a smaller-than-standard format.  GETCRTINFO has been slightly modified to 
allow the direct access to individual bits in a given byte.
        
     Note that the name, revision number, and date of last revision is in a
procedure called VER_FILEUNIT.  When this procedure is called, the version
number and last revision date are written to the screen, so that the unit can
identify itself.  This is also done in SCREENUNIT and PRINTERUNIT. If you
update the unit, remember to update the version and date.

     This unit is rather large.  You will find that it will make even the most
trivial program at least fourteen (count 'em 14) blocks long, but as the
saying goes, "there ain't no free lunch".  If you have any comments,
suggestions, or improvements concerning the unit, I would appreciate hearing
them.

     George Schreyer
     412 North Maria Ave.
     Redondo Beach, Ca.
     90277
     (213-376-9348)

     P.S.  This unit has been tested and works on version 4 of the UCSD 
system.  EXCEPT, you must add a dummy termination section to the SCREENUNIT as
shown

     BEGIN
     ***;
     END.

 or the EXIT(PROGRAM) in BAD_IO will do some mighty strange things.  I 
understand that this is a genuine bug and will be fixed.


========================================================================================
DOCUMENT :usus Folder:VOL08:volume.8.text
========================================================================================

                   DOCUMENTATION FOR VOLUME 8 -- USUS LIBRARY
                                 26 July 1981

     Here, at last, is a collection of software tools that I've been receiving
over the last year, since the inception of USUS.  These programs look good to
me, by and large, but I have by no means had the time to try them all.  So
this volume is a sort of "review volume" released to the membership at large. 
Please send bug reports to me AND to Keith Schillington, the Newsletter
editor, so that they can be published.  Simple bugs will be both published and
repaired on future disks--look at the date of a file if you have learned of a
bug and want to know if we've already fixed it.
              
     Note that some of the files have changed from those listed in the 
Newsletter, since I've rearranged things to accommodate George Schreyer's
latest versions of things.

     I'm including documentation from several sources below; my comments are
in brackets.

     Jim Gagne, Chairman, USUS Library
     Datamed Research, Inc.
     1433 Roscomare Road
     Los Angeles, CA 90024


                        SUBMISSIONS FROM GEORGE SCHREYER

LINECOUNT.....This a very fast linecounter.  It runs at about 600 lines per 
              second on my LSI-11. [George's wife Sandy uses LINECOUNT to 
              measure productivity in lines of code per day, by counting lines 
              on each file in a directory list stored in a textfile.  BUG: 
              don't allow LINECOUNT to clear the screen until you've had a 
              chance to read the answer.]
     
COPYBLOCKS....This copys a region on a disk to a file to allow for the recovery
              of a lost program.  I wrote it to recover a file which my wife
              lost by overwriting it with the version II editor.

RECOVER.......Recover searches each block of a volume to look for lost programs.
              It identifies each location where the lost program might still
              exist.  Copyblocks is then used to transfer those blocks to a
              file.
              [This is a very simple program that looks for the word "PROGRAM",
              all in caps, in the first block.  Suggestion: At least make it
              case-insensitive; you might also have it look for the structure
              of the segment tables in the first block of code files.]

CRMBLEV1.2....This one will break a file that is too large for the editor into
              smaller pieces.  I use it to processes programs which I have
              taken from other computers via INHALE.  It is slow but
              effective.

WRITERV7.2....A substantially reworked version of the original.  It uses
              blockreads and unitwrites and runs much faster.  I believe that
              this version is bullet-proof; try and see if you can make it blow
              up.

              The original version was found in the USUS library.  It will
              list your files with a banner page, which makes a listing easier
              to find in a pile of listings (and they do seem to pile up).  It
              will also list include files in-line if desired and number
              lines and pages.  It can optionally maintain a data file on your
              root volume with the latest date and a set of standard form
              parameters.  Version 7.2 will get the date from your system disk
              automatically.  If you choose to maintain a data file of form
              parameters the program will initialize one for you at the end of
              the first run.  Built in (but changable at run-time) defaults
              will be used for the first run.  The program has been tested
              with version IV.0 and it works fine, however because version IV
              does the actual unit linking at run-time, the time overhead of
              the system getting all the units together is excessive (as much
              as 15 secs with "high-performance" floppies and about 5 secs
              with a hard disk).

PERUSEV4.4....A faster version of peruse.  It will allow you to back up 44 lines
              at a time if you want.  It is also bullet-proof.

MODEMV2.2.....Basically the same as before but a little cleaner.  NOTE: this
              program depends upon UNITBUSY and thus runs only on the PDP-11
              systems.
              
UNITS.DOC.....Documentation for FILEUNIT.

FILEUNIT......This is a unit I wrote to allow error-free handling of files and
              general I/O.  It works very well and it is used in most of the
              other programs on this disk.  I believe that this does the same
              function as GETFILE in UNIT.GOOD [USUS Library, Volume 5 --see
              alse CRTINPUT in the save volume], but it is more general and
              does error checking and recovery for general I/O also.  This unit
              also containes reworked versions of DIR.TEXT and GETDATE.  DIR
              can be called from a user program and displays the filenames only
              in four columns.  GET_FILE_DATE can get the date from the system
              disk or the date of the last update of any file on any disk.  It
              also prefixes the filename with the actual volume id even if the
              id name is not supplied.

SCREENUNIT....This is just the procedures GETCRTINFO and CRT from UNIT.GOOD.
              
PRINTRUNIT....[I omitted this file to save room; it is called by some of
              George's other programs but does nothing but prevent his
              buffer from overflowing and is specific to PDP-11's.  Delete any
              references to the following procedures:
              
                   PROCEDURE VER_PRTUNIT;       {write a note of which version}
                   PROCEDURE INITPT;            {initialize the unit}
                   PROCEDURE WAIT_FOR_DC1;      {called when you've dumped some
                                                 text & are worried your buffer
                                                 may overflow}]

ERROR.DATA....This is a data file for Fileunit.  Its use is optional.

              I hope that you find these programs interesting. 
              
              Sincerely, 
              George W. Schreyer
     
P.S.  I received Version IV.0 and all of these programs have been tested with
              it.  Everything works as before, except much slower.  I have
              mixed feelings about the new version.  It is much easier to
              update programs which use units, but the run-time overhead is a
              killer.  I would hate to be strictly floppy bound.  It takes as
              much as 15 seconds to simply eX)ecute a program which uses a few
              units.  Further there doesn't seem to be any way to permanantly
              link in a unit to avoid the time lag.  Also, with all the system
              swapping, just using the system involves a lot of waiting, even
              with a hard disk!  Even the compiler runs about 30% slower.
              
              Also the system seems to die mysterious deaths after some
              segment errors and won't work properly until after a real hard
              boot.  I am sticking with version II until things improve
              considerably.

           
[NOTE: we discussed this on the phone; George's problem is that he's using 4
              units, each in a different file, causing a dozen file and
              directory accesses each time he runs just to find out where the
              units are he wants to load.  Solution: use the SYSTEM.LIBRARY
              for frequently used routines.]
              
           
                          PROGRAMS FROM STUART LYNN

ARCHIVER......this program will store a disk image in a file. This allows you
              to set up an Archive disk with several disk images, for backup
              purposes. It is most useful on large disks ( > 1000 blocks) when
              your directory space is used up before the data space. Before
              archiving a disk remove all extraneous files and krunch. To
              restore an archived disk image use the filer to transfer the file
              to a blank disk. ie.

                          T
                          Archive:Backup.dsk #4:
          
              where Archive is the name of the archive disk, and Backup was the
              name of the original disk.  [This program appears to have 
              something left out and won't compile as is, though I believe 
              what's missing is not essential.  Try it without the offending 
              statement and see; meanwhile watch the Newsletter.]

CHAIN.........this procedure will tell the operating system to start up
              another program when the currently running program is finished.
              See Chain.1 and Chain.2 for example of use.(Note: you have to
              have the source for the system globals for archiver,chainer and
              fast.seek/z80.seek)

FAST SEEK,
Z80.SEEK......these procedures are the same as the original UCSD intrinsics
              but are substantially faster. 
              
MULDIV.Z80....Z80 code for Z80.SEEK


                          PROGRAMS FROM DAVID MUNDIE

MAILER........is a substitute I propose for Frank's mailing list program.  It
              is along the same basic lines, but I think it is an improvement.
              For one thing, you don't have to worry about leaving space free
              after the file--I had a hard time making a disk-file to contain
              the output on Frank's program; the two files kept growing
              together.  It also allows selecting certain fields to be
              printed, eliminates the need for the key field, etc. etc.--I had
              already made most of the suggestions to you.  See MAILER.DOC.
              
LISP..........I am including even though I don't think it is fully debugged,
              just 'cause you mentioned it.  I haven't put the comments back
              in, so it wouldn't be very easy to follow without the NTIS
              listing.

DISKSORT......is my best effort at a reasonable sort program.  The QUICKSORT
              program on volume 5 disappointed me somewhat, since it is not a
              "disk" sort at all, at least as I understand the term.  Mine is
              based on Arbib and Alagic's algorithm (in The Design of Well-
              structured and Correct Programs, or whatever the name of their
              book is), and is, I think, a four-way balanced merge sort.  It
              expects a user-supplied file "raw.data", consisting of
              string[10]'s, up to 120 blocks' worth.  But the program is
              intended as a model only, and would be easy to change to handle
              other data structures and larger files.  I'm not an expert on
              disk sorts; if you get a better program, let me know.
              

                         SUBMISSIONS FROM BOB PETERSON
            Chairman, Communications SIG and the new USUS president
              
REM.UNIT......This is an implementation of the draft proposed standard UCSD
              system remote unit, of January 1981 (which was recently revised
              slightly and accepted by the Communications SIG as the standard
              interface for communications equipment).  Its purpose is to put
              all hardware-dependent features of interprocessor communications
              in one spot, and then to provide a standard interface to each
              system, so that communications software will work with any
              system.  See the newsletter for details on the relatively minor
              changes required to bring REM.UNIT up to the new standard.
              
REM.TERM......This is Bob's implementation of Teletalker; others are available
              from Volition Systems and Bowles' TeleSoftware.  Bob's program
              is hardware independent, because it relies on the REM.UNIT
              above.  It allows the UCSD system to act as a "dumb" remote
              terminal, as well as saving a part or all of a session in a text
              file, or sending a previously created text file.  Several
              options are noted in the text of the program.
              
              One issue never really resolved by any of the Teletalkers I've
              seen is that if you transmit many characters nonstop on
              Telemail, on occasion it hangs up briefly, and if you then keep
              sending characters, it dies.  This is especially a problem
              during system purge time (1AM to 6AM Eastern time), though it
              rarely happens at 300 baud.  The Bowles program counteracts the
              problem some by checking for echo character by character, and
              stopping the transmission if echo ceases.  This helps, but
              transmission rate suffers and the problem is still not solved.


                        MY ONE ADDITION TO THE LIBRARY
              
D.............Several people have sent in "updates" or "corrections" to DIR,
              the directory-listing program I wrote that was contained on
              Volume 5.  Frankly, I liked the original better than any of the
              modifications.  DIR did have several problems: the UNITREAD read
              in too many bytes (2048 rather than 2024, the actual size of the
              directory), causing this disk access to write over the program
              and crash or act weirdly.  Also, the simple sort I used takes up
              to six seconds to alphabetize the directory if it contains 77
              entries.  The way I listed files that did not fit on the first
              screenful was lousy, and I found that listing unused blocks on
              the bottom was not useful.  Finally, several people with Apples
              reformatted the prompts so that they would fit on their screens.
              
              D now addresses most of the above issues:  a) not only was the
              UNITREAD corrected, but (to allow BLOCKREAD, if you wish to read
              a directory by Volume ID) I extended the size of the buffer,
              which now holds four full blocks; b) D now uses a quicksort
              contributed by George Schreyer; c) files that do not fit on the
              screen are written cleanly at the bottom, separated from the
              previous page by a blank line, so that the maximum amount of
              material still appears on the screen; and d) I've improved the
              prompts somewhat for those with Apples with 40-column screens.
              An additional feature is that you can list files two ways:
              alphabetically (in 3 columns; Apple users convert to 4 if you
              wish), for searching for a file name, or in physical order on the
              disk, noting unused blocks in the areas where they appear, for
              disk space management.


                                   MISCELLANY
              
GLOBAL.II0
GLOBAL.III....II.0 and III.0 Globals, donated to the Library by SofTech
              Microsystems and both SofTech and Western Digital, respectively.
              For those who do not know the significance of GLOBALS, here is a
              brief note (though an article in the Newsletter is really
              required...any takers?):
              
              GLOBALS is the file included in the compilation of any UCSD
              system software, and is not a program but the declarations
              of the global operating system data types, variables, and
              procedures.  It allows you to access these features of the
              operating system directly.  So, for instance, if you know how,
              you can access memory-resident features such as terminal-driver
              characters, the system date, the name of the root and prefix
              volumes, the workfile, etc.
              
              However, there are many pitfalls in the use of GLOBALS.  First,
              they are subtly different in several UCSD releases (particularly
              II.1, III.0, and the variations of the UCSD system implemented
              by IBS, among others).  IV.0, in particular, bears NO
              relationship with the files here.  So programs that depend
              heavily upon GLOBALS are likely to perform poorly on various
              systems, unless they are recompiled with the correct version of
              GLOBALS.  Second, and more important to most of us, as a rule one
              must compile with the {$U-} compiler option set.  Again, one
              needs several pages of documentation to understand the many
              otherwise nondocumented exceptions to normal compiler operation
              that are called into force by compiling with {$U-}.
              
SCREEN........This is the Western Digital screen control unit, which may work 
              without modification on most other UCSD p-systems.  Don't fiddle 
              with it except to change the include file calls to just 
              GLOBAL.III, reflecting my condensation of the three files.
              

========================================================================================
DOCUMENT :usus Folder:VOL08:writerv7.2.text
========================================================================================

{$R-}
{$S+}
{$I-}
PROGRAM WRITER;
  
  USES (*$U SCREENUNIT.CODE*)SCREENUNIT,
       (*$U FILEUNIT.CODE*)FILEUNIT,
       (*$U PRINTRUNIT.CODE*) PRINTERUNIT;
  
  CONST VERSION = 'WRITER     version 7.2   18-Jul-81';

     {Program Writer will print your files in a pretty format among other
things. (See WRITER.DOC.TEXT for details)

     This version was modified from the Version 1.0 distributed by USUS.
Version 2.0 was done by Sandy Schreyer.  All subsequent versions were done by
George Schreyer.
 
     This program containes printer dependant code (for a TI 820 printer)
which can be found in procedures INITWRTPAGE, BANNER and WRAP_UP_WRTPAGE.  
 
     The procedures GETCRTINFO and CRT (from the USUS library, Volume 5) are
used to allow terminal independance, however the program assumes a 24 line by
80 column display so modifications will be necessary in various places for
smaller displays to prevent wrap-around or undesired scrolling.  The
procedures are found in the unit SCREENUNIT.

     The unit FILEUNIT is used to aid in the error-free opening and reading of
files.  I believe that the program is klutz-proof, and I dare you to make it
generate a run time error.

     This version containes machine dependant code, found only in PRINTRUNIT,
to sense the condition of the printer. The code was necessary because this
version of writer runs so fast that it overfills the buffer of my printer. The
earlier versions with READLN and WRITELN statements run at about 92 cps on an
LSI-11.  The new version runs at about 370 cps, a speed improvement of about a
factor of four. The extra speed makes this kludge is necessary to interface
the UCSD operating system to a serial printer.  If you don't have an pdp-11
type computer this patch won't work, just delete all references to PRINTRUNIT
and cross your fingers. If you have a parallel printer then this code is
totally unnecessary anyway.}
           
          
  
  TYPE BLOCK = FILE;
  
  VAR
    INP : FILE; {main file}
    INC : FILE;  {include files}
    FILENAME : STRING ; 
    Q:INTEGER;
    FORM_CHANGE : BOOLEAN;
    IO_OK: BOOLEAN;
    INP_NEXT_BLOCK : INTEGER;
    INC_NEXT_BLOCK : INTEGER;
    INLINE : CHAR;
    PR:TEXT;
    DISKA:TEXT;
    DATE : STRING ; 
    COPIES:INTEGER; 
    DOUBLESPACE : CHAR ;
    PAPERSIZE : INTEGER ;
    SEQUENCE:CHAR;
    LEFTMARGIN : INTEGER ;
    TOPMARGIN : INTEGER ;
    ENDLINES : INTEGER ;
    EXPANDED_PRINT : CHAR;
    NOTES : STRING;
    DISK_DATA : BOOLEAN;
    DATE_CHANGE : BOOLEAN;
    WRITERDATA : STRING;
    LPI : INTEGER;
    FILE_DATE : STRING;
    
{ * * * * * * * * * * }

PROCEDURE GETDATA;
 
 VAR REPLY :CHAR;
     COMMAND : CHAR;

PROCEDURE SHIFT_UP (VAR CH : CHAR);
BEGIN
  IF CH IN ['a'..'z'] THEN CH := CHR(ORD(CH)-32);
END;

PROCEDURE CARRYOUT ;
  
  VAR
    NEWDATE:STRING ;
    TEMP : INTEGER;
           

PROCEDURE SETMARGIN(VAR MARGIN:INTEGER);
   VAR TEMP:INTEGER;
   BEGIN
      TEMP:=MARGIN;
      READLN(MARGIN);
      IF (MARGIN < 1) OR (MARGIN > PAPERSIZE)  THEN MARGIN:=TEMP;
   END {setmargin};
     

  BEGIN    {carryout}
    CASE COMMAND OF
      'D' : BEGIN 
               WRITE ('date today? ' ) ; 
               READLN ( NEWDATE ) ; 
               IF NEWDATE <> '' THEN DATE := NEWDATE ;
               DATE_CHANGE:=TRUE;
            END ;
      'F' : BEGIN
               CLOSE(INP);
               OPNDSKREAD(INP,'file to write? - - >  ',FILENAME,5,15);
               CLOSE(INP);
               GET_FILE_DATE(FILENAME,FILE_DATE);
               IF (FILE_DATE = '') OR (LENGTH(FILENAME)=POS(':',FILENAME)) 
                  THEN FILENAME:='';
            END;
      'C' : BEGIN
               REPEAT
                  WRITE('# of copies? ');
                  READLN(COPIES);
                  IF COPIES < 1 THEN COPIES:=1;
               UNTIL IORESULT=0;
            END;
      'M' : BEGIN
              WRITELN('Banner message? (63 characters maximum)');
              READLN(NOTES);
              IF LENGTH(NOTES)>63 THEN
                BEGIN
                  DELETE(NOTES,64,(LENGTH(NOTES)-63));
                END;
            END;
      'L' : BEGIN
              WRITE('Left margin? ');
              SETMARGIN(LEFTMARGIN);
              IF LEFTMARGIN < 2 THEN LEFTMARGIN:=2;
              FORM_CHANGE:=TRUE;
            END;
      'Q' : EXIT(WRITER);
      'I' : BEGIN
              REPEAT
                WRITE('do you wish include files printed in-line? (Y/N) ');
                READ(INLINE);
                SHIFT_UP(INLINE);
                GOTOXY(0,0);
                CRT(ERASEOS);
              UNTIL INLINE IN ['Y','N'];
              FORM_CHANGE:=TRUE;
            END;
      'W' : BEGIN
              REPEAT
                 WRITE('Do you want E)xpanded, N)ormal or'
                       ,' C)ompressed print ? ');
                 READ(EXPANDED_PRINT);
                 SHIFT_UP(EXPANDED_PRINT);
                 GOTOXY(0,0);
                 CRT(ERASEOS);
              UNTIL EXPANDED_PRINT IN ['E','N','C'];
              FORM_CHANGE:=TRUE;
            END;
      'T' : BEGIN
               WRITE('Top margin? ');
               SETMARGIN(TOPMARGIN);
               FORM_CHANGE:=TRUE;
            END;
      'B' : BEGIN
              WRITE('Bottom margin? ');
              SETMARGIN(ENDLINES);
              FORM_CHANGE:=TRUE;
            END;
      'P' : BEGIN
              TEMP:=PAPERSIZE;
                 REPEAT
                    WRITE ( 'what is your papersize? ' ) ;
                    READLN (PAPERSIZE ) ; 
                 UNTIL IORESULT=0;
              FORM_CHANGE:=TRUE;
              IF (PAPERSIZE<1) OR (PAPERSIZE>66) THEN PAPERSIZE:=TEMP;
            END;
      'S' : BEGIN
              REPEAT
                 WRITE('do you want doublespaces (Y or N)? ');
                 READ(DOUBLESPACE);
                 SHIFT_UP(DOUBLESPACE);
              UNTIL DOUBLESPACE IN ['Y','N'];
              REPEAT
                 GOTOXY(0,0);
                 CRT(ERASEOS);
                 WRITE('do you want S)ix or E)ight lines per inch?');
                 READ(REPLY);
                 SHIFT_UP(REPLY);
              UNTIL REPLY IN ['S','E'];
              IF REPLY='E' THEN LPI:=8 ELSE LPI:=6;
              FORM_CHANGE:=TRUE;
            END;
      'N' : REPEAT
              WRITE('do you want line numbers (Y or N)? ');
              READ(SEQUENCE);
              SHIFT_UP(SEQUENCE);
              FORM_CHANGE:=TRUE;
            UNTIL (SEQUENCE='Y') OR (SEQUENCE='N');
    END { CASE } ;
  END { CARRYOUT } ;
     
PROCEDURE MENU;
   BEGIN
      WRITELN('WRITER: D(ate, F(ilename, C(opies, L(eft margin, T(op ',
                      'margin, B(ottom margin,');
      WRITELN('        P(apersize, S(pacing, print W(idth,', 
                      ' N(umbers, Q(uit, G(o,');
      WRITELN('        I(nclude files, banner M(essage');
      WRITELN;
      WRITELN('date: ',DATE); 
      WRITELN('left margin: ',LEFTMARGIN);
      WRITELN('top margin: ',TOPMARGIN);
      WRITELN('bottom margin: ',ENDLINES);
      WRITE('doublespaces: ');
      IF DOUBLESPACE = 'Y' THEN WRITELN('yes') ELSE WRITELN('no');
      WRITE('numbers: ');
      IF SEQUENCE = 'Y' THEN WRITELN('yes') ELSE WRITELN('no');
      WRITELN('papersize: ',PAPERSIZE);
      WRITELN('copies: ',COPIES);
      WRITE('print width: ');
      CASE EXPANDED_PRINT OF
        'n','N' : WRITELN('normal');
        'e','E' : WRITELN('expanded');
        'c','C' : WRITELN('compressed');
      END;
      WRITELN('lines per inch: ',LPI);
      WRITE('include files: ');
      IF INLINE = 'Y' THEN WRITELN('yes') ELSE WRITELN('no');
      WRITELN('banner message: ',NOTES);
      WRITE('filename: ',FILENAME);
      IF FILENAME <> '' THEN WRITELN(' dated ',FILE_DATE) ELSE WRITELN;
   END;  {menu}
      
 BEGIN   {getdata}
    RESET(INP,FILENAME);
    IF IORESULT <> 0 THEN OPNDSKREAD(INP,'file to write? - - - > '
          ,FILENAME,0,15);
    CLOSE(INP);
    IF FILENAME = '' THEN EXIT(PROGRAM);
    GET_FILE_DATE(FILENAME,FILE_DATE);
    IF (FILE_DATE = '') OR (LENGTH(FILENAME)=POS(':',FILENAME)) THEN 
    FILENAME :='';
    GOTOXY(0,0);
    CRT(ERASEOS);
    REPEAT
      IF FILENAME = '' THEN WRITELN(CHR(7),'No file') ELSE WRITELN;
      WRITELN;
      MENU;
      WRITELN;
      WRITE('Command ? ');
      READ(COMMAND);
      SHIFT_UP(COMMAND);
      GOTOXY(0,0);
      CRT(ERASEOS);
      CARRYOUT;
      GOTOXY(0,0);
      CRT(ERASEOS);
    UNTIL (COMMAND IN ['G','g']) AND (FILENAME <> '');
    IF DISK_DATA THEN
       BEGIN
          IF FORM_CHANGE THEN
             BEGIN
                GOTOXY(0,0);
                CRT(ERASEOS);
                GOTOXY(0,12);
                WRITE('Do you wish to make form changes permanent? (Y/N)');
                READ(REPLY);
                GOTOXY(0,0);
                CRT(ERASEOS);
                IF REPLY <> 'Y' THEN FORM_CHANGE:=FALSE;
             END;
       END;
   CLOSE(INP);
END {getdata};

{ * * * * * * * * * * }

PROCEDURE INITIALIZE ;
  VAR T1:INTEGER; 
     
PROCEDURE SETVARS ;
  VAR STAR : STRING;
  
  BEGIN  {setvars}
    STAR:='*';
    LPI:=6;
    DATE:=' ';
    LEFTMARGIN := 10 ;
    TOPMARGIN:=4;
    ENDLINES:=4;
    DOUBLESPACE:='N';
    SEQUENCE:='Y';
    PAPERSIZE:=51;
    COPIES:=1;
    INLINE:='N';
    EXPANDED_PRINT:='N';
    FILENAME:='*SYSTEM.WRK.TEXT';
    IF DISK_DATA THEN
       BEGIN
          RESET(DISKA,WRITERDATA);
          IF IORESULT=0 THEN
             BEGIN
                READLN(DISKA,DATE);
                READLN(DISKA,LEFTMARGIN);
                READLN(DISKA,EXPANDED_PRINT);
                READLN(DISKA,LPI);
                READLN(DISKA,TOPMARGIN);
                READLN(DISKA,ENDLINES);
                READLN(DISKA,PAPERSIZE);
                READLN(DISKA,DOUBLESPACE);
                READLN(DISKA,INLINE);
                READLN(DISKA,SEQUENCE);
             END;
           CLOSE(DISKA);
        END;
    GET_FILE_DATE(STAR,DATE);
END {SETVARS};
  
  
  BEGIN   {initialize}
    GETCRTINFO;
    DISK_DATA:=TRUE;
    FILE_DATE:='';
    WRITERDATA:='*WRITERDATA';
    DATE_CHANGE:=FALSE;
    NOTES:='';
    FORM_CHANGE:=FALSE;
    GOTOXY(0,0);
    CRT(ERASEOS);
    WRITELN;
    FOR T1:=1 TO 79 DO WRITE('*');
    WRITELN ;
    WRITELN ;
    WRITELN ( '                  WELCOME TO ',VERSION  ) ;
    WRITELN ;
    FOR T1:=1 TO 79 DO WRITE('*');
    WRITELN;
    VER_SCREENUNIT;
    VER_FILEUNIT;
    VER_PRTUNIT;
    UNITCLEAR(6);
    IF IORESULT <> 0 THEN 
       BEGIN
          WRITELN;
          WRITE('printer not on-line at port #6');
          EXIT(PROGRAM);
       END;
    REWRITE(PR,'PRINTER:');
    INITPT;
    WAIT_FOR_DC1;
    SETVARS;
 END    {initialize};
        
PROCEDURE WRITE_DATA;

   VAR TEMP_STR : STRING;
   
   BEGIN
      IF DISK_DATA THEN
        BEGIN
           TEMP_STR:=DATE;
           IF NOT FORM_CHANGE THEN
              BEGIN
                 RESET(DISKA,WRITERDATA);
                 IF IORESULT=0 THEN 
                    BEGIN
                         READLN(DISKA,DATE);
                         READLN(DISKA,LEFTMARGIN);
                         READLN(DISKA,EXPANDED_PRINT);
                         READLN(DISKA,LPI);
                         READLN(DISKA,TOPMARGIN);
                         READLN(DISKA,ENDLINES);
                         READLN(DISKA,PAPERSIZE);
                         READLN(DISKA,DOUBLESPACE);
                         READLN(DISKA,INLINE);
                         READLN(DISKA,SEQUENCE);
                      END;
                  CLOSE(DISKA);
              END;
           DATE:=TEMP_STR;
           IF DATE_CHANGE OR FORM_CHANGE THEN
              BEGIN
                  REWRITE(DISKA,WRITERDATA);
                  IF IORESULT = 0 THEN
                     BEGIN
                       WRITELN(DISKA,DATE);
                       WRITELN(DISKA,LEFTMARGIN);
                       WRITELN(DISKA,EXPANDED_PRINT);
                       WRITELN(DISKA,LPI);
                       WRITELN(DISKA,TOPMARGIN);
                       WRITELN(DISKA,ENDLINES);
                       WRITELN(DISKA,PAPERSIZE);
                       WRITELN(DISKA,DOUBLESPACE);
                       WRITELN(DISKA,INLINE);
                       WRITELN(DISKA,SEQUENCE);
                     END;
               END;
            CLOSE(DISKA,LOCK);
       END;
END;   {write_data}

PROCEDURE WRTPAGE;
   
VAR
    LINE:PACKED ARRAY[0..132] OF CHAR;
    DATAI,DATA: PACKED ARRAY[0..511] OF CHAR;
    S,PAGE_SIZE : INTEGER;
    K,N,J,MARGINLINES : INTEGER ;
    LINECNT:INTEGER;
    PAGENUMBER : INTEGER ;
    INC_NAME : STRING;
    MARGINSPACES : INTEGER ;
    LINESLEFT : INTEGER;
    INCLUDE : BOOLEAN;
    BLANK_STRING : STRING;
   

PROCEDURE INITWRTPAGE;

PROCEDURE BANNER;
   
   VAR I : INTEGER;
   
   BEGIN
      BLANK_STRING:='                                       ';
      WRITE(PR,CHR(27),'PA\');  {sets 6 lpi}
      PAGE(PR);
      WRITE(PR,CHR(27),'PI',CHR(27),'\');  {set 5 cpi}
      FOR I:= 1 TO 5 DO WRITE(PR,CHR(10));
      WRITELN(PR,BLANK_STRING:10,FILENAME);
      WRITELN(PR);
      WRITELN(PR,BLANK_STRING:10,'listing date is ',DATE);
      WRITELN(PR);
      WRITELN(PR,BLANK_STRING:10,'last updated on ',FILE_DATE);
      WRITELN(PR);
      IF LENGTH(NOTES)>44 THEN 
           WRITELN(PR,CHR(27),'PD\',BLANK_STRING:33,CHR(27),
              'PJ',CHR(27),'\',NOTES)
             {sets 16.5 cpi, moves 33 spaces, then sets 8.25 cpi}
      ELSE WRITELN(PR,BLANK_STRING:10,NOTES);
      WRITE(PR,CHR(27),'PC\');  {sets 10 cpi}
   END;   {banner}

BEGIN   {initwtrpage}
   INCLUDE:=FALSE;
   PAGE_SIZE:=PAPERSIZE-ENDLINES-TOPMARGIN-2;
   IF LPI=8 THEN PAGE_SIZE:=(4*PAGE_SIZE) DIV 3;
   IF DOUBLE_SPACE = 'Y' THEN PAGE_SIZE:=PAGE_SIZE DIV 2;
   WRITELN;
   WRITE ( 'printing ... ',FILENAME ) ;
   WRITE(PR,CHR(27),CHR(91),CHR(49),CHR(59),PAPERSIZE,CHR(114));
      {this mess sets the top margin a line 1 if it isn't there already}
      {and sets bottom margin to papersize}
   BANNER;
   CASE EXPANDED_PRINT OF
      'E' : WRITE(PR,CHR(27),'PJ',CHR(27),'\'); {sets 8.5 cpi}
      'N' : WRITE(PR,CHR(27),'PC\');            {sets 10 cpi}
      'C' : WRITE(PR,CHR(27),'PD\')             {sets 16.5 cpi}
      END;
   IF LPI=8 THEN WRITE(PR,CHR(27),'PH',CHR(27),'\'); {sets 8 lpi}
   WRITELN;
END;    {initwrtpage}
  
PROCEDURE SKIP_HEADER(VAR SOURCE     : BLOCK;
                          FILENAME   : STRING;
                      VAR NEXT_BLOCK : INTEGER);
  BEGIN
     IF POS('.TEXT',FILENAME) <> 0 THEN NEXT_BLOCK:=2 
     ELSE NEXT_BLOCK:=0; 
  END;  {skip_header}
        
        
PROCEDURE WRAP_UP_WRTPAGE;
BEGIN
    CLOSE(INP);
    WRITE(PR,CHR(27),'PA\');  {sets 6 lpi}
    WRITE(PR,CHR(27),'PC\');  {resets printer to 10 cpi}
    WRITE(PR,CHR(27),CHR(91),CHR(52),CHR(59),PAPERSIZE-4,CHR(114));
   {resets margins to top=4, bottom=papersize-4 in case Writer isn't used next}
END;   {wrap_up_wrtpage}

PROCEDURE NUMBERS;

VAR SPACE : PACKED ARRAY[0..1] OF CHAR;
        Z : INTEGER;


   BEGIN
     SPACE[0]:=CHR(32);
     Z:=LEFTMARGIN+4;
     IF SEQUENCE = 'Y' THEN
        BEGIN
           Z:=Z-4;
           LINECNT:=LINECNT+1;
           WRITE(PR,LINECNT:4);
           IF INCLUDE AND (INLINE='Y') THEN 
              BEGIN
                 Z:=Z-1;
                 WRITE(PR,'+');
              END;
        END;
     FOR K:=1 TO Z DO UNITWRITE(6,SPACE[0],1,,1);
   END;   {numbers}

PROCEDURE NEWPAGE;
   BEGIN
     LINESLEFT := PAGE_SIZE;
     WAIT_FOR_DC1;
     PAGE(PR);
     PAGENUMBER := PAGENUMBER + 1 ;
     FOR MARGINLINES:=1 TO TOPMARGIN DO WRITELN(PR);
     WRITELN(PR,FILENAME:25,'-':3,PAGENUMBER,'-   listing date '
             ,DATE,'   last updated ',FILE_DATE);
     WRITELN(PR);
  END;   {newpage}
            
PROCEDURE PRINT_A_LINE ;

VAR Q : INTEGER;

PROCEDURE GET_INCLUDE;

VAR NAME : PACKED ARRAY[0..24] OF CHAR;
    X,R : INTEGER;
    GOTFILE:BOOLEAN;
    IORESLT : INTEGER;
    STR : STRING;
    INC_DATE : STRING;
    
BEGIN
   R:=0;
   STR:=' ';
   INC_NAME:='';
   REPEAT
      NAME[R]:=LINE[Q+5+R];
      R:=SUCC(R);
   UNTIL NAME[R-1] = '*';
   FOR X:=0 TO R-2 DO
      BEGIN
         STR[1]:=NAME[X];
         INC_NAME:=CONCAT(INC_NAME,STR);
      END;
   REPEAT
      CLOSE(INC);
      RESET_DISK(INC,INC_NAME,IORESLT);
      BAD_IO(INC,INC_NAME,IORESLT,TRUE,IO_OK);
   UNTIL IO_OK;
   SKIP_HEADER(INC,INC_NAME,INC_NEXT_BLOCK);
   INCLUDE:=TRUE;
   WRITELN;
   WRITELN('printing ... ',INC_NAME);
   GET_FILE_DATE(INC_NAME,INC_DATE);
   WAIT_FOR_DC1;
   IF DOUBLE_SPACE = 'Y' THEN WRITELN(PR);
   WRITELN(PR,BLANK_STRING:LEFTMARGIN+4,INC_NAME,
           ' last updated on ',INC_DATE);
   LINESLEFT:=LINESLEFT-1;
END;   {get_include}
            
BEGIN   {print_a_line} 
   WAIT_FOR_DC1;
   NUMBERS;
   FOR Q:=0 TO S-1 DO IF LINE[Q] <> CHR(12) THEN UNITWRITE(6,LINE[Q],1,,1);
   S:=0;
   FOR Q:=0 TO 3 DO
      BEGIN
         IF (LINE[Q+0] = '(') AND
            (LINE[Q+1] = '*') AND
            (LINE[Q+2] = '$') THEN
               BEGIN
                  IF (LINE[Q+3] = 'I') AND
                     (LINE[Q+4] <> '-') AND
                     (LINE[Q+4] <> '+') 
                  THEN IF (NOT INCLUDE) AND (INLINE = 'Y') THEN GET_INCLUDE;
                  IF LINE[Q+3] = 'P' THEN NEWPAGE;
               END
       END;
   IF LINESLEFT = 1 THEN NEWPAGE
   ELSE
      BEGIN 
         IF DOUBLESPACE = 'Y' THEN WRITELN (PR) ;
         LINESLEFT := LINESLEFT - 1 ;
      END;
END;    {print_a_line}
      
  
BEGIN   {wrtpage}
  INITWRTPAGE;
     REPEAT
        RESET(INP,FILENAME);
        BAD_IO(INP,FILENAME,IORESULT,FALSE,IO_OK);
     UNTIL IO_OK;
  SKIP_HEADER(INP,FILENAME,INP_NEXT_BLOCK);
  PAGENUMBER := 0 ;
  LINECNT:=0;
  S:=0;
  NEWPAGE;
  WHILE NOT EOF (INP) DO
     BEGIN
        J:=0;
           REPEAT
              K:=BLOCKREAD(INP,DATA,1,INP_NEXT_BLOCK);
              BAD_IO(INP,FILENAME,IORESULT,FALSE,IO_OK);
           UNTIL IO_OK;
        INP_NEXT_BLOCK:=SUCC(INP_NEXT_BLOCK);
        WHILE J < 512 DO
           BEGIN 
              IF NOT INCLUDE THEN 
                 BEGIN
                    IF DATA[J] <> CHR(0) THEN
                       BEGIN
                          LINE[S]:=DATA[J];
                          S:=SUCC(S);
                       END;
                    IF DATA[J] = CHR(13) THEN PRINT_A_LINE;
                    J:=SUCC(J);
                 END
              ELSE
                 BEGIN
                    WHILE NOT EOF(INC) DO
                       BEGIN
                          N:=0;
                          REPEAT
                             K:=BLOCKREAD(INC,DATAI,1,INC_NEXT_BLOCK);
                             BAD_IO(INC,INC_NAME,IORESULT,FALSE,IO_OK);
                          UNTIL IO_OK;
                          INC_NEXT_BLOCK := SUCC(INC_NEXT_BLOCK);
                          WHILE N < 512 DO 
                             BEGIN
                                IF DATAI[N] <> CHR(0) THEN
                                   BEGIN
                                      LINE[S]:=DATAI[N];
                                      S:=SUCC(S);
                                   END;
                                IF DATAI[N] = CHR(13) THEN PRINT_A_LINE;
                                N:=SUCC(N);
                             END;
                       END;
                    CLOSE(INC);
                    INCLUDE:=FALSE;
                    WRITELN;
                    WRITELN('printing ... ',FILENAME);
                 END;
            END;
      END;
   WRAP_UP_WRTPAGE;
END; { wrtpage } 

BEGIN   {writer}
  INITIALIZE;
  GETDATA;
  FOR Q:=1 TO COPIES DO WRTPAGE;  
  WRITE_DATA; 
END.


========================================================================================
DOCUMENT :usus Folder:VOL09:adv.doc.text
========================================================================================

                      ADVENTURE.

The history of this version of adventure has been lost, and I am
unable to credit the originator. This program was converted
to UCSD Pascal from a PL/1 version found on our local computer
system. This version was obviously converted from a Fortran
version (it said so in the comments) but any history was not
indicated. If you need assistance with this program, you can
write me. My address is:

          Michael R. Turner
          1622 Colonial Way
          Frederick Md. 21701
          (301)-663-9181


GETTING STARTED.

The steps required to run adventure are:

1). Compile ADVINIT.TEXT. File needed is:
        ADVINIT.TEXT

2). Compile ADV.TEXT. Files needed are:
        ADV.TEXT
        ADVSUBS.TEXT
        ADVVERB.TEXT

3). Run ADVINIT to build the required files for Adventure.
    Files needed are:
        ADVS1.TEXT
        ADVS2.TEXT
        ADVS3.TEXT
        ADVS4.TEXT
        ADVS5.TEXT
        ADVS6.TEXT
        ADVS7.TEXT
        ADVS8.TEXT
        ADVS9.TEXT
        ADVS10.TEXT
        ADVS11.TEXT
        ADVINIT.CODE
    There are two output files produced by ADVINIT:
        ADVMSGS[79]
        ADVDATA[23]
    Insure that there are at least 102 free contiguous blocks 
    on the prefix disk. ADVINIT creates the msg file completely
    before opening the data file. That way ADVINIT will work ok
    if exactly 102 free blocks are available.

4). Build an ADV.MISCINFO file. This is nothing more than a
    text file with two numbers in it.The format is HEIGHT WIDTH.
    (eg. 24 80) If you are an APPLE user using the 24x40
    screen, this is not necessary (see Notes, below).

5). The only files needed to run adventure are:
         ADVDATA
         ADVMSGS
         ADV.CODE
    Move these files to an appropriate disk if necessary.

6). Be prepared to spend hours exploring the cave. Try not to
    look at the source or the messages until all of adventuredom
    pays tribute to you, Oh Grand Master Adventurer!
    
Notes:
    
    There is a save game feature. Try SAVE. You might like it.
    The program asks for your name, but any identifier can be
    used as long as it is valid for a filename.  Each save
    file requires 6 blocks.
    
    The system clock is used to initialize the random number
    generator. If the value returned by the TIME function
    is zero, then the user is prompted for a number to start
    the random number generator.
    
    The system MISCINFO is not used because the APPLE sets the
    screen width to 80 on the 40 char screen. Flipping side to
    side may be OK during editing, but not during ADVenture.
    Also, The program defaults are such that APPLE users do
    not need an ADV.MISCINFO.
    
    ADV.TEXT has {$S+} to allow it to compile on most machines.


==============================================================
PROGRAM-SECTION.

ADV.TEXT............The adventure program.
ADVSUBS.TEXT........Include file of adventure program.
ADVVERB.TEXT........        ""
ADVINIT.TEXT.......Initialization program. This program reads
          ADVS1 through ADVS11 and produces ADVDATA and
          ADVMSGS. These files must be on the default disk
          in order to run the adventure program.

==============================================================
DATA-FILES-SECTION.

ADV.MISCINFO........Sample miscinfo for adventure.

ASVS1.TEXT..........Long form descriptions.

          Each line contains a location number, a space, and
          a line of text. The set of adjacent lines whose numbers
          are X form the long description of location X.
          
ADVS2.TEXT..........Short form descriptions.

          Same format as ADVS1.TEXT.  Not all places have
          short descriptions.
          
ADVS3.TEXT..........Travel Table.

          Each line contains a location number (X), a condition
          value (M), a second location number (N), and a list
          of motion numbers from ADVS4.TEXT.
          Each motion represents a verb which will take you to N
          if you are at X. M and N are interpreted as follows:
          
              If N<=300     location to go to.
              If 300<N<=500 N-300 is used to select special code
              If N>500      Message N-500 is to be issued.
              
          Meanwhile, M specifies the condition of motion.
          
              If M=0        Unconditional.
              If 0<M<100    M% probability of motion.
              If M=100      Unconditional but forbidden to dwarves.
              If 100<M<=200 Must be carrying object M-100.
              If 200<M<=300 Must be carrying or be in
                            the same room as M-200.
              If 300<M<=400 Property of (M MOD 100) must <> 0.
              If 400<M<=500 Property of (M MOD 100) must <> 1.
              If 500<M<=600 Property of (M MOD 100) must <> 2.
                            Etc.
          
          If the condition is not met, then the next *DIFFERENT*
          'destination' value is used (Unless it fails to meet
          *ITS* conditions, in which case the next is found, etc).
          Typically, the next destination will be for one of the
          same verbs, so that its only use is as the alternate
          destination for those verbs. For instance:
          
               15   110   22  29 31 34 35 23 43
               15     0   14  45
               
          says that from location 15, any of the verbs (29,31,...,43)
          will take you to 22 if you are carrying object 10.
          Otherwise, they or verb 45 will take you to location 14.
          
               11  303    8  49
               11    0    9  50
               
          says that from 11, 49 takes him to 8 unless the PROP(3)=0.
          In that case, 49 takes you to 9. Verb 50 always takes
          you to 9.
          
ADVS4.TEXT..........Vocabulary

          Each line contains a number and a five letter word.
          Let M=N DIV 1000.
          
          If M=0.  The word is a motion verb used in ADVS3.TEXT.
          If M=1.  The word is an object.
          If M=2.  The word is an action word (eg ATTACK).
          If M=3.  Special case word. N MOD 1000 is an index
                   into ADVS6.TEXT messages.
                   
ADVS5.TEXT..........Object descriptions.

          Each line contains a number and a message. If 1<=N<=100,
          it is the 'INVENTORY' message for object N. Otherwise
          N should be 000,100,200 etc and the message is the
          description of the preceding object when its property
          value is N DIV 100. The N DIV 100 is used to destinguish
          from multiple messages from multi-line messages. 
          Properties that produce no message must be given
          a null message.

ADVS6.TEXT..........Miscellaneous messages.

          Same format as ADVS1,ADVS2 and ADVS5, except that
          the numbers are not related to anything. (Except
          for special verbs in ADVS4).

ADVS7.TEXT..........Object locations.

           Each line contains an object number and its initial
           location (zero if none) and a second location (also
           zero if none). If the object is immovable, the
           second location is set to -1. If the object has two
           locations (eg GRATE), the second location field is set
           to the second location and is assumed to be immovable.
           
ADVS8.TEXT..........Action defaults.

           Each line contains an 'ACTION-VERB' number and the
           index (into ADVS6) of the default message for the
           verb.
           
ADVS9.TEXT..........Liquid Assetts, etc.
           
           Each line contains a number (N) and up to 20 location
           numbers. Bit N (where 0 is the units bit) is set
           in COND(LOC) for each loc given. The bits currently
           assigned are:
           
               0   Light
               1   If bit 2 is on; 1=oil,0=water.
               2   Liquid asset, set bit 1.
               3   Pirate doesn't go here unless following
                   player.
           The other bits are used to indicate areas of interest
           to the hint routines:
               4   Trying to get into the cave.
               5   Trying to catch the bird.
               6   Trying to deal with the snake.
               7   Lost in maze.
               8   Pondering the dark room.
               9   At witts end.
           COND(LOC) is set to 2, overriding all other bits,
           if LOC has forced motion.
           
ADVS10.TEXT.........Player class messages.

           Each line contains a number N and a message describing
           the classification of the player. The scoring section
           selects the appropriate message. A message applies
           to a players whose scores are higher than the previous
           N but not higher than this N.
           
ADVS11.TEXT.........Hints.

           Each line contains a hint number corresponding to
           the COND(LOC) bits (see ADVS9), the number of turns
           he must be at the right LOC(s) before triggering
           the hint, the points deducted for the hint, the
           message number of the question (from ADVS6) and
           the message number of the hint (also from ADVS6).
           Hint numbers 1-3 are no usable as the COND(LOC)
           bits 1-3 are otherwise assigned.
           

========================================================================================
DOCUMENT :usus Folder:VOL09:adv.miscinfo
========================================================================================

16 64
FIRST NUMBER IS HEIGHT
SECOND IS       WIDTH


========================================================================================
DOCUMENT :usus Folder:VOL09:adv.text
========================================================================================

{$S+}
PROGRAM ADVENTURE;
CONST
  VERSION = 5;
  KEYS = 1;
  LAMP = 2;
  GRATE = 3;
  CAGE = 4;
  ROD = 5;
  ROD2 = 6;
  STEPS = 7;
  BIRD = 8;
  DOOR = 9;
  PILLOW = 10;
  SNAKE = 11;
  FISSURE = 12;
  TABLET = 13;
  CLAM = 14;
  OYSTER = 15;
  MAGAZINE = 16;
  DWARF = 17;
  KNIFE = 18;
  FOOD = 19;
  BOTTLE = 20;
  WATER = 21;
  OIL = 22;
  PLANT = 24;
  PLANT2 = 25;
  AXE = 28;
  MIRROR = 23;
  DRAGON = 31;
  CHASM = 32;
  TROLL = 33;
  TROLL2 = 34;
  BEAR = 35;
  MESSAGE = 36;
  VEND_MACHINE = 38;
  BATTERY = 39;
  NUGGET = 50;
  COINS = 54;
  CHEST = 55;
  EGGS = 56;
  TRIDENT = 57;
  VASE =58;
  EMERALD = 59;
  PYRAMID = 60;
  PEARL = 61;
  RUG = 62;
  CHAIN = 64;
  SPICES = 63;
  CAVE = 67;
  BACK = 8;
  LOOK = 57;
  NULL = 21;
  ENTRANCE = 64;
  DEPRESSION = 63;
  SAY = 3;
  LOCK = 6;
  THROW = 17;
  FIND = 19;
  INVENTORY = 20;
  MAXTRS = 64;
  MAXDIE = 3;
  MAXHLD = 6;
  DALTLC = 18;
TYPE
  CH512 = PACKED ARRAY[1..512] OF CHAR;
  CHAR6 = PACKED ARRAY[1..6] OF CHAR;
  ARYS = RECORD
    CASE BOOLEAN OF
      FALSE : (DBLK : CH512);
      TRUE  : (TRAVEL : ARRAY[1..750] OF INTEGER;
               TRAVEL2 : ARRAY[1..750] OF INTEGER;
               TRAVEL3 : ARRAY[1..750] OF INTEGER;
               ATAB : ARRAY[1..300] OF STRING[5];
               KTAB : ARRAY[1..300] OF INTEGER;
               LTEXT : ARRAY[1..150] OF INTEGER;
               STEXT : ARRAY[1..150] OF INTEGER;
               KEY : ARRAY[1..150] OF INTEGER;
               PLAC : ARRAY[1..100] OF INTEGER;
               FIXD : ARRAY[1..100] OF INTEGER;
               PTEXT : ARRAY[1..100] OF INTEGER;
               ACTSPK : ARRAY[1..35] OF INTEGER;
               RTEXT : ARRAY[1..205] OF INTEGER;
               CTEXT : ARRAY[1..12] OF INTEGER;
               CVAL : ARRAY[1..12] OF INTEGER;
               HINTS : ARRAY[1..20,1..4] OF INTEGER)
  END;
  VARYS = RECORD
    CASE BOOLEAN OF
      FALSE : (DBLK : CH512);
      TRUE  : (COND : ARRAY[1..150] OF INTEGER;
               ABB : ARRAY[1..150] OF INTEGER;
               ATLOC : ARRAY[1..150] OF INTEGER;
               PLACE : ARRAY[1..100] OF INTEGER;
               FIXED : ARRAY[1..100] OF INTEGER;
               LINK : ARRAY[1..200] OF INTEGER;
               PROP : ARRAY[1..100] OF INTEGER;
               HINTLC : ARRAY[1..20] OF INTEGER;
               HINTED : ARRAY[1..20] OF BOOLEAN;
               DSEEN : ARRAY[1..6] OF BOOLEAN;
               DLOC : ARRAY[1..6] OF INTEGER;
               ODLOC : ARRAY[1..6] OF INTEGER;
               TK : ARRAY[1..20] OF INTEGER)
  END;
  VBLS = RECORD
    CASE BOOLEAN OF
      FALSE : (DBLK : CH512);
      TRUE  : (HLDING,LOC,OLDLOC : INTEGER;
               OLDLC2,CLOCK1,CLOCK2 : INTEGER;
               CHLOC,CHLOC2,TALLY,TALLY2 : INTEGER;
               DFLAG,DTOTAL,FOOBAR,TURNS : INTEGER;
               VERB,OBJ,LIMIT,IWEST,KNFLOC : INTEGER;
               ABBNUM,DKILL,NUMDIE,DETAIL : INTEGER;
               PANIC,CLOSING,CLOSED,WZDARK : BOOLEAN;
               VERSION : INTEGER;
               PASSWORD : STRING[20])
  END;
VAR
  NEWLOC,RESTART,I,J,K,KK,K2 : INTEGER;
  MAXSCORE,TVCOND,ATTACK,STICK : INTEGER;
  FOO,SCORE,HINT,SPK : INTEGER;
  BONUS,SEED : INTEGER;
  RESUME,OK,SKIPIT,STEAL : BOOLEAN;
  GAVEUP,YEA,SKIPDWARF,ALLDONE,HE_DIED,PIT : BOOLEAN;
  NEWLOCSET,LMWARN,SKIPDESCRIBE : BOOLEAN;
  HNTSIZ,CLSSES : INTEGER;
  ARY : ^ARYS;
  VARY : ^VARYS;
  VBL : ^VBLS;
  LINE,TERMWIDTH,TERMHIGHT : INTEGER;
  KKWORD,WD1,WD2 : STRING[5];
  WD1X,WD2X : STRING;
  ACHAR : STRING[1];
  TESTPW : STRING[20];
  NAMEOFUSER : STRING[40];
  INFILE : FILE;
  MSGFILE : FILE OF CHAR6;
PROCEDURE READINIT(VAR BFR:CH512;NUM:INTEGER);
BEGIN { READINIT }
  NUM:=(NUM+511) DIV 512;
  IF NUM<>BLOCKREAD(INFILE,BFR,NUM) THEN
  BEGIN
    WRITE('ERROR READING ARRAY FILE');
    EXIT(ADVENTURE);
  END;
END;  { READINIT }
PROCEDURE INITIALIZE;
VAR
  I,J,K,X : INTEGER;
  ININFO : TEXT;
PROCEDURE INITP2;
VAR
  I,J : INTEGER;
BEGIN { INITP2}
  TIME(I,J);
  IF J=0 THEN
    J:=I;
  WHILE J=0 DO
  BEGIN
    WRITELN('NO CLOCK.');
    WRITELN('PLEASE ENTER A NUMBER FROM 1 TO 32767 ');
    READ(J);
    WRITELN;
  END;
  IF (J MOD 2)=0 THEN
    J:=J+1;
  SEED:=J;
  LINE:=1;
  VARY^.DLOC[1]:=19;
  VARY^.DLOC[2]:=27;
  VARY^.DLOC[3]:=33;
  VARY^.DLOC[4]:=44;
  VARY^.DLOC[5]:=64;
  VARY^.DLOC[6]:=114;
  VBL^.CHLOC:=114;
  VBL^.CHLOC2:=140;
  VBL^.ABBNUM:=5;
  BONUS:=0;
  VBL^.OLDLOC:=0;
  VBL^.OLDLC2:=0;
  RESTART:=0;
  KK:=0;
  VBL^.TALLY:=0;
  VBL^.TALLY2:=0;
  TVCOND:=0;
  VBL^.DKILL:=0;
  VBL^.DFLAG:=0;
  VBL^.DTOTAL:=0;
  ATTACK:=0;
  STICK:=0;
  VBL^.KNFLOC:=0;
  MAXSCORE:=0;
  VBL^.FOOBAR:=0;
  VBL^.TURNS:=0;
  VBL^.VERB:=0;
  VBL^.OBJ:=0;
  VBL^.IWEST:=0;
  FOO:=0;
  VBL^.NUMDIE:=0;
  SCORE:=0;
  VBL^.DETAIL:=0;
  VBL^.HLDING:=0;
  SPK:=0;
  OK:=FALSE;
  SKIPIT:=FALSE;
  STEAL:=FALSE;
  VBL^.PANIC:=FALSE;
  VBL^.CLOSING:=FALSE;
  VBL^.CLOSED:=FALSE;
  VBL^.WZDARK:=FALSE;
  GAVEUP:=FALSE;
  SKIPDWARF:=FALSE;
  ALLDONE:=FALSE;
  LMWARN:=FALSE;
  SKIPDESCRIBE:=FALSE;
  ALLDONE:=FALSE;
  HE_DIED:=FALSE;
  SKIPDWARF:=FALSE;
  PIT:=FALSE;
  NEWLOCSET:=FALSE;
  KKWORD:='';
  WD1:='';
  WD2:='';
  WD1X:='';
  WD2X:='';
  ACHAR:=' ';
END;  { INITP2}
BEGIN {INITIALIZE}
  { READ IN ARRAYS }
  {$I-}
  RESET(ININFO,'ADV.MISCINFO');
  {$I+}
  IF IORESULT=0 THEN
  BEGIN
    READ(ININFO,TERMHIGHT,TERMWIDTH);
    CLOSE(ININFO);
  END
  ELSE
  BEGIN
    TERMHIGHT:=24;{DEFAULT FOR APPLE}
    TERMWIDTH:=40;
  END;
  RESET(INFILE,'ADVDATA');
  RESET(MSGFILE,'ADVMSGS');
  NEW(ARY);
  READINIT(ARY^.DBLK,SIZEOF(ARYS));
  NEW(VARY);
  READINIT(VARY^.DBLK,SIZEOF(VARYS));
  CLOSE(INFILE);
  NEW(VBL);
  INITP2;
  CLSSES:=0;
  FOR I:=1 TO 12 DO
    IF ARY^.CTEXT[I]<>0 THEN
      CLSSES:=I;
  FOR I:=4 TO 20 DO
    IF ARY^.HINTS[I,1]<>0 THEN
      HNTSIZ:=I;
  FOR X:=50 TO 64 DO
    IF ARY^.PTEXT[X]<>0 THEN
      VBL^.TALLY:=VBL^.TALLY - VARY^.PROP[X];
  FOR I:=1 TO 300 DO
    IF ARY^.ATAB[I]='' THEN
    BEGIN
      ARY^.ATAB[I]:='     ';
      ARY^.ATAB[I,1]:=CHR(255);
      ARY^.ATAB[I,2]:=CHR(I DIV 256);
      ARY^.ATAB[I,3]:=CHR(I MOD 256);
    END;
END; {INITIALIZE}
{$I ADVSUBS.TEXT}
PROCEDURE GETNEWCOMMAND;
VAR
  W1FLAG,DONE : BOOLEAN;
  INLINE : STRING;
BEGIN { GETNEWCOMMAND }
  IF VBL^.CLOSED THEN
  BEGIN
    IF (VARY^.PROP[OYSTER]<0) AND TOTING(OYSTER) THEN
      PSPEAK(OYSTER,1);
    FOR I:=1 TO 100 DO
      IF TOTING(I) AND (VARY^.PROP[I]<0) THEN
        VARY^.PROP[I]:=-1-VARY^.PROP[I];
  END;
  LINE:=1;
  WD1:='';
  WD2:='';
  WD1X:='';
  WD2X:='';
  VBL^.WZDARK:=DARK;
  IF (VBL^.KNFLOC>0) AND (VBL^.KNFLOC<>VBL^.LOC) THEN
    VBL^.KNFLOC:=0;
  I:=RAN(1);
  REPEAT
    READLN(INLINE);
    INLINE:=CONCAT(INLINE,'  :');
    WHILE INLINE[1]=' ' DO
      DELETE(INLINE,1,1);
  UNTIL INLINE<>':';
  W1FLAG:=FALSE;
  DONE:=FALSE;
  REPEAT
    ACHAR:=COPY(INLINE,1,1);
    DELETE(INLINE,1,1);
    IF ACHAR=' ' THEN
    BEGIN
      DONE:=W1FLAG;
      W1FLAG:=TRUE
    END
    ELSE
      IF W1FLAG THEN
        IF LENGTH(WD2)=5 THEN
          WD2X:=CONCAT(WD2X,ACHAR)
        ELSE
          WD2:=CONCAT(WD2,ACHAR)
      ELSE
        IF LENGTH(WD1)=5 THEN
          WD1X:=CONCAT(WD1X,ACHAR)
        ELSE
          WD1:=CONCAT(WD1,ACHAR)
  UNTIL DONE;
END;  { GETNEWCOMMAND }
PROCEDURE DOWHATHESAYS;
{$I ADVVERB.TEXT}
PROCEDURE ANALANOBJ;
PROCEDURE ASKWHATTODO;
BEGIN {ASKWHATTODO}
  IF WD2<>'' THEN
  BEGIN
    RESTART:=1;
    EXIT(ANALANOBJ);
  END;
  IF VBL^.VERB<>0 THEN
  BEGIN
    ANALATVERB;
    EXIT(ANALANOBJ);
  END;
  WRITELN('WHAT DO YOU WANT TO DO WITH THE ',WD1,WD1X);
  RESTART:=1;
  EXIT(DOWHATHESAYS);
END;  {ASKWHATTODO}
BEGIN { ANALANOBJ }
  VBL^.OBJ:=K;
  IF (VARY^.FIXED[K]=VBL^.LOC) OR HERE(K) THEN
    ASKWHATTODO;
  IF K=GRATE THEN
  BEGIN
    IF (VBL^.LOC=1) OR (VBL^.LOC=4) OR (VBL^.LOC=7) THEN
      K:=DEPRESSION;
    IF (VBL^.LOC>9) AND (VBL^.LOC<15) THEN
      K:=ENTRANCE;
    IF K<>GRATE THEN
    BEGIN
      SET_NEW_LOC;
      EXIT(ANALANOBJ);
    END;
  END;
  IF K=DWARF THEN
    FOR I:=1 TO 5 DO
      IF (VARY^.DLOC[I]=VBL^.LOC) AND (VBL^.DFLAG>=2) THEN
        ASKWHATTODO;
  IF ((LIQ=K) AND HERE(BOTTLE)) OR (K=LIQLOC(VBL^.LOC)) THEN
    ASKWHATTODO;
  IF (VBL^.OBJ=PLANT) AND AT(PLANT2) AND (VARY^.PROP[PLANT2]=0) THEN
  BEGIN
    VBL^.OBJ:=PLANT2;
    ASKWHATTODO;
  END;
  IF (VBL^.OBJ=KNIFE) AND (VBL^.KNFLOC=VBL^.LOC) THEN
  BEGIN
    VBL^.KNFLOC:=-1;
    SPEAK(ARY^.RTEXT[116]);
  END
  ELSE
    IF (VBL^.OBJ=ROD) AND HERE(ROD2) THEN
    BEGIN
      VBL^.OBJ:=ROD2;
      ASKWHATTODO;
    END
    ELSE
      IF ((VBL^.VERB=FIND) OR
          (VBL^.VERB=INVENTORY)) AND (WD2='') THEN
        ASKWHATTODO
      ELSE
        WRITELN('I SEE NO ',WD1,WD1X,' HERE.');
  SKIPDWARF:=TRUE;
  SKIPDESCRIBE:=TRUE;
  EXIT(DOWHATHESAYS);
END;  { ANALANOBJ }
PROCEDURE ANALAVERB;
BEGIN { ANALAVERB }
  VBL^.VERB:=K;
  SPK:=ARY^.ACTSPK[VBL^.VERB];
  IF (WD2<>'') AND (VBL^.VERB<>SAY) THEN
  BEGIN
    RESTART:=1;
    EXIT(ANALAVERB);
  END;
  IF VBL^.VERB=SAY THEN
    IF WD2='' THEN
      ANALANITVERB
    ELSE
      ANALATVERB
  ELSE
    IF VBL^.OBJ=0 THEN
      ANALANITVERB
    ELSE
      ANALATVERB;
END;  { ANALAVERB }
PROCEDURE CLOSE1;
BEGIN {CLOSE1}
  VARY^.PROP[GRATE]:=0;
  VARY^.PROP[FISSURE]:=0;
  FOR I:=1 TO 6 DO
    VARY^.DSEEN[I]:=FALSE;
  MOVE(TROLL,0);
  MOVE(TROLL+100,0);
  MOVE(TROLL2,ARY^.PLAC[TROLL]);
  MOVE(TROLL2+100,VARY^.FIXED[TROLL]);
  JUGGLE(CHASM);
  IF VARY^.PROP[BEAR]<>3 THEN
    DESTROY(BEAR);
  VARY^.PROP[CHAIN]:=0;
  VARY^.FIXED[CHAIN]:=0;
  VARY^.PROP[AXE]:=0;
  VARY^.FIXED[AXE]:=0;
  SPEAK(ARY^.RTEXT[129]);
  VBL^.CLOCK1:=-1;
  VBL^.CLOSING:=TRUE;
END;  {CLOSE2}
PROCEDURE CLOSE2;
BEGIN {CLOSE2}
  VARY^.PROP[BOTTLE]:=PUT(BOTTLE,115,1);
  VARY^.PROP[PLANT]:=PUT(PLANT,115,0);
  VARY^.PROP[OYSTER]:=PUT(OYSTER,115,0);
  VARY^.PROP[LAMP]:=PUT(LAMP,115,0);
  VARY^.PROP[ROD]:=PUT(ROD,115,0);
  VARY^.PROP[DWARF]:=PUT(DWARF,115,0);
  VBL^.LOC:=115;
  VBL^.OLDLOC:=115;
  NEWLOC:=115;
  FOO:=PUT(GRATE,116,0);
  VARY^.PROP[SNAKE]:=PUT(SNAKE,116,1);
  VARY^.PROP[BIRD]:=PUT(BIRD,116,1);
  VARY^.PROP[CAGE]:=PUT(CAGE,116,0);
  VARY^.PROP[ROD2]:=PUT(ROD2,116,0);
  VARY^.PROP[PILLOW]:=PUT(PILLOW,116,0);
  VARY^.PROP[MIRROR]:=PUT(MIRROR,115,0);
  VARY^.FIXED[MIRROR]:=116;
  FOR I:=1 TO 100 DO
    IF TOTING(I) THEN
      DESTROY(I);
  SPEAK(ARY^.RTEXT[132]);
  VBL^.CLOSED:=TRUE;
  EXIT(DOWHATHESAYS);
END;  {CLOSE2}
BEGIN { DOWHATHESAYS }
  IF VBL^.FOOBAR>0 THEN
    VBL^.FOOBAR:=-VBL^.FOOBAR
  ELSE
    VBL^.FOOBAR:=0;
  VBL^.TURNS:=VBL^.TURNS+1;
  K:=SAY;
  IF (VBL^.VERB=SAY) AND (WD2<>'') THEN
    VBL^.VERB:=0;
  IF VBL^.VERB<>SAY THEN
  BEGIN
    IF (VBL^.TALLY=0) AND (VBL^.LOC>=15) AND (VBL^.LOC<>33) THEN
      VBL^.CLOCK1:=VBL^.CLOCK1-1;
    IF VBL^.CLOCK1=0 THEN
      CLOSE1
    ELSE
      IF VBL^.CLOCK1<0 THEN
        VBL^.CLOCK2:=VBL^.CLOCK2-1;
    IF VBL^.CLOCK2=0 THEN
      CLOSE2
    ELSE
    BEGIN
      IF VARY^.PROP[LAMP]=1 THEN
        VBL^.LIMIT:=VBL^.LIMIT-1;
      IF (VBL^.LIMIT<=30) AND HERE(BATTERY) AND
         (VARY^.PROP[BATTERY]=0) AND HERE(LAMP) THEN
      BEGIN
        SPEAK(ARY^.RTEXT[188]);
        VARY^.PROP[BATTERY]:=1;
        IF TOTING(BATTERY) THEN
          DROP(BATTERY,VBL^.LOC);
        VBL^.LIMIT:=VBL^.LIMIT+2500;
        LMWARN:=FALSE;
      END
      ELSE
        IF VBL^.LIMIT=0 THEN
        BEGIN
          VBL^.LIMIT:=-1;
          VARY^.PROP[LAMP]:=0;
          IF HERE(LAMP) THEN
            SPEAK(ARY^.RTEXT[184]);
        END
        ELSE
          IF (VBL^.LIMIT<0) AND (VBL^.LOC<=8) THEN
          BEGIN
            SPEAK(ARY^.RTEXT[185]);
            ALLDONE:=TRUE;
            GAVEUP:=TRUE;
            EXIT(DOWHATHESAYS);
          END
          ELSE
            IF VBL^.LIMIT<=30 THEN
            BEGIN
              IF NOT LMWARN AND HERE(LAMP) THEN
              BEGIN
                LMWARN:=TRUE;
                SPK:=187;
                IF VARY^.PLACE[BATTERY]=0 THEN
                  SPK:=183;
                IF VARY^.PROP[BATTERY]=1 THEN
                  SPK:=189;
                SPEAK(ARY^.RTEXT[SPK]);
              END;
            END;
      K:=43; {WHERE?}
      IF LIQLOC(VBL^.LOC)=WATER THEN
        K:=70;
      IF (WD1='ENTER') AND ((WD2='STREA') OR (WD2='WATER')) THEN
      BEGIN
        SPEAK(ARY^.RTEXT[K]);
        SKIPDWARF:=TRUE;
        SKIPDESCRIBE:=TRUE;
      END
      ELSE
      REPEAT
        RESTART:=0;
        IF (WD1='ENTER') AND (WD2<>'') THEN
        BEGIN
          WD1:=WD2;
          WD1X:=WD2X;
          WD2:='';
        END
        ELSE
        BEGIN
          IF ((WD1='WATER') OR (WD1='OIL')) AND
             ((WD2='PLANT') OR (WD2='DOOR')) THEN
            IF AT(VOCAB(WD2,1)) THEN
              WD2:='POUR';
        END;
        IF WD1='WEST' THEN
        BEGIN
          VBL^.IWEST:=VBL^.IWEST+1;
          IF VBL^.IWEST=10 THEN
            SPEAK(ARY^.RTEXT[17]);
        END;
        I:=VOCAB(WD1,-1);
        IF I=-1 THEN
        BEGIN
          SPK:=60;
          IF PERCENT(20) THEN
            SPK:=61;
          IF PERCENT(20) THEN
            SPK:=13;
          SPEAK(ARY^.RTEXT[SPK]);
          RESTART:=1;
          EXIT(DOWHATHESAYS);
        END
        ELSE
        BEGIN
          K:=I MOD 1000;
          CASE (I DIV 1000) OF
            0 : SET_NEW_LOC;
            1 : ANALANOBJ;
            2 : ANALAVERB;
            3 : BEGIN
                  SKIPDWARF:=TRUE;
                  SKIPDESCRIBE:=TRUE;
                  IF K<>0 THEN
                    SPEAK(ARY^.RTEXT[K]);
                END;
          END;
          IF RESTART<>0 THEN
          BEGIN
            WD1:=WD2;
            WD1X:=WD2X;
            WD2:='';
          END;
        END;
      UNTIL RESTART=0; { SHORT RESTART }
    END;
  END;
END;  { DOWHATHESAYS }
PROCEDURE REINCARNATION;
BEGIN { REINCARNATION }
  IF HE_DIED THEN
  BEGIN
    IF PIT THEN
    BEGIN
      SPEAK(ARY^.RTEXT[23]);
      VBL^.OLDLC2:=VBL^.LOC;
    END;
    IF VBL^.CLOSING THEN
    BEGIN
      SPEAK(ARY^.RTEXT[131]);
      VBL^.NUMDIE:=VBL^.NUMDIE+1;
    END
    ELSE
    BEGIN
      YEA:=YES(81+(VBL^.NUMDIE*2),82+(VBL^.NUMDIE*2),54);
      VBL^.NUMDIE:=VBL^.NUMDIE+1;
      IF (VBL^.NUMDIE<>MAXDIE) AND YEA THEN
      BEGIN
        HE_DIED:=FALSE; { SAVED! }
        SKIPDWARF:=TRUE;
        VARY^.PLACE[WATER]:=0;
        VARY^.PLACE[OIL]:=0;
        IF TOTING(LAMP) THEN
          VARY^.PROP[LAMP]:=0;
        FOR J:=100 DOWNTO 1 DO
          IF TOTING(J) THEN
          BEGIN
            K:=VBL^.OLDLC2;
            IF J=LAMP THEN
              K:=1;
            DROP(J,K);
          END;
        VBL^.LOC:=3;
        VBL^.OLDLOC:=VBL^.LOC;
      END;
    END;
  END;
END;  { REINCARNATION }
PROCEDURE ENDGAME;
BEGIN { ENDGAME }
  SCORE:=GETSCORE(FALSE);
  WRITELN;
  WRITE('YOU SCORED ',SCORE,' OUT OF A POSSIBLE ',MAXSCORE);
  IF TERMWIDTH<64 THEN
    WRITELN;
  IF VBL^.TURNS=1 THEN
    KKWORD:='.'
  ELSE
    KKWORD:='S.';
  WRITELN(' USING ',VBL^.TURNS,' TURN',KKWORD);
  FOR I:=1 TO CLSSES DO
    IF ARY^.CVAL[I]>=SCORE THEN
    BEGIN
      SPEAK(ARY^.CTEXT[I]);
      IF I=CLSSES THEN
      BEGIN
        WRITE('TO ACHIEVE THE NEXT HIGHER RATING WOULD ');
        IF TERMWIDTH<64 THEN
          WRITELN;
        WRITELN('BE A NEAT TRICK!');
        WRITELN;
        WRITELN('CONGRATULATIONS');
      END
      ELSE
      BEGIN
        K:=ARY^.CVAL[I]+1-SCORE;
        KKWORD:='S.';
        IF K=1 THEN
          KKWORD:='.';
        WRITE('TO ACHIEVE THE NEXT HIGHER RATING, YOU NEED ');
        IF TERMWIDTH<64 THEN
          WRITELN;
        WRITELN(K,' MORE POINT',KKWORD);
      END;
      I:=CLSSES; { EXIT THIS MESS }
    END;
END;  { ENDGAME }
BEGIN { ADVENTURE  }
  INITIALIZE;
  VARY^.HINTED[3]:=YES(65,1,0);
  IF VARY^.HINTED[3] THEN
    RESUME:=FALSE
  ELSE
    RESUME:=YES(201,0,0);
  IF RESUME THEN
  BEGIN
    NAMEANDPW;
    {$I-}
    RESET(INFILE,NAMEOFUSER);
    IF IORESULT<>0 THEN
    {$I+}
    BEGIN
      WRITELN('SORRY, YOU DO NOT HAVE A SAVED GAME');
      RESUME:=FALSE;
    END
    ELSE
    BEGIN
      READINIT(VARY^.DBLK,SIZEOF(VARYS));
      READINIT(VBL^.DBLK,SIZEOF(VBLS));
      CLOSE(INFILE);
      IF TESTPW<>VBL^.PASSWORD THEN
      BEGIN
        WRITE('INCORRECT PASSWORD');
        EXIT(ADVENTURE);
      END;
      IF VERSION<>VBL^.VERSION THEN
      BEGIN
        IF VERSION>VBL^.VERSION THEN
          WRITE('OLD SAVE FILE - NEW ')
        ELSE
          WRITE('NEW SAVE FILE - OLD ');
        WRITE('ADVENTURE. SORRY.');
        EXIT(ADVENTURE);
      END;
    END;
    VBL^.LIMIT:=MAX(VBL^.LIMIT,150); { GIVE HIM SOME TIME}
  END;
  IF NOT RESUME THEN
  BEGIN
    VBL^.LOC:=1;
    VBL^.CLOCK1:=30;
    VBL^.CLOCK2:=50;
    IF VARY^.HINTED[3] THEN
      VBL^.LIMIT:=1000
    ELSE
      VBL^.LIMIT:=330;
  END;
  NEWLOC:=VBL^.LOC;
  REPEAT
    REPEAT
      IF SKIPDWARF THEN
        SKIPDWARF:=FALSE
      ELSE
      BEGIN
        TESTCLOSE;
        VBL^.LOC:=NEWLOC;
        IF VBL^.LOC<>0 THEN
          IF NOT FORCED(VBL^.LOC) AND
            NOT BITSET(NEWLOC,3) THEN
            IF VBL^.DFLAG=0 THEN
              IF VBL^.LOC>=15 THEN
                VBL^.DFLAG:=1
              ELSE
            ELSE
              DWARFSTUFF;
      END;
      NEWLOCSET:=FALSE;
      IF NOT HE_DIED THEN
      BEGIN
        IF SKIPDESCRIBE THEN
          SKIPDESCRIBE:=FALSE
        ELSE
        BEGIN
          WRITELN;
          DESCRIBE_CURRENT_LOCATION;
        END;
        IF NOT HE_DIED AND NOT NEWLOCSET THEN
        BEGIN
          VBL^.VERB:=0;
          VBL^.OBJ:=0;
          RESTART:=0;
          REPEAT
            IF RESTART<>2 THEN
            BEGIN
              CHECKHINTS;
              GETNEWCOMMAND;
            END;
            RESTART:=0;
            DOWHATHESAYS;
          UNTIL RESTART=0; {LONG RESTART}
        END;
      END;
    UNTIL HE_DIED OR ALLDONE; { MAIN LOOP }
    REINCARNATION;
  UNTIL HE_DIED OR ALLDONE;   { NO MORE RE-INCARNATIONS}
  ENDGAME;
END.


========================================================================================
DOCUMENT :usus Folder:VOL09:advinit.text
========================================================================================

PROGRAM BUILDINIT;
TYPE
  CHAR6 = PACKED ARRAY[1..6] OF CHAR;
  ARYS = RECORD
    CASE BOOLEAN OF
      FALSE : ( DBLK : PACKED ARRAY[1..512] OF CHAR);
      TRUE  : (TRAVEL : ARRAY[1..750] OF INTEGER;
               TRAVEL2 : ARRAY[1..750] OF INTEGER;
               TRAVEL3 : ARRAY[1..750] OF INTEGER;
               ATAB : ARRAY[1..300] OF STRING[5];
               KTAB : ARRAY[1..300] OF INTEGER;
               LTEXT : ARRAY[1..150] OF INTEGER;
               STEXT : ARRAY[1..150] OF INTEGER;
               KEY : ARRAY[1..150] OF INTEGER;
               PLAC : ARRAY[1..100] OF INTEGER;
               FIXD : ARRAY[1..100] OF INTEGER;
               PTEXT : ARRAY[1..100] OF INTEGER;
               ACTSPK : ARRAY[1..35] OF INTEGER;
               RTEXT : ARRAY[1..205] OF INTEGER;
               CTEXT : ARRAY[1..12] OF INTEGER;
               CVAL : ARRAY[1..12] OF INTEGER;
               HINTS : ARRAY[1..20,1..4] OF INTEGER)
  END;
  VARYS = RECORD
    CASE BOOLEAN OF
      FALSE : ( DBLK : PACKED ARRAY[1..512] OF CHAR);
      TRUE  : (COND : ARRAY[1..150] OF INTEGER;
               ABB : ARRAY[1..150] OF INTEGER;
               ATLOC : ARRAY[1..150] OF INTEGER;
               PLACE : ARRAY[1..100] OF INTEGER;
               FIXED : ARRAY[1..100] OF INTEGER;
               LINK : ARRAY[1..200] OF INTEGER;
               PROP : ARRAY[1..100] OF INTEGER;
               HINTLC : ARRAY[1..20] OF INTEGER;
               HINTED : ARRAY[1..20] OF BOOLEAN;
               DSEEN : ARRAY[1..6] OF BOOLEAN;
               DLOC : ARRAY[1..6] OF INTEGER;
               ODLOC : ARRAY[1..6] OF INTEGER;
               TK : ARRAY[1..20] OF INTEGER)
  END;
VAR
  MSGNDX,SEG,CLASSES,RECNUM,I,J,K,COUNT : INTEGER;
  ACHAR : CHAR;
  ARY : ^ARYS;
  VARY : ^VARYS;
  MSGFILE : FILE OF CHAR6;
  SAVEMSG : STRING[10];
  INFILE : TEXT;
  OUTFILE : FILE;
PROCEDURE DROP(OBJECT,WHERE:INTEGER);
BEGIN
  WITH VARY^ DO
  BEGIN
    IF OBJECT>100 THEN
      FIXED[OBJECT-100]:=WHERE
    ELSE
      PLACE[OBJECT]:=WHERE;
    IF WHERE>0 THEN
    BEGIN
      LINK[OBJECT]:=ATLOC[WHERE];
      ATLOC[WHERE]:=OBJECT;
    END;
  END;
END;
PROCEDURE BLIP;
BEGIN {BLIP}
  IF COUNT=50 THEN
  BEGIN
    COUNT:=0;
    WRITELN;
    WRITE('           .');
  END
  ELSE
    WRITE('.');
  COUNT:=COUNT+1;
END;  {BLIP}
PROCEDURE BLIPER(MSG:STRING);
BEGIN
  COUNT:=0;
  WRITELN;
  WRITE(MSG);
END;
PROCEDURE PUTMSG(MSG:STRING;SAME:BOOLEAN);
VAR
  I : INTEGER;
BEGIN { PUTMSG }
  IF LENGTH(MSG)=0 THEN
    MSG:=' ';
  IF SAME THEN
  BEGIN
    IF LENGTH(SAVEMSG)<>0 THEN
      RECNUM:=RECNUM-1;
    MSG:=CONCAT(SAVEMSG,MSG);
    SAVEMSG:='';
  END
  ELSE
  BEGIN
    IF SAVEMSG<>'' THEN
    BEGIN
      WHILE LENGTH(SAVEMSG)<5 DO
        SAVEMSG:=CONCAT(SAVEMSG,' ');
      PUTMSG(' ',TRUE);
    END;
    MSGFILE^[1]:=CHR(ORD(MSGFILE^[1])+128);
  END;
  WHILE LENGTH(MSG)>=6 DO
  BEGIN
    PUT(MSGFILE); { PUT LAST MESSAGE }
    FOR I:=1 TO 6 DO
      MSGFILE^[I]:=MSG[I];
    DELETE(MSG,1,6);
    RECNUM:=RECNUM+1;
  END;
  SAVEMSG:=MSG;
  IF LENGTH(SAVEMSG)<>0 THEN
    RECNUM:=RECNUM+1;
END;  { PUTMSG }
PROCEDURE TXTREAD;
VAR
  LAST,I : INTEGER;
  MSGTXT : STRING[128];
PROCEDURE PART1;
BEGIN {PART1}
  IF ARY^.LTEXT[MSGNDX]=0 THEN
    ARY^.LTEXT[MSGNDX]:=RECNUM;
END;  {PART1}
PROCEDURE PART2;
BEGIN {PART2}
  IF ARY^.STEXT[MSGNDX]=0 THEN
    ARY^.STEXT[MSGNDX]:=RECNUM;
END;  {PART2}
PROCEDURE PART5;
BEGIN {PART5}
  IF (MSGNDX>0) AND (MSGNDX<=100) THEN
    IF ARY^.PTEXT[MSGNDX]=0 THEN
      ARY^.PTEXT[MSGNDX]:=RECNUM;
END;  {PART5}
PROCEDURE PART6;
BEGIN {PART6}
  IF ARY^.RTEXT[MSGNDX]=0 THEN
    ARY^.RTEXT[MSGNDX]:=RECNUM;
END;  {PART6}
PROCEDURE PART10;
BEGIN {PART10}
  CLASSES:=CLASSES+1;
  IF ARY^.CTEXT[CLASSES]=0 THEN
    ARY^.CTEXT[CLASSES]:=RECNUM;
  ARY^.CVAL[CLASSES]:=MSGNDX;
END;  {PART10}
BEGIN {TXTREAD}
  LAST:=32761;
  REPEAT
    READ(INFILE,MSGNDX);
    BLIP;
    IF NOT EOF(INFILE) THEN
    BEGIN
      IF NOT EOLN(INFILE) THEN
        READ(INFILE,ACHAR); { ONE BLANK DELIMETER }
      CASE SEG OF
        1 : PART1;
        2 : PART2;
        5 : PART5;
        6 : PART6;
       10 : PART10;
      END;
      READLN(INFILE,MSGTXT);
      PUTMSG(MSGTXT,MSGNDX=LAST);
      LAST:=MSGNDX;
    END;
  UNTIL EOF(INFILE);
  IF LENGTH(SAVEMSG)>0 THEN
  BEGIN
    WHILE LENGTH(SAVEMSG)<5 DO
      SAVEMSG:=CONCAT(SAVEMSG,' ');
    PUTMSG(' ',TRUE);
  END;
  CLOSE(INFILE);
END;
PROCEDURE SEGMENT1;
BEGIN { SEGMENT1 }
  BLIPER('<SEGMENT1 >');
  RESET(INFILE,'ADVS1.TEXT');
  SEG:=1;
  TXTREAD;
END;  { SEGMENT1 }
PROCEDURE SEGMENT2;
BEGIN { SEGMENT2 }
  BLIPER('<SEGMENT2 >');
  RESET(INFILE,'ADVS2.TEXT');
  SEG:=2;
  TXTREAD;
END;  { SEGMENT2 }
PROCEDURE SEGMENT3;
VAR
  TVINDEX,INDEX,TRVL,TVCOND,VOIB : INTEGER;
BEGIN { SEGMENT3 }
  TVINDEX:=1;
  BLIPER('<SEGMENT3 >');
  RESET(INFILE,'ADVS3.TEXT');
  WHILE NOT EOF(INFILE) DO
  BEGIN
    READ(INFILE,INDEX);
    BLIP;
    IF NOT EOLN(INFILE) THEN
    BEGIN
      READ(INFILE,TVCOND,TRVL);
      IF ARY^.KEY[INDEX]=0 THEN
        ARY^.KEY[INDEX]:=TVINDEX
      ELSE
        ARY^.TRAVEL[TVINDEX-1]:=-ARY^.TRAVEL[TVINDEX-1];
      WHILE NOT EOLN(INFILE) DO
      BEGIN
        READ(INFILE,VOIB,ACHAR);
        ARY^.TRAVEL[TVINDEX]:=VOIB;
        ARY^.TRAVEL2[TVINDEX]:=TRVL;
        ARY^.TRAVEL3[TVINDEX]:=TVCOND;
        TVINDEX:=TVINDEX+1;
      END;
      ARY^.TRAVEL[TVINDEX-1]:=-ARY^.TRAVEL[TVINDEX-1];
      READLN(INFILE);
    END;
  END;
  CLOSE(INFILE);
END;  { SEGMENT3 }
PROCEDURE SEGMENT4;
VAR
  WORDNUM,NUMBER : INTEGER;
BEGIN { SEGMENT4 }
  WORDNUM:=1;
  BLIPER('<SEGMENT4 >');
  RESET(INFILE,'ADVS4.TEXT');
  WHILE NOT EOF(INFILE) DO
  BEGIN
    READ(INFILE,NUMBER);
    BLIP;
    IF NOT EOLN(INFILE) THEN
    BEGIN
      READ(INFILE,ACHAR);
      READLN(INFILE,ARY^.ATAB[WORDNUM]);
      ARY^.KTAB[WORDNUM]:=NUMBER;
      WORDNUM:=WORDNUM+1;
    END;
  END;
  CLOSE(INFILE);
END;  { SEGMENT4 }
PROCEDURE SEGMENT5;
BEGIN { SEGMENT5 }
  BLIPER('<SEGMENT5 >');
  RESET(INFILE,'ADVS5.TEXT');
  SEG:=5;
  TXTREAD;
END;  { SEGMENT5 }
PROCEDURE SEGMENT6;
BEGIN { SEGMENT6 }
  BLIPER('<SEGMENT6 >');
  RESET(INFILE,'ADVS6.TEXT');
  SEG:=6;
  TXTREAD;
END;  { SEGMENT6 }
PROCEDURE SEGMENT7;
VAR
  ILOC1,ILOC2,OBJECT : INTEGER;
BEGIN { SEGMENT7 }
  BLIPER('<SEGMENT7 >');
  RESET(INFILE,'ADVS7.TEXT');
  WHILE NOT EOF(INFILE) DO
  BEGIN
    READ(INFILE,OBJECT);
    BLIP;
    IF NOT EOLN(INFILE) THEN
    BEGIN
      READLN(INFILE,ILOC1,ILOC2);
      ARY^.PLAC[OBJECT]:=ILOC1;
      ARY^.FIXD[OBJECT]:=ILOC2;
    END;
  END;
  CLOSE(INFILE);
END;  { SEGMENT7 }
PROCEDURE SEGMENT8;
VAR
  VOIB,MSGNUM : INTEGER;
BEGIN { SEGMENT8 }
  BLIPER('<SEGMENT8 >');
  RESET(INFILE,'ADVS8.TEXT');
  WHILE NOT EOF(INFILE) DO
  BEGIN
    READ(INFILE,VOIB);
    BLIP;
    IF NOT EOLN(INFILE) THEN
    BEGIN
      READLN(INFILE,MSGNUM);
      ARY^.ACTSPK[VOIB]:=MSGNUM;
    END;
  END;
  CLOSE(INFILE);
END;  { SEGMENT8 }
PROCEDURE SEGMENT9;
VAR
  I,TEMP,COND,LOC : INTEGER;
BEGIN { SEGMENT9 }
  BLIPER('<SEGMENT9 >');
  RESET(INFILE,'ADVS9.TEXT');
  WHILE NOT EOF(INFILE) DO
  BEGIN
    READ(INFILE,COND);
    BLIP;
    TEMP:=1;
    FOR I:=1 TO COND DO
      TEMP:=TEMP*2;
    IF NOT EOLN(INFILE) THEN
      WHILE NOT EOLN(INFILE) DO
      BEGIN
        READ(INFILE,LOC,ACHAR);
        VARY^.COND[LOC]:=VARY^.COND[LOC]+TEMP;
      END;
    READLN(INFILE);
  END;
  CLOSE(INFILE);
END;  { SEGMENT9 }
PROCEDURE SEGMENTA;
BEGIN { SEGMENTA }
  BLIPER('<SEGMENT10>');
  RESET(INFILE,'ADVS10.TEXT');
  SEG:=10;
  TXTREAD;
END;  { SEGMENTA }
PROCEDURE SEGMENTB;
VAR
  HINT,TURNS,POINTS,QUES,ANS : INTEGER;
BEGIN { SEGMENTB }
  BLIPER('<SEGMENT11>');
  RESET(INFILE,'ADVS11.TEXT');
  WHILE NOT EOF(INFILE) DO
  BEGIN
    READ(INFILE,HINT);
    BLIP;
    IF NOT EOLN(INFILE) THEN
    BEGIN
      READLN(INFILE,TURNS,POINTS,QUES,ANS);
      ARY^.HINTS[HINT,1]:=TURNS;
      ARY^.HINTS[HINT,2]:=POINTS;
      ARY^.HINTS[HINT,3]:=QUES;
      ARY^.HINTS[HINT,4]:=ANS;
    END;
  END;
  CLOSE(INFILE);
END;  { SEGMENTB }
PROCEDURE LINKUP;
VAR
  K,I : INTEGER;
BEGIN {LINKUP}
  BLIP;
  WITH ARY^,VARY^ DO
    FOR I:=1 TO 150 DO
    BEGIN
      IF (LTEXT[I]=0) OR (KEY[I]=0) THEN
      ELSE
      BEGIN
        K:=KEY[I];
        IF TRAVEL[K]=1 THEN
          COND[I]:=2;
      END;
    END;
  BLIP;
  WITH ARY^ DO
    FOR I:=100 DOWNTO 1 DO
    BEGIN
      IF FIXD[I]>0 THEN
      BEGIN
        DROP(I+100,FIXD[I]);
        DROP(I,PLAC[I]);
      END;
    END;
  BLIP;
  WITH ARY^ DO
    FOR I:=100 DOWNTO 1 DO
    BEGIN
      VARY^.FIXED[I]:=FIXD[I];
      IF (PLAC[I]<>0) AND (FIXD[I]<=0) THEN
        DROP(I,PLAC[I]);
    END;
  BLIP;
  WITH ARY^,VARY^ DO
    FOR I:=50 TO 64 DO
    BEGIN
      IF PTEXT[I]<>0 THEN
        PROP[I]:=-1;
    END;
END;  {LINKUP}
BEGIN
  NEW(ARY);
  FILLCHAR(ARY^.DBLK,SIZEOF(ARYS),CHR(0)); { ZERO ARRAYS }
  NEW(VARY);
  FILLCHAR(VARY^.DBLK,SIZEOF(VARYS),CHR(0)); { ZERO ARRAYS }
  CLASSES:=0;
  RECNUM:=1;
  COUNT:=0;
  REWRITE(MSGFILE,'ADVMSGS');
  MSGFILE^:='MSGFIL'; {WILL BE PUT }
  SAVEMSG:='';
  SEGMENT1; {LONG DESCRIPTIONS}
  SEGMENT2; {SHORT DESCRIPTIONS}
  SEGMENT3; {TRAVEL OPTIONS}
  SEGMENT4; {WORD TABLE}
  SEGMENT5; {OBJECT PROPERTIES}
  SEGMENT6; {MISC MESSAGES}
  SEGMENT7; {OBJECT LOCATIONS}
  SEGMENT8; {VERB DEFAULT ACTIONS}
  SEGMENT9; {LIQUID ASSETS}
  SEGMENTA; {PLAYER CLASS MESSAGES}
  SEGMENTB; {HINTS}
  LINKUP;   {BUILD MISC ARRAYS}
  PUTMSG('EXTMSG',FALSE);
  PUT(MSGFILE); {PURGE LAST BUFFER}
  CLOSE(MSGFILE,LOCK);
  WRITELN;
  WRITELN('WRITING ADVDATA');
  REWRITE(OUTFILE,'ADVDATA');
  I:=(SIZEOF(ARYS) + 511) DIV 512;
  IF I<>BLOCKWRITE(OUTFILE,ARY^.DBLK,I) THEN
  BEGIN
    WRITELN('ERROR WRITING FILE');
    EXIT(BUILDINIT);
  END;
  I:=(SIZEOF(VARYS) + 511) DIV 512;
  IF I<>BLOCKWRITE(OUTFILE,VARY^.DBLK,I) THEN
  BEGIN
    WRITELN('ERROR WRITING FILE');
    EXIT(BUILDINIT);
  END;
  CLOSE(OUTFILE,LOCK);
  WRITELN('FILE CREATED');
END.


========================================================================================
DOCUMENT :usus Folder:VOL09:advs1.text
========================================================================================

   1 YOU ARE STANDING AT THE END OF A ROAD BEFORE A SMA
   1 LL BRICK BUILDING.  AROUND YOU IS A FOREST.  A SMA
   1 LL STREAM FLOWS OUT OF THE BUILDING AND DOWN A GUL
   1 LY.
   2 YOU HAVE WALKED UP A HILL, STILL IN THE FOREST.  T
   2 HE ROAD SLOPES BACK DOWN THE OTHER SIDE OF THE HIL
   2 L.  THERE IS A BUILDING IN THE DISTANCE.
   3 YOU ARE INSIDE A BUILDING, A WELL HOUSE FOR A LARG
   3 E SPRING.
   4 YOU ARE IN A VALLEY IN THE FOREST BESIDE A STREAM 
   4 TUMBLING ALONG A ROCKY BED.
   5 YOU ARE IN OPEN FOREST, WITH A DEEP VALLEY TO ONE 
   5 SIDE.
   6 YOU ARE IN OPEN FOREST NEAR BOTH A VALLEY AND A RO
   6 AD.
   7 AT YOUR FEET ALL THE WATER OF THE STREAM SPLASHES 
   7 INTO A 2 INCH SLIT IN THE ROCK.  DOWNSTREAM THE ST
   7 REAMBED IS BARE ROCK.
   8 YOU ARE IN A 20 FOOT DEPRESSION FLOORED WITH BARE 
   8 DIRT.  SET INTO THE DIRT IS A STRONG STEEL GRATE M
   8 OUNTED IN CONCRETE.  A DRY STREAMBED LEADS INTO TH
   8 E DEPRESSION.
   9 YOU ARE IN A SMALL CHAMBER BENEATH A 3X3 STEEL GRA
   9 TE TO THE SURFACE.  A LOW CRAWL OVER COBBLES LEADS
   9  INWARD TO THE WEST.
  10 YOU ARE CRAWLING OVER COBBLES IN A LOW PASSAGE.  T
  10 HERE IS A DIM LIGHT AT THE END OF THE PASSAGE.
  11 YOU ARE IN A DEBRIS ROOM FILLED WITH STUFF WASHED 
  11 IN FROM THE SURFACE.  A LOW WIDE PASSAGE WITH COBB
  11 LES BECOMES PLUGGED WITH MUD AND DEBRIS HERE, BUT 
  11 AN AWKWARD CANYON LEADS UPWARD AND WEST.  A NOTE O
  11 N THE WALL SAYS 'MAGIC WORD XYZZY'.
  12 YOU ARE IN AN AWKWARD SLOPING EAST/WEST CANYON.
  13 YOU ARE IN A SPLENDID CHAMBER THIRTY FEET HIGH.  T
  13 HE WALLS ARE FROZEN RIVERS OF ORANGE STONE.  AN AW
  13 KWARD CANYON AND A GOOD PASSAGE EXIT FROM EAST AND
  13  WEST SIDES OF THE CHAMBER.
  14 AT YOUR FEET IS A SMALL PIT BREATHING TRACES OF WH
  14 ITE MIST.  AN EAST PASSAGE ENDS HERE EXCEPT FOR A 
  14 SMALL CRACK LEADING ON.
  15 YOU ARE AT ONE END OF A VAST HALL STRETCHING FORWA
  15 RD OUT OF SIGHT TO THE WEST.  THERE ARE OPENINGS T
  15 O EITHER SIDE.  NEARBY, A WIDE STONE STAIRCASE LEA
  15 DS DOWNWARD.  THE HALL IS FILLED WITH WISPS OF WHI
  15 TE MIST SWAYING TO AND FRO
  15  ALMOST AS IF ALIVE.  A COLD WIND BLOWS UP THE STA
  15 IRCASE.  THERE IS A PASSAGE AT THE TOP OF A DOME B
  15 EHIND YOU.
  16 THE CRACK IS FAR TOO SMALL FOR YOU TO FOLLOW.
  17 YOU ARE ON THE EAST BANK OF A FISSURE SLICING CLEA
  17 R ACROSS THE HALL.  THE MIST IS QUITE THICK HERE, 
  17 AND THE FISSURE IS TOO WIDE TO JUMP.
  18 THIS IS A LOW ROOM WITH A CRUDE NOTE ON THE WALL. 
  18  THE NOTE SAYS,'YOU WON'T GET IT UP THE STEPS'.
  19 YOU ARE IN THE HALL OF THE MOUNTAIN KING, WITH PAS
  19 SAGES OFF IN ALL DIRECTIONS.
  20 YOU ARE AT THE BOTTOM OF THE PIT WITH A BROKEN NEC
  20 K.
  21 YOU DIDN'T MAKE IT.
  22 THE DOME IS UNCLIMBABLE.
  23 YOU ARE AT THE WEST END OF THE TWOPIT ROOM.  THERE
  23  IS A LARGE HOLE IN THE WALL ABOVE THE PIT AT THIS
  23  END OF THE ROOM.
  24 YOU ARE AT THE BOTTOM OF THE EASTERN PIT IN THE TW
  24 OPIT ROOM.  THERE IS A SMALL POOL OF OIL IN ONE CO
  24 RNER OF THE PIT.
  25 YOU ARE AT THE BOTTOM OF THE WESTERN PIT IN THE TW
  25 OPIT ROOM.  THERE IS A LARGE HOLE IN THE WALL ABOU
  25 T 25 FEET ABOVE YOU.
  26 YOU CLAMBER UP THE PLANT AND SCURRY THROUGH THE HO
  26 LE AT THE TOP.
  27 YOU ARE ON THE WEST SIDE OF THE FISSURE IN THE HAL
  27 L OF MISTS.
  28 YOU ARE IN A LOW N/S PASSAGE AT A HOLE IN THE FLOO
  28 R.  THE HOLE GOES DOWN TO AN E/W PASSAGE.
  29 YOU ARE IN THE SOUTH SIDE CHAMBER.
  30 YOU ARE IN THE WEST SIDE CHAMBER OF THE HALL OF TH
  30 E MOUNTAIN KING.  A PASSAGE CONTINUES WEST AND UP 
  30 HERE.
  31  
  32 YOU CAN'T GET BY THE SNAKE.
  33 YOU ARE IN A LARGE ROOM, WITH A PASSAGE TO THE SOU
  33 TH, A PASSAGE TO THE WEST, AND A WALL OF BROKEN RO
  33 CK TO THE EAST.  THERE IS A LARGE 'Y2' ON A ROCK I
  33 N THE ROOM'S CENTER.
  34 YOU ARE IN A JUMBLE OF ROCK, WITH CRACKS EVERWHERE
  34 .
  35 YOU'RE AT A LOW WINDOW OVERLOOKING A HUGE PIT, WHI
  35 CH EXTENDS UP OUT OF SIGHT.  A FLOOR IS INDISTINCT
  35 LY VISIBLE OVER 50 FEET BELOW.  TRACES OF WHITE MI
  35 ST COVER THE FLOOR OF THE PIT, BECOMING THICKER TO
  35  THE RIGHT.
  35   MARKS IN THE DUST AROUND THE WINDOW WOULD SEEM T
  35 O INDICATE
  35  THAT SOMEONE HAS BEEN HERE RECENTLY.  DIRECTLY AC
  35 ROSS THE PIT FROM YOU AND 25 FEET AWAY THERE IS A 
  35 SIMILAR WINDOW LOOKING INTO A LIGHTED ROOM.  A SHA
  35 DOWY FIGURE CAN BE SEEN THERE PEERING BACK AT YOU.
  36 YOU ARE IN A DIRTY BROKEN PASSAGE.  TO THE EAST IS
  36  A CRAWL.  TO THE WEST IS A LARGE PASSAGE.  ABOVE 
  36 YOU IS A HOLE TO ANOTHER PASSAGE.
  37 YOU ARE ON THE BRINK OF A SMALL CLEAN CLIMBABLE PI
  37 T,  A CRAWL LEADS WEST.
  38 YOU ARE IN THE BOTTOM OF A SMALL PIT WITH A LITTLE
  38  STREAM, WHICH ENTERS AND EXITS THROUGH TINY SLITS
  38 .
  39 YOU ARE IN A LARGE ROOM FULL OF DUSTY ROCKS.  THER
  39 E IS A BIG HOLE IN THE FLOOR.  THERE ARE CRACKS EV
  39 ERYWHERE, AND A PASSAGE LEADING EAST.
  40 YOU HAVE CRAWLED THROUGH A VERY LOW WIDE PASSAGE P
  40 ARALLEL TO AND NORTH OF THE HALL OF MISTS.
  41 YOU ARE AT THE WEST END OF THE HALL OF MISTS.  A L
  41 OW WIDE CRAWL CONTINUES WEST AND ANOTHER GOES NORT
  41 H.  TO THE SOUTH IS A LITTLE PASSAGE 6 FEET OFF TH
  41 E FLOOR.
  42 YOU ARE IN A MAZE OF TWISTY LITTLE PASSAGES, ALL A
  42 LIKE.
  43 YOU ARE IN A MAZE OF TWISTY LITTLE PASSAGES, ALL A
  43 LIKE.
  44 YOU ARE IN A MAZE OF TWISTY LITTLE PASSAGES, ALL A
  44 LIKE.
  45 YOU ARE IN A MAZE OF TWISTY LITTLE PASSAGES, ALL A
  45 LIKE.
  46 DEAD END.
  47 DEAD END.
  48 DEAD END.
  49 YOU ARE IN A MAZE OF TWISTY LITTLE PASSAGES, ALL A
  49 LIKE.
  50 YOU ARE IN A MAZE OF TWISTY LITTLE PASSAGES, ALL A
  50 LIKE.
  51 YOU ARE IN A MAZE OF TWISTY LITTLE PASSAGES, ALL A
  51 LIKE.
  52 YOU ARE IN A MAZE OF TWISTY LITTLE PASSAGES, ALL A
  52 LIKE.
  53 YOU ARE IN A MAZE OF TWISTY LITTLE PASSAGES, ALL A
  53 LIKE.
  54 DEAD END.
  55 YOU ARE IN A MAZE OF TWISTY LITTLE PASSAGES, ALL A
  55 LIKE.
  56 DEAD END.
  57 YOU ARE ON THE BRINK OF A THIRTY FOOT PIT WITH A M
  57 ASSIVE ORANGE COLUMN DOWN ONE WALL.  YOU COULD CLI
  57 MB DOWN HERE BUT YOU COULD NOT GET BACK UP.  THE M
  57 AZE CONTINUES AT THIS LEVEL.
  58 DEAD END.
  59 YOU HAVE CRAWLED THROUGH A VERY LOW WIDE PASSAGE P
  59 ARALLEL TO AND NORTH OF THE HALL OF MISTS.
  60 YOU ARE AT THE EAST END OF A VERY LONG HALL APPARE
  60 NTLY WITHOUT SIDE CHAMBERS.  TO THE EAST A LOW WID
  60 E CRAWL SLANTS UP.  TO THE NORTH A ROUND TWO FOOT 
  60 HOLE SLANTS DOWN.
  61 YOU ARE AT THE WEST END OF A VERY LONG FEATURELESS
  61  HALL.  THE HALL JOINS UP WITH A NARROW NORTH/SOUT
  61 H PASSAGE.
  62 YOU ARE AT A CROSSROADS OF A HIGH N/S PASSAGE AND 
  62 A LOW E/W ONE.
  63 DEAD END.
  64 YOU ARE AT A COMPLEX JUNCTION.  A LOW HANDS AND KN
  64 EES PASSAGE FROM THE NORTH JOINS A HIGHER CRAWL FR
  64 OM THE EAST TO MAKE A WALKING PASSAGE GOING WEST. 
  64  THERE IS ALSO A LARGE ROOM ABOVE.  THE AIR IS DAM
  64 P HERE.
  65 YOU ARE IN BEDQUILT, A LONG EAST/WEST PASSAGE WITH
  65  HOLES EVERYWHERE.  TO EXPLORE AT RANDOM SELECT NO
  65 RTH, SOUTH, UP, OR DOWN.
  66 YOU ARE IN A ROOM WHOSE WALLS RESEMBLE SWISS CHESE
  66 .  OBVIOUS PASSAGES GO WEST, EAST, NE, AND NW.  PA
  66 RT OF THE ROOM IS OCCUPIED BY A LARGE BEDROCK BLOC
  66 K.
  67 YOU ARE AT THE EAST END OF THE TWOPIT ROOM.  THE F
  67 LOOR HERE IS LITTERED WITH THIN ROCK SLABS, WHICH 
  67 MAKE IT EASY TO DESCEND THE PITS.  THERE IS A PATH
  67  HERE BYPASSING THE PITS TO CONNECT PASSAGES FROM 
  67 EAST AND WEST.
  67   THERE ARE HOLES ALL OVER, BUT THE ONLY BIG ONE I
  67 S ON THE WALL DIRECTLY OVER THE WEST PIT WHERE YOU
  67  CAN'T GET TO IT.
  68 YOU ARE IN A LARGE LOW CIRCULAR CHAMBER WHOSE FLOO
  68 R IS AN IMMENSE SLAB FALLEN FROM THE CEILING (SLAB
  68  ROOM).  EAST AND WEST THERE ONCE WERE LARGE PASSA
  68 GES, BUT THEY ARE NOW FILLED WITH BOULDERS.  LOW S
  68 MALL PASSAGES GO NORTH AND SOUTH,
  68  AND THE SOUTH ONE QUICKLY BENDS WEST AROUND THE B
  68 OULDERS.
  69 YOU ARE IN A SECRET N/S CANYON ABOVE A LARGE ROOM.
  70 YOU ARE IN A SECRET N/S CANYON ABOVE A SIZABLE PAS
  70 SAGE.
  71 YOU ARE IN A SECRET CANYON AT A JUNCTION OF THREE 
  71 CANYONS, BEARING NORTH, SOUTH, AND SE.  THE NORTH 
  71 ONE IS AS TALL AS THE OTHER TWO COMBINED.
  72 YOU ARE IN A LARGE LOW ROOM.  CRAWLS LEAD NORTH SE
  72 , AND SW.
  73 DEAD END CRAWL.
  74 YOU ARE IN A SECRET CANYON WHICH HERE RUNS E/W.  I
  74 T CROSSES OVER A VERY TIGHT CANYON 15 FEET BELOW. 
  74  IF YOU GO DOWN YOU MAY NOT BE ABLE TO GET BACK UP
  74 .
  75 YOU ARE AT A WIDE PLACE IN A VERY TIGHT N/S CANYON
  75 .
  76 THE CANYON HERE BECOMES TOO TIGHT TO GO FURTHER SO
  76 UTH.
  77 YOU ARE IN A TALL E/W CANYON.  A LOW TIGHT CRAWL G
  77 OES 3 FEET NORTH AND SEEMS TO OPEN UP.
  78 THE CANYON RUNS INTO A MASS OF BOULDERS -- DEAD EN
  78 D.
  79 THE STREAM FLOWS OUT THROUGH A PAIR OF 1 FOOT DIAM
  79 ETER SEWER PIPES.  IT WOULD BE ADVISABLE TO USE TH
  79 E EXIT.
  80 YOU ARE IN A MAZE OF TWISTY LITTLE PASSAGES, ALL A
  80 LIKE.
  81 DEAD END.
  82 DEAD END.
  83 YOU ARE IN A MAZE OF TWISTY LITTLE PASSAGES, ALL A
  83 LIKE.
  84 YOU ARE IN A MAZE OF TWISTY LITTLE PASSAGES, ALL A
  84 LIKE.
  85 DEAD END.
  86 DEAD END.
  87 YOU ARE IN A MAZE OF TWISTY LITTLE PASSAGES, ALL A
  87 LIKE.
  88 YOU ARE IN A LONG, NARROW CORRIDOR STRETCHING OUT 
  88 OF SIGHT TO THE WEST.  AT THE EASTERN END IS A WHO
  88 LE THROUGH WHICH YOU CAN SEE A PROFUSION OF LEAVES
  88 .
  89 THERE IS NOTHING HERE TO CLIMB.  USE 'UP' OR 'OUT'
  89  TO LEAVE THE PIT.
  90 YOU HAVE CLIMBED UP THE PLANT AND OUT OF THE PIT.
  91 YOU ARE AT THE TOP OF A STEEP INCLINE ABOVE A LARG
  91 E ROOM.  YOU COULD CLIMB DOWN HERE, BUT YOU WOULD 
  91 NOT BE ABLE TO CLIMB UP.  THERE IS A PASSAGE LEADI
  91 NG BACK TO THE NORTH.
  92 YOU ARE IN THE GIANT ROOM.  THE CEILING HERE IS TO
  92 O HIGH UP FOR YOUR LAMP TO SHOW IT.  CAVERNOUS PAS
  92 SAGES LEAD EAST, NORTH, AND SOUTH.  ON THE WEST WA
  92 LL IS SCRAWLED THE INSCRIPTION, 'FEE FIE FOE FOO' 
  92 (SIC).
  93 THE PASSAGE HERE IS BLOCKED BY A RECENT CAVE-IN.
  94 YOU ARE AT ONE END OF AN IMMENSE NORTH/SOUTH PASSA
  94 GE.
  95 YOU ARE IN A MAGNIFICIENT CAVERN WITH A RUSHING ST
  95 REAM, WHICH CASCADES OVER A SPARKLING WATERFALL IN
  95 TO A ROARING WHIRLPOOL WHICH DISAPEARS THROUGH A H
  95 OLE IN THE FLOOR.  PASSAGES EXIT TO THE SOUTH AND 
  95 WEST.
  96 YOU ARE IN THE SOFT ROOM.  THE WALLS ARE COVERED W
  96 ITH HEAVY CURTAINS, THE FLOOR WITH A THICK PILE CA
  96 RPET.  MOSS COVERS THE CEILING.
  97 THIS THE ORIENTAL ROOM.  ANCIENT ORIENTAL CAVE DRA
  97 WINGS COVER THE WALLS.  A GENTLY SLOPING PASSAGE L
  97 EADS UPWARD TO THE NORTH, ANOTHER PASSAGE LEADS SE
  97 , AND A HANDS AND KNEES CRAWL LEADS WEST.
  98 YOU ARE FOLLOWING A WIDE PATH AROUND THE OUTER EDG
  98 E OF A LARGE CAVERN.  FAR BELOW, THROUGH A HEAVY W
  98 HITE MIST, STRANGE SPLASHING NOISES CAN BE HEARD. 
  98  THE MIST RISES UP THROUGH A FISSURE IN THE CEILIN
  98 G.
  98   THE PATH EXITS TO THE SOUTH AND WEST.
  99 YOU ARE IN AN ALCOVE.  A SMALL NW PATH SEEMS TO WI
  99 DEN AFTER A SHORT DISTANCE.  AN EXTREMLY TIGHT TUN
  99 NEL LEADS EAST.  IT LOOKS LIKE A VERY TIGHT SQUEEZ
  99 E.  AN EERIE LIGHT CAN BE SEEN AT THE OTHER END.
 100 YOU'RE IN A SMALL CHAMBER LIT BY AN EERIE GREEN LI
 100 GHT.  AN EXTREMELY NARROW TUNNEL EXITS TO THE WEST
 100 .  A DARK CORRIDOR LEADS NE.
 101 YOU'RE IN THE DARK-ROOM.  A CORRIDOR LEADING SOUTH
 101  IS THE ONLY EXIT.
 102 YOU ARE IN AN ARCHED HALL.  A CORAL PASSAGE ONCE C
 102 ONTUINED UP AND EAST FROM HERE, BUT IS NOW BLOCKED
 102  BY DEBRIS.  THE AIR SMELLS OF SEA WATER.
 103 YOU'RE IN A LARGE ROOM CARVED OUT OF SEDIMENTARY R
 103 OCK.  THE FLOOR AND WALLS ARE LITTERED WITH BITS O
 103 F SHELLS IMBEDDED IN THE STONE.  A SHALLOW PASSAGE
 103  PROCEEDS DOWNWARD, AND A SOMEWHAT STEEPER ONE LEA
 103 DS UP.
 103   A LOW HANDS AND KNEES PASSAGE ENTERS FROM THE SO
 103 UTH.
 104 YOU ARE IN A LONG SLOPING CORRIDOR WITH RAGGED SHA
 104 RP WALLS.
 105 YOU ARE IN A CUL-DE-SAC ABOUT EIGHT FEET ACROSS.
 106 YOU ARE IN AN ANTEROOM LEADING TO A LARGE PASSAGE 
 106 TO THE EAST.  SMALL PASSAGES GO WEST AND UP.  THE 
 106 REMNANTS OF RECENT DIGGING ARE EVIDENT.  A SIGN IN
 106  MIDAIR HERE SAYS 'CAVE UNDER CONSTRUCTION BEYOND 
 106 THIS POINT.
 106   PROCEED AT OWN RISK. (WITT CONSTRUCTION COMPANY)
 106 '
 107 YOU ARE IN A MAZE OF TWISTY LITTLE PASSAGES, ALL D
 107 IFFERENT.
 108 YOU ARE AT WITT'S END.  PASSAGES LEAD OFF IN *ALL*
 108  DIRECTIONS.
 109 YOU ARE IN A NORTH/SOUTH CANYON ABOUT 25 FEET ACRO
 109 SS.  THE FLOOR IS COVERED BY WHITE MIST SEEPING IN
 109  FROM THE NORTH.  THE WALLS EXTEND UPWARD FOR WELL
 109  OVER 100 FEET.  SUSPENDED FROM SOME UNSEEN POINT 
 109 FAR ABOVE YOU,
 109  AN ENORMOUS TWO-SIDED MIRROR
 109  IS HANGING PARALLEL TO AND MIDWAY BETWEEN THE CAN
 109 YON WALLS.  (THE MIRROR IS OBVIOUSLY PROVIDED FOR 
 109 THE USE OF THE DWARVES, WHO AS YOU KNOW, ARE EXTRE
 109 MELY VAIN.)  A SMALL WINDOW CAN BE SEEN IN EITHER 
 109 WALL, SOME FIFTY FEET UP.
 110 YOU'R AT A LOW WINDOW OVERLOOKING A HUGE PIT, WHIC
 110 H EXTENDS UP OUT OF SIGHT.  A FLOOR IS INDISTINCTL
 110 Y VISIBLE OVER 50 FEET BELOW.  TRACES OF WHITE MIS
 110 T COVER THE FLOOR OF THE PIT, BECOMING THICKER TO 
 110 THE LEFT.
 110   MARKS IN THE DUST AROUND THE WINDOW WOULD SEEM
 110  TO INDICATE THAT SOMEONE HAS BEEN HERE RECENTLY. 
 110  DIRECTLY ACROSS THE PIT FROM YOU AND 25 FEET AWAY
 110  THERE IS A SIMILAR WINDOW LOOKING INTO A LIGHTED 
 110 ROOM.  A SHADOWY FIGURE CAN BE SEEN PEERING BACK A
 110 T YOU.
 111 A LARGE STALACTITE EXTENDS FROM THE ROOF AND ALMOS
 111 T REACHES THE FLOOR BELOW.  YOU COULD CLIMB DOWN I
 111 T, AND JUMP FROM IT TO THE FLOOR,BUT HAVING DONE S
 111 O YOU WOULD BE UNABLE TO REACH IT TO CLIMB BACK UP
 111 .
 112 YOU ARE IN A LITTLE MAZE OF TWISTING PASSAGES, ALL
 112  DIFFERENT.
 113 YOU ARE AT THE EDGE OF A LARGE UNDERGROUND RESERVO
 113 IR.  AN OPAQUE CLOUD OF WHITE MIST FILLS THE ROOM 
 113 AND RISES RAPIDLY UPWARD.  THE LAKE IS FED BY A ST
 113 REAM, WHICH TUMBLES OUT OF A HOLE IN THE WALL ABOU
 113 T 10 FEET OVERHEAD AND SPLASHES
 113  NOISILY INTO THE WATER SOMEWHERE WITHIN THE MIST.
 113   THE ONLY PASSAGE GOES BACK TOWARD THE SOUTH.
 114 DEAD END.
 115 YOU ARE AT THE NORTHEAST END OF AN IMMENSE ROOM, E
 115 VEN LARGER THAN THE GIANT ROOM.  IT APPEARS TO BE 
 115 A REPOSITORY FOR THE ADVENTURE PROGRAM.  MASSIVE T
 115 ORCHES FAR OVERHEAD BATHE THE ROOM WITH SMOKY YELL
 115 OW LIGHT.
 115   SCATTERED ABOUT YOU CAN BE SEEN A NUMBER OF BOTT
 115 LES (ALL OF THEM EMPTY),
 115  A NURSERY OF YOUNG BEANSTALKS MURMURING QUIETLY, 
 115 A BED OF OYSTERS, A BUNDLE OF BLACK RODS WITH RUST
 115 Y STARS ON THEIR ENDS, AND A COLLECTION OF BRASS L
 115 ANTERNS.  OFF TO ONE SIDE A GREAT MANY DWARVES ARE
 115  SLEEPING ON THE FLOOR, SNORING LOUDLY.  A SIGN NE
 115 ARBY READS 'DO NOT DISTURB DWARVES.'  AN IMMENSE M
 115 IRROR IS HANGING AGAINST ONE WALL, AND STRETCHES T
 115 O THE OTHER END OF THE ROOM,
 115  WHERE VARIOUS OTHER SUNDRY OBJECTS CAN BE GLIMPSE
 115 D DIMLY IN THE DISTANCE.
 116 YOU ARE AT THE SOUTHWEST END OF THE REPOSITORY.  T
 116 O ONE SIDE IS A PIT FULL OF FIERCE GREEN SNAKES.  
 116 ON THE OTHER SIDE IS A ROW OF SMALL WICKER CAGES, 
 116 EACH OF WHICH CONTAINS A LITTLE SULKING BIRD.
 116   IN ONE CORNER IS A BUNDLE OF BLACK RODS WITH RUS
 116 TY MARKS ON THEIR ENDS.
 116   A LARGE NUMBER OF VELVET PILLOWS ARE SCATTERED A
 116 BOUT ON THE FLOOR.  A VAST MIRROR STRETCHES OFF TO
 116  THE NORTHEAST.  AT YOUR FEET IS A LARGE STEEL GRA
 116 TE, NEXT TO WHICH IS A SIGN WHICH READS, 'TREASURE
 116  VAULT. KEYS IN MAIN OFFICE.'
 117 YOU ARE ON ONE SIDE OF A LARGE, DEEP CHASM.  A HEA
 117 VY WHITE MIST RISING UP FROM BELOW OBSCURES ALL VI
 117 EW OF THE FAR SIDE.  A SW PATH LEADS AWAY FROM THE
 117  CHASM INTO A WINDING CORRIDOR.
 118 YOU ARE IN A LONG WINDING CORRIDOR SLOPING OUT OF 
 118 SIGHT IN BOTH DIRECTIONS.
 119 YOU ARE IN A SECRET CANYON WHICH EXITS TO THE NORT
 119 H AND EAST.
 120 YOU ARE IN A SECRET CANYON WHICH EXITS TO THE NORT
 120 H AND EAST.
 121 YOU ARE IN A SECRET CANYON WHICH EXITS TO THE NORT
 121 H AND EAST.
 122 YOU ARE ON THE FAR SIDE OF THE CHASM.  A NE PATH L
 122 EADS AWAY FROM THE CHASM ON THIS SIDE.
 123 YOU'RE IN A LONG EAST/WEST CORRIDOR.  A FAINT RUMB
 123 LING NOISE CAN BE HEARD IN THE DISTANCE.
 124 THE PATH FORKS HERE.  THE LEFT FORK LEADS NORTHEAS
 124 T.  A DULL RUMBLING SEEMS TO GET LOUDER IN THAT DI
 124 RECTION.  THE RIGHT FORK LEADS SOUTHEAST DOWN A GE
 124 NTLE SLOPE.  THE MAIN CORRIDOR ENTERS FROM THE WES
 124 T.
 125 THE WALLS ARE QUITE WARM HERE.  FROM THE NORTH CAN
 125  BE HEARD A STEADY ROAR, SO LOUD THAT THE ENTIRE C
 125 AVE SEEMS TO BE TREMBLING.  ANOTHER PASSAGE LEADS 
 125 SOUTH, AND A LOW CRAWL GOES EAST.
 126 YOU ARE ON THE EDGE OF A BREATH TAKING VIEW.  FAR 
 126 BELOW YOU IS AN ACTIVE VOLCANO, FROM WHICH GREAT G
 126 OUTS OF MOULTEN LAVA COME SURGING OUT, CASCADING B
 126 ACK DOWN INTO THE DEPTHS.
 126   THE GLOWING ROCK FILLS THE FARTHEST REACHES OF T
 126 HE CAVERN WITH A BLOOD-RED GLARE, GIVING EVERYTHIN
 126 G AN EERIE, MACABRE APPEARANCE.
 126   THE AIR IS FILLED WITH FLICKERING SPARKS OF ASH 
 126 AND A HEAVY SMELL OF BRIMSTONE.  THE WALLS ARE HOT
 126  TO THE TOUCH, AND THE THUNDERING OF THE VOLCANO D
 126 ROWNS OUT ALL OTHER SOUNDS.
 126   EMBEDDED IN THE JAGGED ROOF FAR OVERHEAD ARE MYR
 126 IAD TWISTED FORMATIONS COMPOSED OF PURE WHITE ALAB
 126 ASTER, WHICH SCATTER THE MURKY LIGHT INTO SINISTER
 126  APPARITIONS UPON THE WALLS.
 126   TO ONE SIDE IS A DEEP GORGE, FILLED WITH A BIZAR
 126 RE CHAOS OF TORTURED ROCK WHICH SEEMS TO HAVE BEEN
 126  CRAFTED BY THE DEVIL HIMSELF.
 126   AN IMMENSE RIVER OF FIRE CRASHES OUT FROM THE DE
 126 PTHS OF THE VOLCANO, BURNS ITS WAY THROUGH THE GOR
 126 GE, AND PLUMMETS INTO A BOTTOMLESS PIT FAR OFF TO 
 126 YOUR LEFT.  TO THE RIGHT,
 126  AN IMMENSE GEYSER OF BLISTERING STEAM ERUPTS CONT
 126 INUOUSLY FROM A BARREN ISLAND IN THE CENTER OF A S
 126 ULPHOROUS LAKE, WHICH BUBBLES OMINOUSLY.  THE FAR 
 126 RIGHT WALL IS AFLAME WITH AN INCANDESCENCE OF ITS 
 126 OWN,
 126  WHICH LENDS AN ADDITIONAL INFERNAL SPLENDOR TO TH
 126 E ALREADY HELLISH SCENE.  A DARK FOREBODING PASSAG
 126 E EXITS TO THE SOUTH.
 127 YOU ARE IN A SMALL CHAMBER FILLED WITH LARGE BOULD
 127 ERS.  THE WALLS ARE VERY WARM, CAUSING THE AIR IN 
 127 THE ROOM TO BE ALMOST STIFLING FROM THE HEAT.  THE
 127  ONLY EXIT IS A CRAWL HEADING WEST, THROUGH WHICH 
 127 IS COMING LOW RUMBLING.
 128 YOU ARE WALKING ALONG A GENTLY SLOPING NORTH/SOUTH
 128  PASSAGE LINED WITH ODDLY SHAPED LIMESTONE FORMATI
 128 ONS.
 129 YOU ARE STANDING AT THE ENTRANCE TO A LARGE, BARRE
 129 N ROOM.  A SIGN POSTED ABOVE THE ENTRANCE READS 'C
 129 AUTION.  BEAR IN ROOM.'
 130 YOU ARE IN A BARREN ROOM.  THE CENTER OF THE ROOM 
 130 IS COMPLETELY EMPTY EXCEPT FOR SOME DUST.  MARKS I
 130 N THE DUST LEAD AWAY TOWARD THE FAR END OF THE ROO
 130 M.  THE ONLY EXIT IS THE WAY YOU CAME IN.
 131 YOU ARE IN A MAZE OF TWISTING LITTLE PASSAGES, ALL
 131  DIFFERENT.
 132 YOU ARE IN A LITTLE MAZE OF TWISTY PASSAGES, ALL D
 132 IFFERENT.
 133 YOU ARE IN A TWISTING MAZE OF LITTLE PASSAGES, ALL
 133  DIFFERENT.
 134 YOU ARE IN A TWISTING LITTLE MAZE OF PASSAGES, ALL
 134  DIFFERENT.
 135 YOU ARE IN A TWISTY LITTLE MAZE OF PASSAGES, ALL D
 135 IFFERENT.
 136 YOU ARE IN A TWISTY MAZE OF LITTLE PASSAGES, ALL D
 136 IFFERENT.
 137 YOU ARE IN A LITTLE TWISTY MAZE OF PASSAGES, ALL D
 137 IFFERENT.
 138 YOU ARE IN A MAZE OF LITTLE TWISTING PASSAGES, ALL
 138  DIFFERENT.
 139 YOU ARE IN A MAZE OF LITTLE TWISTY PASSAGES, ALL D
 139 IFFERENT.
 140 DEAD END.


========================================================================================
DOCUMENT :usus Folder:VOL09:advs10.text
========================================================================================

  85 YOU ARE OBVIOUSLY A RANK AMATEUR.  BETTER LUCK
  85  NEXT TIME.
 115 YOUR SCORE QUALIFIES YOU AS A NOVICE ADVENTURER.
 155 YOU HAVE ACHIEVED THE RATING: "EXPERIENCED ADVENTURER".
 190 YOU MAY NOW CONSIDER YOURSELF A "SEASONED ADVENTURER".
 240 YOU HAVE REACHED "JUNIOR MASTER" STATUS.
 280 YOUR SCORE PUTS YOU IN MASTER ADVENTURER CLASS C.
 315 YOUR SCORE PUTS YOU IN MASTER ADVENTURER CLASS B.
 345 YOUR SCORE PUTS YOU IN MASTER ADVENTURER CLASS A.
 350 ALL OF ADVENTUREDOM GIVES TRIBUTE TO YOU, ADVENTURER
 350  GRANDMASTER.


========================================================================================
DOCUMENT :usus Folder:VOL09:advs11.text
========================================================================================

 4   4   2  62  63
 5   5   2  18  19
 6   8   2  20  21
 7  75   4 176 177
 8  25   5 178 179
 9  20   3 180 181


========================================================================================
DOCUMENT :usus Folder:VOL09:advs2.text
========================================================================================

   1 YOU'RE AT END OF ROAD AGAIN.
   2 YOU'RE AT HILL IN ROAD.
   3 YOU'RE INSIDE BUILDING.
   4 YOU'RE IN VALLEY.
   5 YOU'RE IN FOREST.
   6 YOU'RE IN FOREST.
   7 YOU'RE AT SLIT IN STREAMBED.
   8 YOU'RE OUTSIDE GRATE.
   9 YOU'RE BELOW THE GRATE.
  10 YOU'RE IN COBBLE CRAWL.
  11 YOU'RE IN DEBRIS ROOM.
  13 YOU'RE IN BIRD CHAMBER.
  14 YOU'RE AT TOP OF SMALL PIT.
  15 YOU'RE IN HALL OF MISTS.
  17 YOU'RE ON EAST BANK OF FISSURE.
  18 YOU'RE IN NUGGET OF GOLD ROOM.
  19 YOU'RE IN HALL OF MT KING.
  23 YOU'RE AT WEST END OF TWOPIT ROOM.
  24 YOU'RE IN EAST PIT.
  25 YOU'RE IN WEST PIT.
  33 YOU'RE AT 'Y2'.
  35 YOU'RE AT WINDOW ON PIT.
  36 YOU'RE IN DIRTY PASSAGE.
  39 YOU'RE IN DUSTY ROCK ROOM.
  41 YOU'RE AT WEST END OF HALL OF MISTS.
  57 YOU'RE AT BRINK OF PIT.
  60 YOU'RE AT EAST END OF LONG HALL.
  61 YOU'RE AT WEST END OF LONG HALL.
  64 YOU'RE AT COMPLEX JUNCTION.
  66 YOU'RE IN SWISS CHEESE ROOM.
  67 YOU'RE AT EAST END OF TWOPIT ROOM.
  68 YOU'RE IN SLAB ROOM.
  71 YOU'RE AT JUNCTION OF THREE SECRET CANYONS.
  74 YOU'RE IN SECRET E/W CANYON ABOVE TIGHT CANYON.
  88 YOU'RE IN NARROW CORRIDOR.
  91 YOU'RE AT STEEP INCLINE ABOVE LARGE ROOM.
  92 YOU'RE IN GIANT ROOM.
  95 YOU'RE IN CAVERN WITH WATERFALL.
  96 YOU'RE IN SOFT ROOM.
  97 YOU'RE IN ORIENTAL ROOM.
  98 YOU'RE IN MISTY CAVERN.
  99 YOU'RE IN ALCOVE.
 100 YOU'RE IN PLOVER ROOM.
 101 YOU'RE IN DARK ROOM.
 102 YOU'RE IN ARCHED HALL.
 103 YOU'RE IN SHELL ROOM.
 106 YOU'RE IN ANTEROOM.
 108 YOU'RE AT WITT'S END.
 109 YOU'RE IN MIRROR CANYON.
 110 YOU'RE AT WINDOW ON PIT.
 111 YOU'RE AT TOP OF STALACTITE.
 113 YOU'RE AT RESERVOIR.
 115 YOU'RE AT NE END.
 116 YOU'RE AT SW END.
 117 YOU'RE ON SW SIDE OF CHASM.
 118 YOU'RE IN SLOPING CORRIDOR.
 122 YOU'RE ON NE SIDE OF CHASM.
 123 YOU'RE IN CORRIDOR.
 124 YOU'RE AT FORK IN PATH.
 125 YOU'RE AT JUNCTION WITH WARM WALLS.
 126 YOU'RE AT BREATH TAKING VIEW.
 127 YOU'RE IN CHAMBER OF BOULDERS.
 128 YOU'RE IN LIMESTONE PASSAGE.
 129 YOU'RE IN FRONT OF BARREN ROOM.
 130 YOU'RE IN BARREN ROOM.
 

========================================================================================
DOCUMENT :usus Folder:VOL09:advs3.text
========================================================================================

  1   0   2   2  44  29 
  1   0   3   3  12  19  43 
  1   0   4   5  13  14  46  30 
  1   0   5   6  45  43 
  1   0   8  63 
  2   0   1   2  12   7  43  45  30 
  2   0   5   6  45  46 
  3   0   1   3  11  32  44 
  3   0  11  62 
  3   0  33  65 
  3   0  79   5  14 
  4   0   1   4  12  45 
  4   0   5   6  43  44  29 
  4   0   7   5  46  30 
  4   0   8  63 
  5   0   4   9  43  30 
  5  50   5   6   7  45 
  5   0   6   6 
  5   0   5  44  46 
  6   0   1   2  45 
  6   0   4   9  43  44  30 
  6   0   5   6  46 
  7   0   1  12 
  7   0   4   4  45 
  7   0   5   6  43  44 
  7   0   8   5  15  16  46 
  7   0 595  60  14  30 
  8   0   5   6  43  44  46 
  8   0   1  12 
  8   0   7   4  13  45 
  8 303   9   3  19  30 
  8   0 593   3 
  9 303   8  11  29 
  9   0 593  11 
  9   0  10  17  18  19  44 
  9   0  14  31 
  9   0  11  51 
 10   0   9  11  20  21  43 
 10   0  11  19  22  44  51 
 10   0  14  31 
 11 303   8  63 
 11   0   9  64 
 11   0  10  17  18  23  24  43 
 11   0  12  25  19  29  44 
 11   0   3  62 
 11   0  14  31 
 12 303   8  63 
 12   0   9  64 
 12   0  11  30  43  51 
 12   0  13  19  29  44 
 12   0  14  31 
 13 303   8  63 
 13   0   9  64 
 13   0  11  51 
 13   0  12  25  43 
 13   0  14  23  31  44 
 14 303   8  63 
 14   0   9  64 
 14   0  11  51 
 14   0  13  23  43 
 14 150  20  30  31  34 
 14   0  15  30 
 14   0  16  33  44 
 15   0  18  36  46 
 15   0  17   7  38  44 
 15   0  19  10  30  45 
 15 150  22  29  31  34  35  23  43 
 15   0  14  29 
 15   0  34  55 
 16   0  14   1 
 17   0  15  38  43 
 17 312 596  39 
 17 412  21   7 
 17 412 597  41  42  44  69 
 17   0  27  41 
 18   0  15  38  11  45 
 19   0  15  10  29  43 
 19 311  28  45  36 
 19 311  29  46  37 
 19 311  30  44   7 
 19   0  32  45 
 19  35  74  49 
 19 211  32  49 
 19   0  74  66 
 20   0   0   1 
 21   0   0   1 
 22   0  15   1 
 23   0  67  43  42 
 23   0  68  44  61 
 23   0  25  30  31 
 23   0 648  52 
 24   0  67  29  11 
 25   0  23  29  11 
 25 724  31  56 
 25   0  26  56 
 26   0  88   1 
 27 312 596  39 
 27 412  21   7 
 27 412 597  41  42  43  69 
 27   0  17  41 
 27   0  40  45 
 27   0  41  44 
 28   0  19  38  11  46 
 28   0  33  45  55 
 28   0  36  30  52 
 29   0  19  38  11  45 
 30   0  19  38  11  43 
 30   0  62  44  29 
 31 524  89   1 
 31   0  90   1 
 32   0  19   1 
 33   0   3  65 
 33   0  28  46 
 33   0  34  43  53  54 
 33   0  35  44 
 33 159 302  71 
 33   0 100  71 
 34   0  33  30  55 
 34   0  15  29 
 35   0  33  43  55 
 35   0  20  39 
 36   0  37  43  17 
 36   0  28  29  52 
 36   0  39  44 
 36   0  65  70 
 37   0  36  44  17 
 37   0  38  30  31  56 
 38   0  37  56  29  11 
 38   0 595  60  14  30   4   5 
 39   0  36  43  23 
 39   0  64  30  52  58 
 39   0  65  70 
 40   0  41   1 
 41   0  42  46  29  23  56 
 41   0  27  43 
 41   0  59  45 
 41   0  60  44  17 
 42   0  41  29 
 42   0  42  45 
 42   0  43  43 
 42   0  45  46 
 42   0  80  44 
 43   0  42  44 
 43   0  44  46 
 43   0  45  43 
 44   0  43  43 
 44   0  48  30 
 44   0  50  46 
 44   0  82  45 
 45   0  42  44 
 45   0  43  45 
 45   0  46  43 
 45   0  47  46 
 45   0  87  29  30 
 46   0  45  44  11 
 47   0  45  43  11 
 48   0  44  29  11 
 49   0  50  43 
 49   0  51  44 
 50   0  44  43 
 50   0  49  44 
 50   0  51  30 
 50   0  52  46 
 51   0  49  44 
 51   0  50  29 
 51   0  52  43 
 51   0  53  46 
 52   0  50  44 
 52   0  51  43 
 52   0  52  46 
 52   0  53  29 
 52   0  55  45 
 52   0  86  30 
 53   0  51  44 
 53   0  52  45 
 53   0  54  46 
 54   0  53  44  11 
 55   0  52  44 
 55   0  55  45 
 55   0  56  30 
 55   0  57  43 
 56   0  55  29  11 
 57   0  13  30  56 
 57   0  55  44 
 57   0  58  46 
 57   0  83  45 
 57   0  84  43 
 58   0  57  43  11 
 59   0  27   1 
 60   0  41  43  29  17 
 60   0  61  44 
 60   0  62  45  30  52 
 61   0  60  43 
 61   0  62  45 
 61 100 107  46 
 62   0  60  44 
 62   0  63  45 
 62   0  30  43 
 62   0  61  46 
 63   0  62  46  11 
 64   0  39  29  56  59 
 64   0  65  44  70 
 64   0 103  45  74 
 64   0 106  43 
 65   0  64  43 
 65   0  66  44 
 65  80 556  46 
 65   0  68  61 
 65  80 556  29 
 65  50  70  29 
 65   0  39  29 
 65  60 556  45 
 65  75  72  45 
 65   0  71  45 
 65  80 556  30 
 65   0 106  30 
 66   0  65  47 
 66   0  67  44 
 66  80 556  46 
 66   0  77  25 
 66   0  96  43 
 66  50 556  50 
 66   0  97  72 
 67   0  66  43 
 67   0  23  44  42 
 67   0  24  30  31 
 68   0  23  46 
 68   0  69  29  56 
 68   0  65  45 
 69   0  68  30  61 
 69 331 120  46 
 69   0 119  46 
 69   0 109  45 
 69   0 113  75 
 70   0  71  45 
 70   0  65  30  23 
 70   0 111  46 
 71   0  65  48 
 71   0  70  46 
 71   0 110  45 
 72   0  65  70 
 72   0 118  49 
 72   0  73  45 
 72   0  97  48 
 73   0  72  46  17  11 
 74   0  19  43 
 74 331 120  44 
 74   0 121  44 
 74   0  75  30 
 75   0  76  46 
 75   0  77  45 
 76   0  75  45 
 77   0  75  43 
 77   0  78  44 
 77   0  66  45  17 
 78   0  77  46 
 79   0   3   1 
 80   0  42  45 
 80   0  80  44  46 
 80   0  81  43 
 81   0  80  44  11 
 82   0  44  46  11 
 83   0  57  46 
 83   0  84  43 
 83   0  85  44 
 84   0  57  45 
 84   0  83  44 
 84   0 114  50 
 85   0  83  43  11 
 86   0  52  29  11 
 87   0  45  29  30 
 88   0  25  30  56  43 
 88   0  20  39 
 88   0  92  44  27 
 89   0  25   1 
 90   0  23   1 
 91   0  95  45  73  23 
 91   0  72  30  56 
 92   0  88  46 
 92   0  93  43 
 92   0  94  45 
 93   0  92  46  27  11 
 94   0  92  46  27  23 
 94 309  95  45   3  73 
 94   0 611  45 
 95   0  94  46  11 
 95   0  92  27 
 95   0  91  44 
 96   0  66  44  11 
 97   0  66  48 
 97   0  72  44  17 
 97   0  98  29  45  73 
 98   0  97  46  72 
 98   0  99  44 
 99   0  98  50  73 
 99   0 301  43  23 
 99   0 100  43 
100   0 301  44  23  11 
100   0  99  44 
100 159 302  71 
100   0  33  71 
100   0 101  47  22 
101   0 100  46  71  11 
102   0 103  30  74  11 
103   0 102  29  38 
103   0 104  30 
103 114 618  46 
103 115 619  46 
103   0  64  46 
104   0 103  29  74 
104   0 105  30 
105   0 104  29  11 
105   0 103  74 
106   0  64  29 
106   0  65  44 
106   0 108  43 
107   0 131  46 
107   0 132  49 
107   0 133  47 
107   0 134  48 
107   0 135  29 
107   0 136  50 
107   0 137  43 
107   0 138  44 
107   0 139  45 
107   0  61  30 
108  95 556  43  45  46  47  48  49  50  29  30 
108   0 106  43 
108   0 626  44 
109   0  69  46 
109   0 113  45  75 
110   0  71  44 
110   0  20  39 
111   0  70  45 
111  40  50  30  39  56 
111  50  53  30 
111   0  45  30 
112   0 131  49 
112   0 132  45 
112   0 133  43 
112   0 134  50 
112   0 135  48 
112   0 136  47 
112   0 137  44 
112   0 138  30 
112   0 139  29 
112   0 140  46 
113   0 109  46  11 109 
114   0  84  48 
115   0 116  49 
116   0 115  47 
116   0 593  30 
117   0 118  49 
117 233 660  41  42  69  47 
117 332 661  41 
117   0 303  41 
117 332  21  39 
117   0 596  39 
118   0  72  30 
118   0 117  29 
119   0  69  45  11 
119   0 653  43   7 
120   0  69  45 
120   0  74  43 
121   0  74  43  11 
121   0 653  45   7 
122   0 123  47 
122 233 660  41  42  69  49 
122   0 303  41 
122   0 596  39 
122   0 124  77 
122   0 126  28 
122   0 129  40 
123   0 122  44 
123   0 124  43  77 
123   0 126  28 
123   0 129  40 
124   0 123  44 
124   0 125  47  36 
124   0 128  48  37  30 
124   0 126  28 
124   0 129  40 
125   0 124  46  77 
125   0 126  45  28 
125   0 127  43  17 
126   0 125  46  23  11 
126   0 124  77 
126   0 610  30  39 
127   0 125  44  11  17 
127   0 124  77 
127   0 126  28 
128   0 124  45  29  77 
128   0 129  46  30  40 
128   0 126  28 
129   0 128  44  29 
129   0 124  77 
129   0 130  43  19  40   3 
129   0 126  28 
130   0 129  44  11 
130   0 124  77 
130   0 126  28 
131   0 107  44 
131   0 132  48 
131   0 133  50 
131   0 134  49 
131   0 135  47 
131   0 136  29 
131   0 137  30 
131   0 138  45 
131   0 139  46 
131   0 112  43 
132   0 107  50 
132   0 131  29 
132   0 133  45 
132   0 134  46 
132   0 135  44 
132   0 136  49 
132   0 137  47 
132   0 138  43 
132   0 139  30 
132   0 112  48 
133   0 107  29 
133   0 131  30 
133   0 132  44 
133   0 134  47 
133   0 135  49 
133   0 136  43 
133   0 137  45 
133   0 138  50 
133   0 139  48 
133   0 112  46 
134   0 107  47 
134   0 131  45 
134   0 132  50 
134   0 133  48 
134   0 135  43 
134   0 136  30 
134   0 137  46 
134   0 138  29 
134   0 139  44 
134   0 112  49 
135   0 107  45 
135   0 131  48 
135   0 132  30 
135   0 133  46 
135   0 134  43 
135   0 136  44 
135   0 137  49 
135   0 138  47 
135   0 139  50 
135   0 112  29 
136   0 107  43 
136   0 131  44 
136   0 132  29 
136   0 133  49 
136   0 134  30 
136   0 135  46 
136   0 137  50 
136   0 138  48 
136   0 139  47 
136   0 112  45 
137   0 107  48 
137   0 131  47 
137   0 132  46 
137   0 133  30 
137   0 134  29 
137   0 135  50 
137   0 136  45 
137   0 138  49 
137   0 139  43 
137   0 112  44 
138   0 107  30 
138   0 131  43 
138   0 132  47 
138   0 133  29 
138   0 134  44 
138   0 135  45 
138   0 136  46 
138   0 137  48 
138   0 139  49 
138   0 112  50 
139   0 107  49 
139   0 131  50 
139   0 132  43 
139   0 133  44 
139   0 134  45 
139   0 135  30 
139   0 136  48 
139   0 137  29 
139   0 138  46 
139   0 112  47 
140   0 112  45  11 


========================================================================================
DOCUMENT :usus Folder:VOL09:advs4.text
========================================================================================

 1016 'SPEL
 3051 ?
   29 ABOVE
 3050 ABRA
 3050 ABRAC
   42 ACROS
   29 ASCEN
 2012 ATTAC
   26 AWKWA
 1028 AXE
    8 BACK
   40 BARRE
 1052 BARS
 1039 BATTE
 1024 BEANS
 1035 BEAR
   16 BED
   70 BEDQU
 1008 BIRD
 2023 BLAST
 2023 BLOWU
 1020 BOTTL
 1055 BOX
 2028 BREAK
 2026 BRIEF
   54 BROKE
   12 BUILD
 1004 CAGE
 2010 CALM
   25 CANYO
 1040 CARPE
 2001 CARRY
 2001 CATCH
   67 CAVE
   73 CAVER
 1064 CHAIN
 2003 CHANT
 1032 CHASM
 1055 CHEST
 1014 CLAM
   56 CLIMB
 2006 CLOSE
   18 COBBL
 1054 COINS
    7 CONTI
 2011 CONTI
   33 CRACK
   17 CRAWL
   69 CROSS
   30 D
   22 DARK
   51 DEBRI
   63 DEPRE
   30 DESCE
   57 DESCR
 2023 DETON
 2014 DEVOU
 1051 DIAMO
 3066 DIG
 2002 DISCA
 2029 DISTU
   35 DOME
 1009 DOOR
   30 DOWN
    5 DOWNS
   30 DOWNW
 1031 DRAGO
 1029 DRAWI
 2015 DRINK
 2002 DROP
 2002 DUMP
 1017 DWARF
 1017 DWARV
   43 E
   43 EAST
 2014 EAT
 1056 EGG
 1056 EGGS
 1059 EMERA
    3 ENTER
   64 ENTRA
   57 EXAMI
 3066 EXCAV
   11 EXIT
 2011 EXPLO
 2008 EXTIN
 2025 FEE
 3001 FEE
 2021 FEED
 2025 FIE
 3002 FIE
 2012 FIGHT
 1027 FIGUR
 2022 FILL
 2019 FIND
 1012 FISSU
   58 FLOOR
 2025 FOE
 3003 FOE
 2011 FOLLO
 2025 FOO
 3004 FOO
 1019 FOOD
    6 FORES
   77 FORK
    7 FORWA
 2002 FREE
 3079 FUCK
 2025 FUM
 3005 FUM
 2001 GET
 1037 GEYSE
   27 GIANT
 2011 GO
 1050 GOLD
 2011 GOTO
 1003 GRATE
   13 GULLY
 1021 H2O
   38 HALL
 1002 HEADL
 3051 HELP
    2 HILL
 2012 HIT
 3050 HOCUS
   52 HOLE
   12 HOUSE
 2023 IGNIT
   19 IN
 3142 INFO
 3142 INFOR
   19 INSID
 2020 INVEN
   19 INWAR
 1016 ISSUE
 1020 JAR
 1053 JEWEL
   39 JUMP
 2001 KEEP
 1001 KEY
 1001 KEYS
 2012 KILL
 1018 KNIFE
 1018 KNIVE
 1002 LAMP
 1002 LANTE
   11 LEAVE
   36 LEFT
 2007 LIGHT
 2006 LOCK
   57 LOOK
 3068 LOST
   24 LOW
 1038 MACHI
 1016 MAGAZ
   76 MAIN
 1036 MESSA
 1058 MING
 1023 MIRRO
 3069 MIST
 1040 MOSS
 2003 MUMBL
   45 N
   47 NE
 1056 NEST
   45 NORTH
 2005 NOTHI
   21 NOWHE
 1050 NUGGE
   21 NULL
   50 NW
 2008 OFF
   76 OFFIC
 1022 OIL
 2007 ON
    7 ONWAR
 2004 OPEN
 3050 OPENS
   72 ORIEN
   11 OUT
   32 OUTDO
   11 OUTSI
   41 OVER
 1015 OYSTE
   23 PASSA
 1061 PEARL
 1062 PERSI
 1010 PILLO
 1030 PIRAT
   31 PIT
 2010 PLACA
 1024 PLANT
 1025 PLANT
 1060 PLATI
   71 PLOVE
   65 PLUGH
 3050 POCUS
 1058 POTTE
 2013 POUR
 2011 PROCE
 2027 PURUS
 1060 PYRAM
 2018 QUIT
 1019 RATIO
 2027 READ
 2002 RELEA
   75 RESER
    8 RETRE
    8 RETUR
   37 RIGHT
    2 ROAD
   15 ROCK
 1005 ROD
 1006 ROD
   59 ROOM
 2016 RUB
 1062 RUG
 2011 RUN
   46 S
 2030 SAVE
 2003 SAY
 2024 SCORE
   48 SE
   66 SECRE
 3050 SESAM
 1027 SHADO
 2009 SHAKE
 1058 SHARD
 2028 SHATT
 3050 SHAZA
   74 SHELL
 1052 SILVE
 2003 SING
   61 SLAB
   61 SLABR
 2012 SLAY
   60 SLIT
 2028 SMASH
 1011 SNAKE
   46 SOUTH
 1016 SPELU
 1063 SPICE
   10 STAIR
 1026 STALA
 2001 STEAL
   34 STEPS
 1007 STEPS
 3139 STOP
   14 STREA
 2012 STRIK
   20 SURFA
 2030 SUSPE
   49 SW
 3147 SWIM
 2009 SWING
 1013 TABLE
 2001 TAKE
 2010 TAME
 2017 THROW
 2017 TOSS
 2001 TOTE
   57 TOUCH
 2011 TRAVE
 1055 TREAS
 3064 TREE
 3064 TREES
 1057 TRIDE
 1033 TROLL
 1034 TROLL
   23 TUNNE
 2011 TURN
   29 U
 2004 UNLOC
   29 UP
    4 UPSTR
   29 UPWAR
 2003 UTTER
    9 VALLE
 1058 VASE
 1010 VELVE
 1038 VENDI
   28 VIEW
 1037 VOLCA
   44 W
 2029 WAKE
 2011 WALK
   53 WALL
 1021 WATER
 2009 WAVE
   44 WEST
 2019 WHERE
   62 XYZZY
   55 Y2
   

========================================================================================
DOCUMENT :usus Folder:VOL09:advs5.text
========================================================================================

   1 SET OF KEYS
   0 THERE ARE SOME KEYS ON THE GROUND HERE.
   2 BRASS LANTERN
   0 THERE IS A SHINY BRASS LAMP NEARBY.
 100 THERE IS A LAMP SHINING NEARBY.
   3 *GRATE
   0 THE GRATE IS LOCKED.
 100 THE GRATE IS OPEN.
   4 WICKER CAGE
   0 THERE IS A SMALL WICKER CAGE DISCARDED NEARBY.
   5 BLACK ROD
   0 A THREE FOOT BLACK ROD WITH A RUSTY STAR ON AN END
   0  LIES NEARBY.
   6 BLACK ROD
   0 A THREE FOOT BLACK ROD WITH A RUSTY MARK ON AN END
   0  LIES NEARBY.
   7 *STEPS
   0 ROUGH STONE STEPS LEAD DOWN THE PIT.
 100 ROUGH STONE STEPS LEAD UP THE DOME.
   8 LITTLE BIRD IN CAGE
   0 A CHEERFUL LITTLE BIRD IS SITTING HERE SINGING.
 100 THERE IS A LITTLE BIRD IN THE CAGE.
   9 *RUSTY DOOR
   0 THE WAY NORTH IS BARRED BY A MASSIVE, RUSTY, IRON 
   0 DOOR.
 100 THE WAY NORTH LEADS THROUGH A MASSIVE, RUSTY, IRON
 100  DOOR.
  10 VELVET PILLOW
   0 A VELVET PILLOW LIES ON THE FLOOR.
  11 *SNAKE
   0 A HUGE GREEN FIERCE SNAKE BARS THE WAY.
 100  
  12 *FISSURE
   0 
 100 A CRYSTAL BRIDGE NOW SPANS THE FISSURE.
 200 THE CRYSTAL BRIDGE HAS VANISHED.
  13 *STONE TABLET
   0 A MASSIVE STONE TABLET IMBEDDED IN THE WALL READS 
   0 'CONGRATULATIONS ON BRINGING LIGHT INTO THE DARK-R
   0 OOM.
  14 GIANT CLAM >GRUNT.<
   0 THERE IS AN ENORMOUS CLAM HERE WITH ITS SHELL TIGH
   0 TLY CLOSED.
  15 GIANT OYSTER >GROAN<.
   0 THERE IS AN ENORMOUS OYSTER HERE WITH ITS SHELL TI
   0 GHTLY CLOSED.
 100 INTERESTING.  THERE SEEMS TO BE SOMETHING WRITTEN 
 100 ON THE UNDERSIDE OF THE OYSTER.
  16 'SPELUNKER TODAY'
   0 THERE ARE A FEW RECENT ISSUES OF 'SPELUNKER TODAY'
   0  MAGAZINE HERE.
  19 TASTY FOOD
   0 THERE IS FOOD HERE.
  20 SMALL BOTTLE
   0 THERE IS A BOTTLE OF WATER HERE.
 100 THERE IN AN EMPTY BOTTLE HERE.
 200 THERE IS A BOTTLE OF OIL HERE.
  21 WATER IN THE BOTTLE
  22 OIL IN THE BOTTLE
  23 MIRROR
   0 
  24 PLANT
   0 THERE IS A TINY LITTLE PLANT IN THE PIT, MURMURMIN
   0 G WATER, WATER,...
 100 THE PLANT SPURTS INTO FURIOUS GROWTH FOR A FEW SEC
 100 ONDS.
 200 THERE IS A TWELVE FOOT TALL BEANSTALK STRETCHING U
 200 P OUT OF THE PIT, BELLOWING WATER!! WATER!!
 300 THE PLANT GROWS EXPLOSIVELY, ALMOST FILLING THE BO
 300 TTOM OF THE PIT.
 400 THERE IS A GIGANTIC BEANSTALK STRETCHING ALL THE W
 400 AY UP TO THE HOLE.
 500 YOU'VE OVER WATERED THE PLANT.  IT'S SHIRVELING UP
 500 .  IT'S, IT'S...
  25 *PHONY PLANT
   0 
 100 THE TOP OF A TWELVE FOOT TALL BEANSTALK IS POKING 
 100 OUT OF THE WEST PIT.
 200 THERE IS A HUGE BEANSTALK GROWING OUT OF THE WEST 
 200 PIT UP TO THE HOLE.
  26 *STALACTITE
   0 
  27 *SHADOWY FIGURE
   0 THE SHADOWY FIGURE SEEMS TO BE TRYING TO ATTRACT Y
   0 OUR ATTENTION.
  28 DWARF'S AXE
   0 THERE IS A LITTLE AXE HERE.
 100 THERE IS A LITTLE AXE LYING BESIDE THE BEAR.
  29 *CAVE DRAWINGS
   0 
  30 *PIRATE
   0 
  31 *DRAGON
   0 A HUGE GREEN DRAGON BARS THE WAY.
 100 CONGRATULATIONS.  YOU HAVE JUST VANQUISHED A DRAGO
 100 N WITH YOUR BARE HANDS.  (UNBELIEVABLE, ISN'T IT?)
 200 THE BODY OF A HUGE GREEN DEAD DRAGON IS LYING OFF 
 200 TO ONE SIDE.
  32 *CHASM
   0 A RICKETY WOODEN BRIDGE EXTENDS ACROSS THE CHASM, 
   0 VANISHING INTO THE MIST ON THE OTHER SIDE.  A SIGN
   0  POSTED ON THE BRIDGE READS, 'STOP. PAY TROLL.'
 100 THE WRECKAGE OF A BRIDGE (AND A DEAD BEAR) CAN BE 
 100 SEEN AT THE BOTTOM OF THE CHASM.
  33 *TROLL
   0 A BURLY TROLL STANDS BY THE BRIDGE AND INSISTS THA
   0 T YOU THROW HIM A TREASURE BEFORE YOU MAY CROSS.
 100 THE TROLL STEPS OUT FROM BENEATH THE BRIDGE AND BL
 100 OCKS YOUR WAY.
 200  
  34 *PHONY TROLL
   0 THE TROLL IS NOWHERE TO BE SEEN.
  35  
   0 THERE IS A FEROCIOUS CAVE BEAR EYING YOU FROM THE 
   0 FAR END OF THE ROOM.
 100 THERE IS A GENTLE CAVE BEAR SITTING PLACIDLY IN ON
 100 E CORNER.
 200 THERE IS A CONTENTED LOOKING BEAR WANDERING ABOUT 
 200 NEARBY.
 300  
  36 *2ND MAZE MSG
   0 THERE IS A MESSAGE SCRAWLED IN THE DUST IN A FLOWE
   0 RY SCRIPT, READING 'THIS IS NOT THE MAZE WHERE THE
   0  PIRATE LEAVES HIS TREASURE CHEST'.
  37 *VOLCANO
   0 
  38 *VENDING MACHINE
   0 THERE IS A MASSIVE VENDING MACHINE HERE.  THE INST
   0 RUCTIONS ON IT READ 'DROP COINS HERE TO RECEIVE FR
   0 ESH BATTERIES'.
  39 BATTERIES
   0 THERE ARE FRESH BATTERIES HERE.
 100 SOME WORN OUT BATTERIES HAVE BEEN DISCARDED NEARBY
 100 .
  40 *CARPET/MOSS
   0 
  50 LARGE GOLD NUGGET
   0 THERE IS A LARGE SPARKLING NUGGET OF GOLD HERE!
  51 SEVERAL DIAMONDS
   0 THERE ARE DIAMONDS HERE!
  52 BARS OF SILVER
   0 THERE ARE BARS OF SILVER HERE!
  53 PRECIOUS JEWELRY
   0 THERE IS PRECIOUS JEWELRY HERE!
  54 RARE COINS
   0 THERE ARE MANY COINS HERE!
  55 TREASURE CHEST
   0 THE PIRATE'S TREASURE CHEST IS HERE!
  56 GOLDEN EGGS
   0 THERE IS A LARGE NEST HERE, FULL OF GOLDEN EGGS!
 100 THE NEST OF GOLDEN EGGS HAS VANISHED.
 200 DONE.
  57 JEWELED TRIDENT
   0 THERE IS A JEWEL ENCRUSTED TRIDENT HERE!
  58 MING VASE
   0 THERE IS A DELICATE, PRECIOUS MING VASE HERE!
 100 THE VASE IS NOW RESTING, DELICATLY, ON A VELVET PI
 100 LLOW.
 200 THE FLOOR IS LITTERED WITH WORTHLESS SHARDS OF POT
 200 TERY.
 300 THE MING VASE DROPS WITH A DELICATE CRASH.
  59 EGG SIZED EMERALD
   0 THERE IS A EMERALD HERE THE SIZE OF A PLOVER'S EGG
   0 !
  60 PLATINUM PYRAMID
   0 THERE IS A PLATINUM PYRAMID HERE, 8 INCHES ON A SI
   0 DE!
  61 GLISTENING PEARL
   0 OFF TO ONE SIDE LIES A GLISTENING PEARL!
  62 PERSIAN RUG
   0 THERE IS A PERSIAN RUG SPREAD OUT ON THE FLOOR!
 100 THE DRAGON IS SPRAWLED OUT ON A PERSIAN RUG.
  63 RARE SPICES
   0 THERE ARE RARE SPICES HERE!
  64 GOLDEN CHAIN
   0 THERE IS A GOLDEN CHAIN LYING IN A HEAP ON THE FLO
   0 OR.
 100 THE BEAR IS LOCKED TO THE WALL WITH A GOLDEN CHAIN
 100 .
 200 THERE IS A GOLDEN CHAIN LOCKED TO THE WALL.
 

========================================================================================
DOCUMENT :usus Folder:VOL09:advs6.text
========================================================================================

   1 SOMEWHERE NEARBY IS COLOSSAL CAVE, WHERE OTHERS HA
   1 VE FOUND FORTUNES IN TREASURE AND GOLD, THOUGH IT 
   1 IS RUMORED THAT SOME WHO ENTER ARE NEVER SEEN AGAI
   1 N.  MAGIC IS SAID TO WORK IN THE CAVE.
   1   I WILL BE YOUR EYES AND HANDS.  DIRECT ME WITH C
   1 OMMANDS OF ONE OR TWO WORDS.
   1   I SHOULD WARN YOU THAT I LOOK AT ONLY THE FIRST 
   1 FIVE LETTERS OF EACH WORD, SO THAT YOU'LL HAVE TO 
   1 ENTER 'NORTHEAST' AS 'NE' TO DISTINGUISH IT FROM '
   1 NORTH'.  (SHOULD YOU GET STUCK, TYPE 'HELP' FOR SO
   1 ME GENERAL HINTS.
   2 A LITTLE DWARF WITH A BIG KNIFE BLOCKS YOUR WAY.
   3 A LITTLE DWARF JUST WALKED AROUND A CORNER, SAW YO
   3 U, THREW A LITTLE AXE AT YOU WHICH MISSED, CURSED,
   3  AND RAN AWAY.
   4 THERE IS A THREATENING LITTLE DWARF IN THE ROOM WI
   4 TH YOU.
   5 ONE SHARP NASTY KNIFE IS THROWN AT YOU.
   6 NONE OF THEM HIT YOU.
   7 ONE OF THEM GETS YOU.
   8 A HOLLOW VOICE SAYS 'PLUGH'.
   9 THERE IS NO WAY TO GO IN THAT DIRECTION.
  10 I AM UNSURE HOW YOU ARE FACING.  USE COMPASS POINT
  10 S OR NEARBY OBJECTS.
  11 I DON'T KNOW IN FROM OUT HERE.  USE COMPASS POINTS
  11  OR NAME SOMETHING IN THE GENERAL DIRECTION YOU WA
  11 NT TO GO.
  12 I DON'T KNOW HOW TO APPLY THAT WORD HERE.
  13 I DON'T UNDERSTAND THAT.
  14 I'M GAME.  WOULD YOU CARE TO EXPLAIN HOW?
  15 SORRY, BUT I AM NOT ALLOWED TO GIVE MORE DETAIL.  
  15 I WILL REPEAT THE LONG DESCRIPTION OF YOUR LOCATIO
  15 N.
  16 IT IS NOW PITCH DARK.  IF YOU PROCEED YOU WILL LIK
  16 ELY FALL INTO A PIT.
  17 IF YOU PREFER, SIMPLY TYPE W RATHER THAN WEST.
  18 ARE YOU TRYING TO CATCH THE BIRD?
  19 THE BIRD IS FRIGHTENED NOW AND YOU CANNOT CATCH IT
  19  NO MATTER WHAT YOU TRY.  PERHAPS YOU MIGHT TRY LA
  19 TER.
  20 ARE YOU TRYING TO SOMEHOW DEAL WITH THE SNAKE?
  21 YOU CAN'T KILL THE SNAKE, OR DRIVE IT AWAY, OR AVO
  21 ID IT, OR ANYTHING LIKE THAT.  THERE IS A WAY TO G
  21 ET BY, BUT YOU DON'T HAVE THE NECESSARY RESOURCES 
  21 RIGHT NOW.
  22 DO YOU REALLY WANT TO QUIT NOW?
  23 YOU FELL INTO A PIT AND BROKE EVERY BONE IN YOUR B
  23 ODY.
  24 YOU ARE ALREADY CARRYING IT.
  25 YOU CAN'T BE SERIOUS.
  26 THE BIRD WAS UNAFRAID WHEN YOU ENTERED, BUT AS YOU
  26  APPROACH IT BECOMES DISTURBED AND YOU CAN'T CATCH
  26  IT.
  27 YOU CAN CATCH THE BIRD, BUT YOU CANNOT CARRY IT.
  28 THERE IS NOTHING HERE WITH A LOCK.
  29 YOU AREN'T CARRYING IT.
  30 THE LITTLE BIRD ATTACKS THE GREEN SNAKE, AND IN AN
  30  ASTOUNDING FLURRY DRIVES THE SNAKE AWAY.
  31 YOU HAVE NO KEYS.
  32 IT HAS NO LOCK.
  33 I DON'T KNOW HOW TO LOCK OR UNLOCK SUCH A THING.
  34 IT WAS ALREADY LOCKED.
  35 THE GRATE IS NOW LOCKED.
  36 THE GRATE IS NOW UNLOCKED.
  37 IT WAS ALREADY UNLOCKED.
  38 YOU HAVE NO SOURCE OF LIGHT.
  39 YOUR LAMP IS NOW ON.
  40 YOUR LAMP IS NOW OFF.
  41 THERE IS NO WAY TO GET PAST THE BEAR TO UNLOCK THE 
  41 CHAIN, WHICH IS PROBABLY JUST AS WELL.
  42 NOTHING HAPPENS.
  43 WHERE?
  44 THERE IS NOTHING HERE TO ATTACK.
  45 THE LITTLE BIRD IS NOW DEAD.  ITS BODY DISAPPEARS.
  46 ATTACKING THE SNAKE BOTH DOESN'T WORK AND IS VERY 
  46 DANGEROUS.
  47 YOU KILLED A LITTLE DWARF.
  48 YOU ATTACK A LITTLE DWARF, BUT HE DODGES OUT OF TH
  48 E WAY.
  49 WITH WHAT?  YOUR BARE HANDS?
  50 GOOD TRY, BUT THAT IS AN OLD WORN OUT MAGIC WORD.
  51 I KNOW OF PLACES, ACTIONS, AND THINGS.  MOST OF MY
  51  VOCABULARY DESCRIBES PLACES AND IS USED TO MOVE Y
  51 OU THERE.  TO MOVE, TRY WORDS LIKE FOREST, BUILDIN
  51 G, DOWNSTREAM, ENTER, EAST, WEST, NORTH, SOUTH, UP
  51 , OR DOWN.
  51   I KNOW ABOUT A FEW SPECIAL OBJECTS, LIKE A BLACK
  51  ROD HIDDEN IN THE CAVE.
  51   THESE OBJECTS CAN BE MANIPULATED USING SOME OF T
  51 HE ACTION WORDS THAT I KNOW.  USUALLY YOU WILL NEE
  51 D TO GIVE BOTH THE OBJECT AND ACTION WORD (IN EITH
  51 ER ORDER), BUT SOMETIMES I CAN INFER THE OBJECT FR
  51 OM
  51  THE VERB ALONE.  SOME OBJECTS ALSO IMPLY VERBS; I
  51 N PARTICULAR, 'INVENTORY' IMPLIES 'TAKE INVENTORY'
  51 , WHICH CAUSES ME TO GIVE YOU A LIST OF WHAT YOU A
  51 RE CARRYING.  THE OBJECTS HAVE SIDE EFFECTS; FOR I
  51 NSTANCE, THE ROD SCARES THE BIRD.
  51   USUALLY PEOPLE HAVING TROUBLE MOVING JUST NEED T
  51 O TRY A FEW MORE WORDS.  USUALLY PEOPLE TRYING UNS
  51 UCCESFULLY TO MANIPULATE AN OBJECT ARE ATTEMPTING 
  51 SOMETHING BEYOND THEIR (OR MY) CAPABILITIES AND SH
  51 OULD TRY A COMPLETELY
  51  DIFFERENT TACK.  TO SPEED THE GAME YOU CAN SOMETI
  51 MES MOVE LONG DISTANCES WITH A SINGLE WORD.  FOR E
  51 XAMPLE, 'BUILDING' USUALLY GETS YOU TO THE BUILDIN
  51 G FROM ANYWHERE ABOVE GROUND EXCEPT WHEN LOST IN T
  51 HE FOREST.
  51   ALSO, NOTE THAT CAVE PASSAGES TURN A LOT, AND TH
  51 AT LEAVING A ROOM TO THE NORTH DOES NOT GUARANTEE 
  51 ENTERING THE NEXT ROOM FROM THE SOUTH.  GOOD LUCK.
  52 IT MISSES.
  53 IT GETS YOU.
  54 OK
  55 YOU CAN'T UNLOCK THE KEYS.
  56 YOU HAVE CRAWLED AROUND IN SOME LITTLE HOLES AND W
  56 OUND UP BACK IN THE MAIN PASSAGE.
  57 I DON'T KNOW WHERE THE CAVE IS, BUT HEREABOUTS NO 
  57 STREAM CAN RUN ON THE SURFACE FOR LONG.  I WOULD T
  57 RY THE STREAM.
  58 I NEED MORE DETAILED INSTRUCTIONS TO DO THAT.
  59 I CAN ONLY TELL YOU WHAT YOU SEE AS YOU MOVE ABOUT
  59  AND MANIPULATE THINGS.  I CANNOT TELL YOU WHERE R
  59 EMOTE THINGS ARE.
  60 I DON'T KNOW THAT WORD.
  61 WHAT?
  62 ARE YOU TRYING TO GET INTO THE CAVE?
  63 THE GRATE IS VERY SOLID AND HAS A HARDENED STEEL L
  63 OCK.  YOU CANNOT ENTER WITHOUT A KEY, AND THERE AR
  63 E NO KEYS NEARBY.  I WOULD RECOMMEND LOOKING ELSEW
  63 HERE FOR THE KEYS.
  64 THE TREES OF THE FOREST ARE LARGE HARDWOOD OAK AND
  64  MAPLE, WITH AN OCCASIONAL GROVE OF PINE OR SPRUCE
  64 .  THERE IS QUITE A BIT OF UNDER GROWTH, LARGLY BI
  64 RCH AND ASH SAPLINGS PLUS NON DESCRIPT BUSHES OF V
  64 ARIOUS SORTS.
  64   THIS TIME OF YEAR VISIBILITY IS QUITE RESTRICTED
  64  BY ALL THE LEAVES, BUT TRAVEL IS QUITE EASY IF YO
  64 U DETOUR AROUND THE SPRUCE AND BERRY BUSHES.
  65 WELCOME TO ADVENTURE... WOULD YOU LIKE INSTRUCTION
  65 S?
  66 DIGGING WITHOUT A SHOVEL IS QUITE IMPRACTICAL.  EV
  66 EN WITH A SHOVEL PROGRESS IS UNLIKELY.
  67 BLASTING REQUIRES DYNAMITE.
  68 I'M AS CONFUSED AS YOU ARE.
  69 MIST IS A WHITE VAPOR, USUALLY WATER, SEEN FROM TI
  69 ME TO TIME IN CAVERNS.  IT CAN BE FOUND ANYWHERE, 
  69 BUT IS FREQUENTLY A SIGN OF A DEEP PIT LEADING DOW
  69 N TO WATER.
  70 YOUR FEET ARE NOW WET.
  71 I THINK I JUST LOST MY APPETITE.
  72 THANK YOU, IT WAS DELICIOUS.
  73 YOU HAVE TAKEN A DRINK FROM THE STREAM.  THE WATER
  73  TASTES STRONGLY OF MINERALS, BUT IS NOT UNPLEASAN
  73 T.  IT IS EXTREMELY COLD.
  74 THE BOTTLE OF WATER IS NOW EMPTY.
  75 IT'S AN ELECTRIC LAMP AND RUBBING IT IS NOT PARTIC
  75 ULARLY REWARDING.  ANYWAY, NOTHING HAPPENS.
  76 PECULIAR.  NOTHING UNEXPECTED HAPPENS.
  77 YOUR BOTTLE IS EMPTY AND THE GROUND AT YOUR FEET I
  77 S WET.
  78 YOU CAN'T POUR THAT.
  79 FUCK YOURSELF!  KEEP THAT UP AND YOU'RE ON YOUR OW
  79 N.
  80 WHICH WAY?
  81 OH DEAR, YOU SEEM TO HAVE GOTTEN YOURSELF KILLED. 
  81  I MIGHT BE ABLE TO HELP YOU OUT, BUT I'VE NEVER R
  81 EALLY DONE THIS KIND OF THING BEFORE.  DO YOU WANT
  81  ME TO TRY TO REINCARNATE YOU?
  82 ALL RIGHT.  BUT DON'T BLAME ME IF SOMETHING GOES W
  82 R.....                  YOU ARE ENGULFED IN A CLOU
  82 D OF ORANGE SMOKE.  COUGHING AND GASPING, YOU EMER
  82 GE FROM THE CLOUD AND FIND....
  83 YOU CLUMSY OAF!  YOU'VE DONE IT AGAIN.  I DON'T KN
  83 OW HOW LONG I CAN KEEP THIS UP.  DO YOU WANT ME TO
  83  TRY REINCARNATING YOU AGAIN?
  84 OKAY, NOW WHERE DID I PUT MY ORANGE SMOKE?....    
  84  >POOF<              EVERYTHING DISAPPEARS IN A DE
  84 NSE CLOUD OF ORANGE SMOKE.
  85 NOW YOU'VE REALLY DONE IT.  I'M OUT OF ORANGE SMOK
  85 E.  YOU DON'T EXPECT ME TO DO A DECENT REINCARNATI
  85 ON WITHOUT ORANGE SMOKE, DO YOU?
  86 OKAY, IF YOU'RE SO SMART DO IT YOURSELF.  I'M LEAV
  86 ING.
  91 SORRY, BUT I NO LONGER SEEM TO REMEMBER HOW IT WAS
  91  YOU GOT HERE.
  92 YOU CAN'T CARRY ANYTHING MORE.  YOU'LL HAVE TO DRO
  92 P SOMETHING FIRST.
  93 YOU CAN'T GO THROUGH A LOCKED STEEL GRATE.
  94 I BELIEVE WHAT YOU WANT IS RIGHT HERE WITH YOU.
  95 YOU DON'T FIT THROUGH A TWO-INCH SLIT.
  96 I RESPECTFULLY SUGGEST YOU GO ACROSS THE BRIDGE IN
  96 STEAD OF JUMPING.
  97 THERE IS NO WAY ACROSS THE FISSURE.
  98 YOU'RE NOT CARRYING ANYTHING.
  99 YOU ARE CURRENTLY HOLDING THE FOLLOWING:
 100 IT'S NOT HUNGRY (IT'S MERELY PININ' FOR THE FJORDS
 100 ).  BESIDES, YOU HAVE NO BIRD SEED.
 101 THE SNAKE HAS NOW DEVOURED YOUR BIRD.
 102 THERE'S NOTHING HERE IT WANTS TO EAT (EXCEPT PERHA
 102 PS YOU).
 103 FOOL, DWARVES EAT ONLY COAL.  NOW YOU'VE MADE HIM 
 103 *REALLY* MAD.
 104 YOU HAVE NOTHING IN WHICH TO CARRY IT.
 105 YOUR BOTTLE IS ALREADY FULL.
 106 THERE IS NOTHING HERE WITH WHICH TO FILL THE BOTTL
 106 E.
 107 YOUR BOTTLE IS NOW FULL OF WATER.
 108 YOUR BOTTLE IS NOW FULL OF OIL.
 109 YOU CAN'T FILL THAT.
 110 DON'T BE RIDICULOUS.
 111 THE DOOR IS EXTREMELY RUSTY AND REFUSES TO OPEN.
 112 THE PLANT INDIGNANTLY SHAKES THE OIL OFF ITS LEAVE
 112 S AND ASKS, 'WATER'?
 113 THE HINGES ARE QUITE THROUGHLY RUSTED NOW AND WON'
 113 T BUDGE.
 114 THE OIL HAS FREED UP THE HINGES SO THAT THE DOOR W
 114 ILL NOW MOVE, THOUGH IT REQUIRES SOME EFFORT.
 115 THE PLANT HAS EXCEPTIONLY DEEP ROOTS AND CANNOT BE
 115  PULLED FREE.
 116 THE DWARVE'S KNIVES VANISH AS THEY STRIKE THE WALL
 116 S OF THE CAVE.
 117 SOMETHING YOU'RE CARRYING WON'T FIT THROUGH THE TU
 117 NNEL WITH YOU.  YOU'D BEST TAKE INVENTORY AND DROP
 117  SOMETHING.
 118 YOU CAN'T FIT THIS FIVE-FOOT CLAM THROUGH THAT LIT
 118 TLE PASSAGE.
 119 YOU CAN'T FIT THIS FIVE-FOOT OYSTER THROUGH THAT L
 119 ITTLE PASSAGE.
 120 I ADVISE YOU TO PUT DOWN THE CLAM BEFORE OPENING I
 120 T. (STRAIN).
 121 I ADVISE YOU TO PUT DOWN THE OYSTER BEFORE OPENING
 121  IT. (WRENCH).
 122 YOU DON'T HAVE ANYTHING STRONG ENOUGH TO OPEN THE 
 122 CLAM.
 123 YOU DON'T HAVE ANYTHING STRONG ENOUGH TO OPEN THE 
 123 OYSTER.
 124 A GLISTENING PEARL FALLS OUT OF THE CLAM AND ROLLS
 124  AWAY.  GOODNESS, THIS MUST REALLY BE AN OYSTER.  
 124 (I NEVER WAS ANY GOOD AT IDENTIFYING BIVALVES.)  W
 124 HATEVER IT IS, IT HAS NOW SNAPPED SHUT AGAIN.
 125 THE OYSTER CREAKS OPEN, REVEALING NOTHING BUT OYST
 125 ER INSIDE.  IT PROMPTLY SNAPS SHUT AGAIN.
 126 YOU HAVE CRAWLED AROUND IN SOME LITTLE HOLES AND F
 126 OUND YOUR WAY BLOCKED BY A RECENT CAVE-IN.  YOU AR
 126 E NOW IN THE MAIN PASSAGE.
 127 THERE ARE FAINT RUSTLING NOISES FROM THE DARKNESS 
 127 BEHIND YOU.
 128 OUT FROM THE SHADOWS BEHIND YOU POUNCES A BEARDED 
 128 PIRATE.  'HAR, HAR' HE CHORTLES, 'I'LL JUST TAKE A
 128 LL THIS BOOTY AND HIDE IT AWAY WITH ME CHEST DEEP 
 128 IN THE MAZE.' HE SNATCHES YOUR TREASURE AND
 128  VANISHES INTO THE GLOOM.
 129 A SEPUCHRAL VOICE REVERBRATING THROUGH THE CAVE, S
 129 AYS, 'CAVE CLOSING SOON.  ALL ADVENTURERS EXIT THR
 129 OUGH MAIN OFFICE.'
 130 A MYSTERIOUS RECORDED VOICE GROANS INTO LIFE AND A
 130 NNOUNCES 'THIS EXIT IS CLOSED.  PLEASE LEAVE VIA M
 130 AIN OFFICE'.
 131 IT LOOKS AS THOUGH YOU'RE DEAD.  WELL, SEEING AS H
 131 OW IT'S SO CLOSE TO CLOSING TIME ANYWAY, I THINK I
 131 'LL JUST CALL IT A DAY.
 132 THE SEPULCHRAL VOICE INTONES, 'THE CAVE IS NOW CLO
 132 SED.'  AS THE ECHOES FADE, THERE IS A BLINDING FLA
 132 SH OF LIGHT (AND A SMALL PUFF OF ORANGE SMOKE).  A
 132 S YOUR EYES REFOCUS, YOU LOOK AROUND AND FIND....
 133 THERE IS A LOUD EXPLOSION, AND A TWENTY-FOOT HOLE 
 133 APPEARS IN THE FAR WALL, BURYING THE DWARVES IN TH
 133 E RUBBLE.  YOU MARCH THROUGH THE HOLE AND FIND YOU
 133 RSELF IN THE MAIN OFFICE,
 133  WHERE A CHEERING BAND OF FRIENDLY ELVES CARRY THE
 133  CONQUERING ADVENTURER OFF INTO THE SUNSET.
 134 THERE IS A LOUD EXPLOSION, AND A TWENTY-FOOT HOLE 
 134 APPEARS IN THE FAR WALL, BURYING THE SNAKES IN THE
 134  RUBBLE.  A RIVER OF MOLTEN LAVA POURS IN THROUGH 
 134 THE HOLE, DESTROYING EVERYTHING IN ITS PATH, INCLU
 134 DING YOU.
 135 THERE IS A LOUD EXPLOSION, AND YOU ARE SUDDENLY SP
 135 LASHED ACROSS THE WALLS OF THE ROOM.
 136 THE RESULTING RUCKUS HAS AWAKENED THE DWARVES.  TH
 136 ERE ARE NOW SEVERAL THREATENING LITTLE DWARVES IN 
 136 THE ROOM WITH YOU.  MOST OF THEM THROW KNIVES AT Y
 136 OU.  ALL OF THEM GET YOU.
 137 OH, LEAVE THE POOR UNHAPPY BIRD ALONE.
 138 I DARESAY WHATEVER YOU WANT IS AROUND HERE SOMEWHE
 138 RE.
 139 I DON'T KNOW THE WORD 'STOP'.  USE QUIT' IF YOU WA
 139 NT TO GIVE UP.
 140 YOU CAN'T GET THERE FROM HERE.
 141 YOU ARE BEING FOLLOWED BY A VERY LARGE, TAME BEAR.
 143 DO YOU INDEED WISH TO QUIT NOW?
 144 THERE IS NOTHING HERE WITH WHICH TO FILL THE VASE.
 145 THE SUDDEN CHANGE IN TEMPERATURE HAS DELICATELY SH
 145 ATTERED THE VASE.
 146 IT IS BEYOND YOUR POWER TO DO THAT.
 147 I DON'T KNOW HOW.
 148 IT IS TOO FAR UP FOR YOU TO REACH.
 149 YOU KILLED A LITTLE DWARF.  THE BODY VANISHES IN A
 149  CLOUD OF GREASY BLACK SMOKE.
 150 THE SHELL IS VERY STRONG AND IS IMPERVIOUS TO ATTA
 150 CK.
 151 WHAT'S THE MATTER, CAN'T YOU READ?  NOW YOU'D BEST
 151  START OVER.
 152 THE AXE BOUNCES HARMLESSLY OFF THE DRAGON'S THICK 
 152 SCALES.
 153 THE DRAGON LOOKS RATHER NASTY.  YOU'D BEST NOT TRY
 153  TO GET BY.
 154 THE LITTLE BIRD ATTACKS THE GREEN DRAGON AND IN AN
 154  ASTOUNDING FLURRY GETS BURNT TO A CINDER.  THE AS
 154 HES BLOW AWAY.
 155 ON WHAT?
 156 OKAY, FROM NOW ON I'LL ONLY DESCRIBE A PLACE IN FU
 156 LL THE FIRST TIME YOU COME TO IT.  TO GET THE FULL
 156  DESCRIPTION, SAY 'LOOK'.
 157 TROLLS ARE CLOSE RELATIVES WITH THE ROCK AND HAVE 
 157 SKIN AS TOUGH AS THAT OF A RHINOCEROS.  THE TROLL 
 157 FENDS OFF YOUR BLOWS EFFORTLESSLY.
 158 THE TROLL DEFTLY CATCHES THE AXE, EXAMINES IT CARE
 158 FULLY, AND TOSSES IT BACK, DECLARING, 'GOOD WORKMA
 158 NSHIP, BUT IT'S NOT VALUABLE ENOUGH.'
 159 THE TROLL CATCHES YOUR TREASURE AND SCURRIES AWAY 
 159 OUT OF SIGHT.
 160 THE TROLL REFUSES TO LET YOU CROSS.
 161 THERE IS NO LONGER ANY WAY ACROSS THE CHASM.
 162 JUST AS YOU REACH THE OTHER SIDE, THE BRIDGE BUCKL
 162 ES BENEATH THE WEIGHT OF THE BEAR, WHICH WAS STILL
 162  FOLLOWING YOU AROUND.  YOU SCRABBLE DESPERATELY F
 162 OR SUPPORT, BUT AS THE BRIDGE COLLAPSES YOU STUMBL
 162 E BACK AND FALL INTO THE CHASM.
 163 THE BEAR LUMBERS TOWARD THE TROLL, WHO LETS OUT A 
 163 STARTLED SHRIEK AND SCURRIES AWAY.  THE BEAR SOON 
 163 GIVES UP THE PURSUIT AND WANDERS BACK.
 164 THE AXE MISSES AND LANDS NEAR THE BEAR WHERE YOU C
 164 AN'T GET AT IT.
 165 WITH WHAT?  YOUR BARE HANDS?  AGAINST *HIS* BEAR H
 165 ANDS??
 166 THE BEAR IS CONFUSED; HE ONLY WANTS TO BE YOUR FRI
 166 END.
 167 FOR CRYING OUT LOUD, THE POOR THING IS ALREADY DEA
 167 D.
 168 THE BEAR EAGERLY WOLFS DOWN YOUR FOOD, AFTER WHICH
 168  HE SEEMS TO CALM DOWN CONSIDERABLY AND EVEN BECOM
 168 ES RATHER FRIENDLY.
 169 THE BEAR IS STILL CHAINED TO THE WALL.
 170 THE CHAIN IS STILL LOCKED.
 171 THE CHAIN IS NOW UNLOCKED.
 172 THE CHAIN IS NOW LOCKED.
 173 THERE IS NOTHING HERE TO WHICH THE CHAIN CAN BE LO
 173 CKED.
 174 THERE IS NOTHING HERE TO EAT.
 175 DO YOU WANT THE HINT?
 176 DO YOU NEED HELP GETTING OUT OF THE MAZE?
 177 YOU CAN MAKE THE PASSAGES LOOK LESS ALIKE BY DROPP
 177 ING THINGS.
 178 ARE YOU TRYING TO EXPLORE BEYOND THE PLOVER ROOM?
 179 THERE IS A WAY TO EXPLORE THAT REGION WITHOUT HAVI
 179 NG TO WORRY ABOUT FALLING INTO A PIT.  NONE OF THE
 179  OBJECTS AVAILABLE IS IMMEDIATELY USEFULL IN DISCO
 179 VERING THE SECRET.
 180 DO YOU NEED HELP GETTING OUT OF HERE?
 181 DON'T GO WEST.
 182 GLUTTONY IS NOT ONE OF THE TROLL'S VICES.  AVARICE
 182 , HOWEVER, IS.
 183 YOUR LAMP IS GETTING DIM.  YOU'D BEST START WRAPPI
 183 NG THIS UP, UNLESS YOU CAN FIND SOME FRESH BATTERI
 183 ES.  I SEEM TO RECALL THERE'S A VENDING MACHINE IN
 183  THE MAZE.  BRING SOME COINS WITH YOU.
 184 YOUR LAMP HAS RUN OUT OF POWER.
 185 THERE'S NOT MUCH POINT IN WANDERING AROUND OUT HER
 185 E, AND YOU CAN'T EXPLORE THE CAVE WITHOUT A LAMP. 
 185  SO LET'S JUST CALL IT A DAY.
 186 THERE ARE FAINT RUSTLING NOISES FROM THE DARKNESS 
 186 BEHIND YOU.  AS YOU TURN TOWARD THEM, THE BEAM OF 
 186 YOUR LAMP FALLS ACROSS A BEARDED PIRATE.  HE IS CA
 186 RRYING A LARGE CHEST.  'SHIVER ME TIMBERS.'  HE CR
 186 IES, 'I'VE BEEN SPOTTED.
 186   I'D BEST HIE MESELF OFF TO THE MAZE TO HIDE ME C
 186 HEST.'  WITH THAT, HE VANISHES INTO THE GLOOM.
 187 YOUR LAMP IS GETTING DIM.  YOU'D BEST GO BACK FOR 
 187 THOSE BATTERIES.
 188 YOUR LAMP IS GETTING DIM.  I'M TAKING THE LIBERTY 
 188 OF REPLACING THE BATTERIES.
 189 YOUR LAMP IS GETTING DIM, AND YOU'RE OUT OF SPARE 
 189 BATTERIES.  YOU'D BEST START WRAPPING THIS UP.
 190 I'M AFRAID THE MAGAZINE IS WRITTEN IN DWARVISH.
 191 'THIS IS NOT THE MAZE WHERE THE PIRATE LEAVES HIS 
 191 CHEST.'
 192 HMMM, THIS LOOKS LIKE A CLUE, WHICH MEANS IT'LL CO
 192 ST YOU TEN POINTS TO READ IT.  SHOULD I GO AHEAD A
 192 ND READ IT ANYWAY?
 193 IT SAYS, 'THERE IS SOMETHING STRANGE ABOUT THIS PL
 193 ACE, SUCH THAT ONE OF THE WORDS I'VE ALWAYS KNOWN 
 193 NOW HAS A NEW EFFECT.'
 194 IT SAYS THE SAME THING IT DID BEFORE.
 195 I'M AFRAID I DON'T UNDERSTAND.
 196 CONGRATULATIONS ON BRINGING LIGHT INTO THE DARK-RO
 196 OM.
 197 YOU STRIKE THE MIRROR A RESOUNDING BLOW, WHEREUPON
 197  IT SHATTERS INTO A MYRIAD TINY FRAGMENTS.
 198 YOU HAVE TAKEN THE VASE AND HURLED IT DELICATELY T
 198 O THE GROUND.
 199 YOU PROD THE NEAREST DWARF, WHO WAKES UP GRUMPILY,
 199  TAKES ONE LOOK AT YOU, CURSES, AND GRABS FOR HIS 
 199 AXE.
 200 IS THIS ACCEPTABLE?
 201 ARE YOU RESUMING AN EARLIER ADVENTURE?


========================================================================================
DOCUMENT :usus Folder:VOL09:advs7.text
========================================================================================

  1   3   0
  2   3   0
  3   8   9
  4  10   0
  5  11   0
  6   0   0
  7  14  15
  8  13   0
  9  94  -1
 10  96   0
 11  19  -1
 12  17  27
 13 101  -1
 14 103   0
 15   0   0
 16 106   0
 17   0  -1
 18   0   0
 19   3   0
 20   3   0
 21   0   0
 22   0   0
 23 109  -1
 24  25  -1
 25  23  67
 26 111  -1
 27  35 110
 28   0   0
 29  97  -1
 30   0   0
 31 119 121
 32 117 122
 33 117 122
 34   0   0
 35 130  -1
 36   0  -1
 37 126  -1
 38 140  -1
 39   0   0
 40  96  -1
 41   0   0
 42   0   0
 43   0   0
 44   0   0
 45   0   0
 46   0   0
 47   0   0
 48   0   0
 49   0   0
 50  18   0
 51  27   0
 52  28   0
 53  29   0
 54  30   0
 55   0   0
 56  92   0
 57  95   0
 58  97   0
 59 100   0
 60 101   0
 61   0   0
 62 119 121
 63 127   0
 64 130  -1
 65   0   0
 66   0   0
 67   0   0
 68   0   0
 69   0   0
 70   0   0
 71   0   0
 72   0   0
 73   0   0
 74   0   0
 75   0   0
 76   0   0
 77   0   0
 78   0   0
 79   0   0
 80   0   0
 81   0   0
 82   0   0
 83   0   0
 84   0   0
 85   0   0
 86   0   0
 87   0   0
 88   0   0
 89   0   0
 90   0   0
 91   0   0
 92   0   0
 93   0   0
 94   0   0
 95   0   0
 96   0   0
 97   0   0
 98   0   0
 99   0   0
100   0   0


========================================================================================
DOCUMENT :usus Folder:VOL09:advs8.text
========================================================================================

  1  24
  2  29
  3   0
  4  33
  5   0
  6  33
  7  38
  8  38
  9  42
 10  14
 11  43
 12 110
 13  29
 14 110
 15  73
 16  75
 17  29
 18  13
 19  59
 20  59
 21 174
 22 109
 23  67
 24  13
 25 147
 26 155
 27 195
 28 146
 29 110
 30  13
 31  13
 32   0
 33   0
 34   0
 35   0


========================================================================================
DOCUMENT :usus Folder:VOL09:advs9.text
========================================================================================

    0    1    2    3    4    5    6    7    8    9   10 
    0  100  115  116  126 
    1   16   20   21   22   24   26   31   32   40   59 
    1   79   89   90 
    2    1    3    4    7   24   38   95  113 
    3   46   47   48   54   56   58   82   85   86  122 
    3  123  124  125  126  127  128  129  130 
    4    8 
    5   13 
    6   19 
    7   42   43   44   45   46   47   48   49   50   51 
    7   52   53   54   55   56   80   81   82   86   87 
    8   99  100  101 
    9  108 


========================================================================================
DOCUMENT :usus Folder:VOL09:advsubs.text
========================================================================================

{ SUBROUTINES FOR ADVENTURE }
PROCEDURE NAMEANDPW;
VAR
  ACHR : CHAR;
  ACHAR : STRING[1];
BEGIN { NAMENADPW }
  WRITELN('ENTER YOUR NAME PLEASE.');
  READLN(NAMEOFUSER);
  WRITELN('ENTER YOUR PASSWORD ');
  READ(KEYBOARD,ACHR);
  ACHAR:=' ';
  TESTPW:='';
  WHILE NOT EOLN(KEYBOARD) DO
  BEGIN
    ACHAR[1]:=ACHR;
    IF 8=ORD(ACHR) THEN
      IF LENGTH(TESTPW)>0 THEN
      BEGIN
        DELETE(TESTPW,LENGTH(TESTPW),1);
        WRITE(CHR(8),' ',CHR(8));
      END
      ELSE
    ELSE
    BEGIN
      WRITE('X');
      TESTPW:=CONCAT(TESTPW,ACHAR);
    END;
    READ(KEYBOARD,ACHR);
  END;
  NAMEOFUSER:=CONCAT(NAMEOFUSER,'.AVSV');
END;  { NAMEANDPW }
FUNCTION GETSCORE(SCORECMD:BOOLEAN) : INTEGER;
VAR
  I,K,SCORE : INTEGER;
BEGIN {GETSCORE}
  MAXSCORE:=0;
  SCORE:=0;
  FOR I:=50 TO MAXTRS DO
    IF ARY^.PTEXT[I]<>0 THEN
    BEGIN
      IF I=CHEST THEN
        K:=14
      ELSE
        IF I>CHEST THEN
          K:=16
        ELSE
          K:=12;
      IF (VARY^.PROP[I]>=0) THEN
        SCORE:=SCORE+2;
      IF (VARY^.PLACE[I]=3) AND (VARY^.PROP[I]=0) THEN
        SCORE:=SCORE+K-2;
      MAXSCORE:=MAXSCORE+K;
    END;
  SCORE:=SCORE+(MAXDIE-VBL^.NUMDIE)*10;
  MAXSCORE:=MAXSCORE+MAXDIE*10;
  IF VBL^.DFLAG<>0 THEN
    SCORE:=SCORE+25;
  MAXSCORE:=MAXSCORE+25;
  IF NOT (GAVEUP OR SCORECMD) THEN
    SCORE:=SCORE+4;
  MAXSCORE:=MAXSCORE+4;
  IF VBL^.CLOSING THEN
    SCORE:=SCORE+25;
  MAXSCORE:=MAXSCORE+25;
  CASE BONUS OF
    0 : SCORE:=SCORE+10;
    135 : SCORE:=SCORE+25;
    134 : SCORE:=SCORE+30;
    133 : SCORE:=SCORE+45;
  END;
  MAXSCORE:=MAXSCORE+45;
  IF VARY^.PLACE[MAGAZINE]=108 THEN
    SCORE:=SCORE+1;
  MAXSCORE:=MAXSCORE+1;
  SCORE:=SCORE+2;
  MAXSCORE:=MAXSCORE+2;
  FOR I:=1 TO HNTSIZ DO
    IF VARY^.HINTED[I] THEN
      SCORE:=SCORE-ARY^.HINTS[I,2];
  GETSCORE:=SCORE;
END;  {GETSCORE}
FUNCTION TOTING(OBJECT:INTEGER):BOOLEAN;
BEGIN {TOTING}
  TOTING:=(VARY^.PLACE[OBJECT]=-1);
END;  {TOTING}
FUNCTION AT(OBJECT:INTEGER):BOOLEAN;
BEGIN {AT}
  AT:=(VARY^.PLACE[OBJECT]=VBL^.LOC) OR
      (VARY^.FIXED[OBJECT]=VBL^.LOC);
END;  {AT}
FUNCTION MIN(I,J:INTEGER):INTEGER;
BEGIN {MIN}
  IF J<I THEN
    MIN:=J
  ELSE
    MIN:=I;
END;  {MIN}
FUNCTION MAX(I,J:INTEGER):INTEGER;
BEGIN {MAX}
  IF J>I THEN
    MAX:=J
  ELSE
    MAX:=I;
END;  {MAX}
FUNCTION RAN(NUM:INTEGER):INTEGER;
VAR
  TEMP : INTEGER;
  TEMP2 : REAL;
BEGIN {RAN}
  TEMP:=SEED*899;
  IF TEMP<0 THEN
    TEMP:=TEMP+32767+1;
  TEMP2:=(TEMP-1)/32767.0;
  RAN:=TRUNC(TEMP2*NUM);
  SEED:=TEMP;
END;  {RAN}
FUNCTION PERCENT(I:INTEGER):BOOLEAN;
BEGIN {PERCENT}
  PERCENT:=(RAN(100)<I);
END;  {PERCENT}
FUNCTION HERE(OBJECT:INTEGER):BOOLEAN;
BEGIN {HERE}
  HERE:=(VARY^.PLACE[OBJECT]=VBL^.LOC) OR TOTING(OBJECT);
END;  {HERE}
FUNCTION DARK : BOOLEAN;
BEGIN {DARK}
  DARK:=((VARY^.COND[VBL^.LOC] MOD 2)=0) AND 
        ((VARY^.PROP[LAMP]=0) OR NOT HERE(LAMP));
END;  {DARK}
FUNCTION FORCED(LOC:INTEGER):BOOLEAN;
BEGIN {FORCED}
  FORCED:=VARY^.COND[LOC]=2;
END;  {FORCED}
FUNCTION BITSET(I,J:INTEGER):BOOLEAN;
VAR
  K,TEMP : INTEGER;
BEGIN {BITSET}
  TEMP:=VARY^.COND[I];
  FOR K:=1 TO J DO
    TEMP:=TEMP DIV 2;
  BITSET:=(TEMP MOD 2) = 1;
END;  {BITSET}
FUNCTION LIQ2(PBOTL:INTEGER): INTEGER;
VAR
  TEMP : INTEGER;
BEGIN {LIQ2}
  TEMP:=PBOTL DIV 2;
  LIQ2:=((1-PBOTL)*WATER+TEMP*(WATER+OIL));
END;  {LIQ2}
FUNCTION LIQ:INTEGER;
BEGIN {LIQ}
  LIQ:=LIQ2(MAX(VARY^.PROP[BOTTLE],-1-VARY^.PROP[BOTTLE]));
END;  {LIQ}
FUNCTION LIQLOC(LOC:INTEGER):INTEGER;
VAR
  TEMP1,TEMP2 : INTEGER;
BEGIN {LIQLOC}
  TEMP1:=(VARY^.COND[LOC] DIV 2) * 2; {EVEN COND ONLY}
  TEMP2:=VARY^.COND[LOC] DIV 4;
  LIQLOC:=LIQ2((TEMP1 MOD 8 - 5) * (TEMP2 MOD 2) + 1);
END;  {LIQLOC}
FUNCTION VOCAB(WORD:STRING;WHAT:INTEGER):INTEGER;
VAR
  I,J,K : INTEGER;
BEGIN {VOCAB}
  I:=1;
  J:=300;
  REPEAT
    K:=(I+J) DIV 2;
    IF ARY^.ATAB[K]<=WORD THEN
      I:=K+1;
    IF ARY^.ATAB[K]>=WORD THEN
      J:=K-1;
  UNTIL I>J;
  IF K>1 THEN
    IF ARY^.ATAB[K-1]=WORD THEN
      K:=K-1; {FIND FIRST WORD}
  VOCAB:=-1;
  IF ARY^.ATAB[K]=WORD THEN
    VOCAB:=ARY^.KTAB[K];
  IF WHAT>=0 THEN
  BEGIN
    WHILE (ARY^.ATAB[K]=WORD) AND
          (WHAT<>(ARY^.KTAB[K] DIV 1000)) DO
      K:=K+1;
    IF ARY^.ATAB[K]=WORD THEN
      VOCAB:=ARY^.KTAB[K] MOD 1000;
  END;
END;  {VOCAB}
PROCEDURE CARRY(OBJECT,WHERE:INTEGER);
VAR
  TEMP : INTEGER;
PROCEDURE LINKUP;
BEGIN {LINKUP}
  TEMP:=VARY^.ATLOC[WHERE];
  WHILE (VARY^.LINK[TEMP]<>OBJECT) DO
    TEMP:=VARY^.LINK[TEMP];
  VARY^.LINK[TEMP]:=VARY^.LINK[OBJECT];
END;  {LINKUP}
BEGIN {CARRY}
  IF OBJECT<=100 THEN
    IF VARY^.PLACE[OBJECT]<>-1 THEN
    BEGIN
      VARY^.PLACE[OBJECT]:=-1;
      VBL^.HLDING:=VBL^.HLDING+1;
      IF VARY^.ATLOC[WHERE]=OBJECT THEN
        VARY^.ATLOC[WHERE]:=VARY^.LINK[OBJECT]
      ELSE
        LINKUP
    END
    ELSE
  ELSE
    IF VARY^.ATLOC[WHERE]=OBJECT THEN
      VARY^.ATLOC[WHERE]:=VARY^.LINK[OBJECT]
    ELSE
      LINKUP
END;  {CARRY}
PROCEDURE DROP(OBJECT,WHERE:INTEGER);
BEGIN {DROP}
  IF OBJECT>100 THEN
    VARY^.FIXED[OBJECT-100]:=WHERE
  ELSE
  BEGIN
    IF VARY^.PLACE[OBJECT]=-1 THEN
      VBL^.HLDING:=VBL^.HLDING-1;
    VARY^.PLACE[OBJECT]:=WHERE;
  END;
  IF WHERE>0 THEN
  BEGIN
    VARY^.LINK[OBJECT]:=VARY^.ATLOC[WHERE];
    VARY^.ATLOC[WHERE]:=OBJECT;
  END;
END;  {DROP}
PROCEDURE MOVE(OBJECT,WHERE:INTEGER);
VAR
  FROM : INTEGER;
BEGIN {MOVE}
  IF OBJECT>100 THEN
    FROM:=VARY^.FIXED[OBJECT-100]
  ELSE
    FROM:=VARY^.PLACE[OBJECT];
  IF (FROM>0) AND (FROM <= 300) THEN
    CARRY(OBJECT,FROM);
  DROP(OBJECT,WHERE);
END;  {MOVE}
PROCEDURE JUGGLE(OBJECT:INTEGER);
BEGIN {JUGGLE}
  MOVE(OBJECT,VARY^.PLACE[OBJECT]);
  MOVE(OBJECT+100,VARY^.FIXED[OBJECT]);
END;  {JUGGLE}
PROCEDURE DESTROY(OBJECT:INTEGER);
BEGIN {DESTROY}
  MOVE(OBJECT,0);
END;  {DESTROY}
FUNCTION PUT(OBJECT,WHERE,PVAL : INTEGER):INTEGER;
BEGIN {PUT}
  MOVE(OBJECT,WHERE);
  PUT:=(-1)-PVAL;
END;  {PUT}
PROCEDURE SPEAK(MSG:INTEGER);
VAR
  I : INTEGER;
  MTEMP : STRING[6];
  MTEMP2 : STRING;
  MTEXT : STRING[255];
PROCEDURE HOLDUP;
BEGIN { HOLDUP }
  LINE:=LINE+1;
  IF LINE>=(TERMHIGHT-1) THEN
  BEGIN
    LINE:=1;
    WRITE(CHR(7),'         PRESS <RETURN> TO CONTINUE');
    READLN;
  END;
END;  { HOLDUP }
BEGIN {SPEAK}
  MTEMP:='      ';
  MTEXT:='';
  IF MSG>0 THEN
  BEGIN
    SEEK(MSGFILE,MSG);
    REPEAT
      GET(MSGFILE);
      FOR I:=1 TO 6 DO
        MTEMP[I]:=MSGFILE^[I];
      IF ORD(MTEMP[1])>128 THEN
        MTEMP[1]:=CHR(ORD(MTEMP[1])-128);
      IF ORD(MTEMP[2])>128 THEN
        MTEMP[2]:=CHR(ORD(MTEMP[2])-128);
      MTEXT:=CONCAT(MTEXT,MTEMP);
      IF LENGTH(MTEXT)>TERMWIDTH THEN
      BEGIN
        I:=TERMWIDTH;
        WHILE MTEXT[I]<>' ' DO
          I:=I-1;
        MTEMP2:=COPY(MTEXT,1,I-1);
        DELETE(MTEXT,1,I);
        WRITELN(MTEMP2);
        HOLDUP;
      END;
    UNTIL ORD(MSGFILE^[1])>128;
    IF MTEXT<>'      ' THEN {DONT PRINT DUMMY MSG}
    BEGIN
      WRITELN(MTEXT);
      HOLDUP;
    END;
  END;
END;  {SPEAK}
PROCEDURE PSPEAK(MSG,SKIP:INTEGER);
VAR
  I,M : INTEGER;
BEGIN {PSPEAK}
  M:=ARY^.PTEXT[MSG];
  SEEK(MSGFILE,M);
  FOR I:=0 TO SKIP DO
  BEGIN
    REPEAT
      GET(MSGFILE);
      M:=M+1;
    UNTIL ORD(MSGFILE^[1])>128;
  END;
  GET(MSGFILE); { INSURE GET BETWEEN SEEKS}
  SPEAK(M);
END;  {PSPEAK}
FUNCTION YES(MSG,SPKYES,SPKNO:INTEGER):BOOLEAN;
VAR
  INLINE : STRING;
BEGIN {YES}
  YEA:=FALSE;
  SKIPIT:=FALSE;
  IF MSG<>0 THEN
    SPEAK(ARY^.RTEXT[MSG]);
  LINE:=1;
  REPEAT
    IF SKIPIT THEN
      WRITELN('PLEASE ANSWER THE QUESTION WITH YES OR NO');
    SKIPIT:=TRUE;
    READLN(INLINE);
  UNTIL (INLINE='YES') OR (INLINE='Y') OR
        (INLINE='NO')  OR (INLINE='N') OR
        (INLINE='yes') OR (INLINE='y') OR
        (INLINE='no')  OR (INLINE='n');
  YEA:=(INLINE='YES') OR (INLINE='Y') OR
       (INLINE='yes') OR (INLINE='y');
  IF (INLINE='yes') OR (INLINE='y') OR
     (INLINE='no')  OR (INLINE='n')THEN
    WRITELN(CHR(7),'YOU WONT GET VERY FAR IN LOWER CASE !');
  IF YEA THEN
    SPKNO:=SPKYES;
  IF SPKNO<>0 THEN
    SPEAK(ARY^.RTEXT[SPKNO]);
  YES:=YEA;
END;  {YES}
PROCEDURE ERRORHALT(I:INTEGER);
BEGIN {ERRORHALT}
  WRITELN;
  WRITELN('FATAL ERROR # ',I,' ---- BYE!');
  HALT;
END;  {ERRORHALT}
PROCEDURE SET_NEW_LOC; FORWARD;
PROCEDURE TESTCLOSE;
VAR
  I : INTEGER;
BEGIN { TESTCLOSE }
  IF (NEWLOC IN [1..8]) AND VBL^.CLOSING THEN
    BEGIN
      SPEAK(ARY^.RTEXT[130]);
      NEWLOC:=VBL^.LOC;
      IF NOT VBL^.PANIC THEN VBL^.CLOCK2:=15;
      VBL^.PANIC:=TRUE;
    END;
  IF (NEWLOC<>VBL^.LOC) AND NOT FORCED(VBL^.LOC)
      AND NOT BITSET(VBL^.LOC,3) THEN
    FOR I:=1 TO 5 DO
      IF (VARY^.ODLOC[I]=NEWLOC) AND VARY^.DSEEN[I] THEN
      BEGIN
        NEWLOC:=VBL^.LOC;
        SPEAK(ARY^.RTEXT[2]);
        I:=5;
      END;
END;  { TESTCLOSE }
PROCEDURE DWARFSTUFF;
VAR
  LASTLOC : INTEGER;
  TBITSET,TFORCED : BOOLEAN;
PROCEDURE PIRATESTUFF;
BEGIN { PIRATESTUFF}
  K:=0;
  STEAL:=FALSE;
  FOR J:=50 TO MAXTRS DO
  BEGIN
    IF (J=PYRAMID) AND ((VBL^.LOC=ARY^.PLAC[PYRAMID]) OR
       (VBL^.LOC=ARY^.PLAC[EMERALD])) THEN { NOTHING }
    ELSE
    BEGIN
      STEAL:=STEAL OR TOTING(J);
      IF VARY^.PLACE[J]=VBL^.LOC THEN
        K:=1;
    END;
  END;
  IF STEAL THEN
  BEGIN
    SPEAK(ARY^.RTEXT[128]);
    IF VARY^.PLACE[MESSAGE]=0 THEN
      MOVE(CHEST,VBL^.CHLOC);
    MOVE(MESSAGE,VBL^.CHLOC2);
    FOR J:=50 TO MAXTRS DO
    BEGIN
      IF (J=PYRAMID) AND ((VBL^.LOC=ARY^.PLAC[PYRAMID]) OR
       (VBL^.LOC=ARY^.PLAC[EMERALD])) THEN { NOTHING }
      ELSE
      BEGIN
        IF (VARY^.PLACE[J]=VBL^.LOC) AND (VARY^.FIXED[J]=0) THEN
          CARRY(J,VBL^.LOC);
        IF TOTING(J) THEN
          DROP(J,VBL^.CHLOC);
      END;
    END;
    VARY^.DLOC[6]:=VBL^.CHLOC;
    VARY^.ODLOC[6]:=VBL^.CHLOC;
    VARY^.DSEEN[6]:=FALSE;
  END
  ELSE
  BEGIN
    IF (VBL^.TALLY=(VBL^.TALLY2+1)) AND
       (K=0) AND (VARY^.PLACE[CHEST]=0) AND
       HERE(LAMP) AND (VARY^.PROP[LAMP]=1) THEN
    BEGIN
      SPEAK(ARY^.RTEXT[186]);
      MOVE(CHEST,VBL^.CHLOC);
      MOVE(MESSAGE,VBL^.CHLOC2);
      VARY^.DLOC[6]:=VBL^.CHLOC;
      VARY^.ODLOC[6]:=VBL^.CHLOC;
      VARY^.DSEEN[6]:=FALSE;
    END
    ELSE
      IF (VARY^.ODLOC[6]<>VARY^.DLOC[6]) AND PERCENT(20) THEN
        SPEAK(ARY^.RTEXT[127]);
  END;
END;  { PIRATESTUFF}
BEGIN { DWARFSTUFF }
  IF VBL^.DFLAG=1 THEN
    IF (VBL^.LOC>=15) AND PERCENT(95) THEN
    BEGIN
      VBL^.DFLAG:=2;
      FOR I:=1 TO 2 DO
        IF PERCENT(50) THEN
          VARY^.DLOC[1+RAN(5)]:=0;
      FOR I:=1 TO 5 DO
      BEGIN
        IF VARY^.DLOC[I]=VBL^.LOC THEN
          VARY^.DLOC[I]:=DALTLC;
        VARY^.ODLOC[I]:=VARY^.DLOC[I];
      END;
      SPEAK(ARY^.RTEXT[3]);
      DROP(AXE,VBL^.LOC);
    END
    ELSE
  ELSE
  BEGIN
    VBL^.DTOTAL:=0;
    ATTACK:=0;
    STICK:=0;
    FOR I:=1 TO 6 DO
      IF VARY^.DLOC[I]<>0 THEN
      BEGIN
        J:=1;
        KK:=ARY^.KEY[VARY^.DLOC[I]];
        IF KK<>0 THEN
        REPEAT
          NEWLOC:=ARY^.TRAVEL2[KK];
          IF (J>1) AND (J<=21) THEN
            LASTLOC:=VARY^.TK[J-1];
          IF NEWLOC<=150 THEN
          BEGIN
            TBITSET:=BITSET(NEWLOC,3);
            TFORCED:=FORCED(NEWLOC);
          END
          ELSE
          BEGIN
            TBITSET:=FALSE;
            TFORCED:=FALSE;
          END;
          IF (NEWLOC>300) OR (NEWLOC<15) OR
             (NEWLOC=VARY^.ODLOC[I]) OR
             ((J>1) AND (NEWLOC=LASTLOC)) OR (J>=20) OR
             (NEWLOC=VARY^.DLOC[I]) OR TFORCED OR
             ((I=6) AND TBITSET) OR
             (ARY^.TRAVEL3[KK]=100) THEN
          ELSE
          BEGIN
            VARY^.TK[J]:=NEWLOC;
            J:=J+1;
          END;
          KK:=KK+1;
        UNTIL ARY^.TRAVEL[KK-1]<0;
        VARY^.TK[J]:=VARY^.ODLOC[I];
        IF J>=2 THEN J:=J-1;
        J:=1+RAN(J);
        VARY^.ODLOC[I]:=VARY^.DLOC[I];
        VARY^.DLOC[I]:=VARY^.TK[J];
        VARY^.DSEEN[I]:=(VARY^.DSEEN[I] AND (VBL^.LOC>=15)) OR
             (VARY^.DLOC[I]=VBL^.LOC) OR
             (VARY^.ODLOC[I]=VBL^.LOC);
        IF VARY^.DSEEN[I] THEN
        BEGIN
          VARY^.DLOC[I]:=VBL^.LOC;
          IF I=6 THEN
            IF (VBL^.LOC<>VBL^.CHLOC) AND (VARY^.PROP[CHEST]<0) THEN
              PIRATESTUFF
            ELSE
          ELSE
          BEGIN
            VBL^.DTOTAL:=VBL^.DTOTAL+1;
            IF VARY^.ODLOC[I]=VARY^.DLOC[I] THEN
            BEGIN
              ATTACK:=ATTACK+1;
              IF VBL^.KNFLOC>=0 THEN VBL^.KNFLOC:=VBL^.LOC;
              IF RAN(1000)<(95*(VBL^.DFLAG-2)) THEN
                STICK:=STICK+1;
            END;
          END;
        END;
      END;
    END;
  IF VBL^.DTOTAL<>0 THEN
  BEGIN
    IF VBL^.DTOTAL=1 THEN
      SPEAK(ARY^.RTEXT[4])
    ELSE
    BEGIN
      WRITE('THERE ARE ',VBL^.DTOTAL,' THREATENING ');
      WRITELN('LITTLE DWARVES IN THE ROOM WITH YOU');
    END;
    IF ATTACK<>0 THEN
    BEGIN
      IF VBL^.DFLAG=2 THEN
        VBL^.DFLAG:=3;
      IF ATTACK=1 THEN
      BEGIN
        SPEAK(ARY^.RTEXT[5]);
        K:=52;
      END
      ELSE
      BEGIN
        K:=6;
        WRITE(ATTACK,' OF THEM THROW KNIVES AT YOU.');
      END;
      IF STICK>1 THEN
        WRITELN(STICK,' OF THEM GET YOU!')
      ELSE
        SPEAK(ARY^.RTEXT[K+STICK]);
      IF STICK<>0 THEN
      BEGIN
        VBL^.OLDLC2:=VBL^.LOC;
        HE_DIED:=TRUE;
      END;
    END;
  END;
END;  { DWARFSTUFF }
PROCEDURE DESCRIBE_CURRENT_LOCATION;
BEGIN { DESCRIBE_CURRENT_LOCATION}
  IF VBL^.LOC=0 THEN
  BEGIN
    HE_DIED:=TRUE;
    EXIT(DESCRIBE_CURRENT_LOCATION);
  END;
  KK:=ARY^.STEXT[VBL^.LOC];
  IF ((VARY^.ABB[VBL^.LOC] MOD VBL^.ABBNUM)=0) OR (KK=0) THEN
    KK:=ARY^.LTEXT[VBL^.LOC];
  IF (NOT FORCED(VBL^.LOC)) AND DARK THEN
  BEGIN
    IF VBL^.WZDARK AND PERCENT(35) THEN
    BEGIN
      HE_DIED:=TRUE;
      PIT:=TRUE;
      EXIT(DESCRIBE_CURRENT_LOCATION);
    END;
    KK:=ARY^.RTEXT[16];
  END;
  IF TOTING(BEAR) THEN
    SPEAK(ARY^.RTEXT[141]);
  SPEAK(KK);
  K:=1;
  IF FORCED(VBL^.LOC) THEN
    BEGIN
      SET_NEW_LOC;
      NEWLOCSET:=TRUE;
      EXIT(DESCRIBE_CURRENT_LOCATEION);
    END;
  IF (VBL^.LOC=33) AND PERCENT(25) AND NOT VBL^.CLOSING THEN
    SPEAK(ARY^.RTEXT[8]);
  IF NOT DARK THEN
  BEGIN
    VARY^.ABB[VBL^.LOC]:=VARY^.ABB[VBL^.LOC]+1;
    I:=VARY^.ATLOC[VBL^.LOC];
    WHILE I<>0 DO
    BEGIN
      VBL^.OBJ:=I;
      IF VBL^.OBJ>100 THEN
        VBL^.OBJ:=VBL^.OBJ-100;
      IF (VBL^.OBJ=STEPS) AND TOTING(NUGGET) THEN
      ELSE
      BEGIN
        IF VARY^.PROP[VBL^.OBJ]<0 THEN
        BEGIN
          IF NOT VBL^.CLOSED THEN
          BEGIN
            VARY^.PROP[VBL^.OBJ]:=0;
            IF (VBL^.OBJ=RUG) OR (VBL^.OBJ=CHAIN) THEN
              VARY^.PROP[VBL^.OBJ]:=1;
            VBL^.TALLY:=VBL^.TALLY-1;
            IF (VBL^.TALLY=VBL^.TALLY2) AND (VBL^.TALLY<>0) THEN
              VBL^.LIMIT:=MIN(35,VBL^.LIMIT);
          END;
        END;
        IF NOT VBL^.CLOSED THEN
        BEGIN
          KK:=VARY^.PROP[VBL^.OBJ];
          IF (VBL^.OBJ=STEPS) AND (VBL^.LOC=VARY^.FIXED[STEPS]) THEN
            KK:=1;
          PSPEAK(VBL^.OBJ,KK);
        END;
      END; 
      I:=VARY^.LINK[I];
    END; { WHILE I<>0 DO}
  END;
END; { DESCRIBE_CURRENT_LOCATION }
PROCEDURE CHECKHINTS;
PROCEDURE GIVEHINT;
BEGIN {GIVEHINT}
  VARY^.HINTLC[HINT]:=0;
  IF YES(ARY^.HINTS[HINT,3],0,54) THEN
  BEGIN
    WRITE('I AM PREPARED TO GIVE YOU A HINT, BUT ');
    WRITELN(' IT WILL COST YOU ',ARY^.HINTS[HINT,2],' POINTS');
    VARY^.HINTED[HINT]:=YES(175,ARY^.HINTS[HINT,4],54);
    IF VARY^.HINTED[HINT] AND (VBL^.LIMIT>30) THEN
      VBL^.LIMIT:=VBL^.LIMIT+30*ARY^.HINTS[HINT,2];
  END;
END;  {GIVEHINT}
PROCEDURE CAVEHINT;
BEGIN {CAVEHINT}
  IF (VARY^.PROP[GRATE]=0) AND NOT HERE(KEYS) THEN
    GIVEHINT
  ELSE
    VARY^.HINTLC[HINT]:=0;
END;  {CAVEHINT}
PROCEDURE BIRDHINT;
BEGIN {BIRDHINT}
  IF HERE(BIRD) AND TOTING(ROD) AND (VBL^.OBJ=BIRD) THEN
    GIVEHINT;
END;  {BIRDHINT}
PROCEDURE SNAKEHINT;
BEGIN {SNAKEHINT}
  IF HERE(SNAKE) AND NOT HERE(BIRD) THEN
    GIVEHINT
  ELSE
    VARY^.HINTLC[HINT]:=0;
END;  {SNAKEHINT}
PROCEDURE MAZEHINT;
BEGIN {MAZEHINT}
  IF (VARY^.ATLOC[VBL^.LOC]=0) AND (VARY^.ATLOC[VBL^.OLDLOC]=0) AND
     (VARY^.ATLOC[VBL^.OLDLC2]=0) AND (VBL^.HLDING>1) THEN
    GIVEHINT
  ELSE
    VARY^.HINTLC[HINT]:=0;
END;  {MAZEHINT}
PROCEDURE DARKHINT;
BEGIN {DARKHINT}
  IF (VARY^.PROP[EMERALD]<>-1) AND (VARY^.PROP[PYRAMID]=-1) THEN
    GIVEHINT
  ELSE
    VARY^.HINTLC[HINT]:=0;
END;  {DARKHINT}
PROCEDURE WITTHINT;
BEGIN {WITTHINT}
  GIVEHINT;
END;  {WITTHINT}
BEGIN { CHECKHINTS}
  FOR HINT:=4 TO HNTSIZ DO
  BEGIN
    IF NOT VARY^.HINTED[HINT] THEN
    BEGIN
      IF BITSET(VBL^.LOC,HINT) THEN
        VARY^.HINTLC[HINT]:=VARY^.HINTLC[HINT]+1
      ELSE
        VARY^.HINTLC[HINT]:=0;
      IF VARY^.HINTLC[HINT]>= ARY^.HINTS[HINT,1] THEN
        CASE HINT OF
          4 : CAVEHINT;
          5 : BIRDHINT;
          6 : SNAKEHINT;
          7 : MAZEHINT;
          8 : DARKHINT;
          9 : WITTHINT;
        END; {CASE OF HINT}
    END;
  END;
END;  { CHECKHINTS}
PROCEDURE SET_NEW_LOC;
VAR
  T1,T2,T3 : BOOLEAN;
PROCEDURE PLOVERALCOVE;
BEGIN { PLOVERALCOVE }
  NEWLOC:=199 - VBL^.LOC;
  IF (VBL^.HLDING=0) OR ((VBL^.HLDING=1) AND TOTING(EMERALD)) THEN
  ELSE
  BEGIN
    NEWLOC:=VBL^.LOC;
    SPEAK(ARY^.RTEXT[117]);
  END;
  EXIT(SET_NEW_LOC);
END;  { PLOVERALCOVE }
PROCEDURE TROLLBRIDGE;
BEGIN { TROLLBRIDGE }
  IF VARY^.PROP[TROLL]=1 THEN
  BEGIN
    PSPEAK(TROLL,1);
    VARY^.PROP[TROLL]:=0;
    MOVE(TROLL2,0);
    MOVE(TROLL2+100,0);
    MOVE(TROLL,ARY^.PLAC[TROLL]);
    MOVE(TROLL+100,ARY^.FIXD[TROLL]);
    JUGGLE(CHASM);
    NEWLOC:=VBL^.LOC;
  END
  ELSE
  BEGIN
    NEWLOC:=ARY^.PLAC[TROLL]+ARY^.FIXD[TROLL]-VBL^.LOC;
    IF VARY^.PROP[TROLL]=0 THEN
      VARY^.PROP[TROLL]:=1;
    IF TOTING(BEAR) THEN
    BEGIN
      SPEAK(ARY^.RTEXT[162]);
      VARY^.PROP[CHASM]:=1;
      VARY^.PROP[TROLL]:=2;
      DROP(BEAR,NEWLOC);
      VARY^.FIXED[BEAR]:=-1;
      VARY^.PROP[BEAR]:=3;
      IF VARY^.PROP[SPICES]<0 THEN
        VBL^.TALLY2:=VBL^.TALLY2+1;
      VBL^.OLDLC2:=NEWLOC;
      HE_DIED:=TRUE;
    END;
  END;
  EXIT(SET_NEW_LOC);
END;  { TROLLBRIDGE }
BEGIN { SET_NEW_LOC }
  KK:=ARY^.KEY[VBL^.LOC];
  IF KK=0 THEN
    ERRORHALT(26);
  NEWLOC:=VBL^.LOC;
  IF K=NULL THEN
    EXIT(SET_NEW_LOC);
  SKIPIT:=FALSE;
  IF K=BACK THEN
  BEGIN {BACK}
    SKIPIT:=TRUE;
    IF FORCED(K) THEN
      K:=VBL^.OLDLC2
    ELSE
      K:=VBL^.OLDLOC;
    VBL^.OLDLC2:=VBL^.OLDLOC;
    VBL^.OLDLOC:=VBL^.LOC;
    K2:=0;
    IF K=VBL^.LOC THEN
    BEGIN
      SPEAK(ARY^.RTEXT[91]);
      EXIT(SET_NEW_LOC);
    END;
    OK:=FALSE;
    KK:=KK-1;
    REPEAT
      KK:=KK+1;
      IF K=ARY^.TRAVEL2[KK] THEN
      BEGIN
        K:=ABS(ARY^.TRAVEL[KK]);
        KK:=ARY^.KEY[VBL^.LOC];
        OK:=TRUE;
      END
      ELSE
      BEGIN
        IF ARY^.TRAVEL2[KK]<=300 THEN
        BEGIN
          J:=ARY^.KEY[ARY^.TRAVEL2[KK]];
          IF FORCED(ARY^.TRAVEL2[KK]) AND (ARY^.TRAVEL2[J]=K) THEN
            K2:=KK;
        END;
        IF ARY^.TRAVEL[KK]<0 THEN
        BEGIN
          KK:=K2;
          IF KK=0 THEN
          BEGIN
            SPEAK(ARY^.RTEXT[140]);
            EXIT(SET_NEW_LOC);
          END;
          K:=ABS(ARY^.TRAVEL[KK]);
          KK:=ARY^.KEY[VBL^.LOC];
          OK:=TRUE;
        END;
      END;
    UNTIL OK OR (ARY^.TRAVEL2[KK]=K);
  END;   {BACK}
  IF K=LOOK THEN
  BEGIN {LOOK}
    IF VBL^.DETAIL<3 THEN
      SPEAK(ARY^.RTEXT[15]);
    VBL^.DETAIL:=VBL^.DETAIL+1;
    VBL^.WZDARK:=FALSE;
    VARY^.ABB[VBL^.LOC]:=0;
  END   {LOOK}
  ELSE  {LOOK}
    IF K=CAVE THEN
    BEGIN {CAVE}
      IF VBL^.LOC<8 THEN
        SPEAK(ARY^.RTEXT[57])
      ELSE
        SPEAK(ARY^.RTEXT[58]);
    END   {CAVE}
    ELSE  {CAVE}
    BEGIN {NOT SPECIAL}
      IF NOT SKIPIT THEN
      BEGIN
        VBL^.OLDLC2:=VBL^.OLDLOC;
        VBL^.OLDLOC:=VBL^.LOC;
      END;
      { TRAVEL  = VERB               }
      { TRAVEL2 = WHERE TO GO        }
      { TRAVEL3 = CONDITION (IF ANY) }
      KK:=KK-1;
      REPEAT
        KK:=KK+1;
        OK:=(ABS(ARY^.TRAVEL[KK])=1) OR (ABS(ARY^.TRAVEL[KK])=K);
      UNTIL OK OR (ARY^.TRAVEL[KK]<0);
      IF NOT OK THEN
      BEGIN
        SPK:=12;
        CASE K OF
          43,44,45,46,47,48,49,50,29,30 : SPK:=9;
          7,36,37 : SPK:=10;
          11,19 : SPK:=11;
          62,65 : SPK:=42;
          17 : SPK:=80;
        END;
        IF (VBL^.VERB=FIND) OR (VBL^.VERB=INVENTORY) THEN
          SPK:=59;
        SPEAK(ARY^.RTEXT[SPK]);
        EXIT(SET_NEW_LOC);
      END;
      REPEAT
        NEWLOC:=ARY^.TRAVEL2[KK];
        TVCOND:=ARY^.TRAVEL3[KK];
        K:=TVCOND MOD 100;
        IF K=0 THEN
        BEGIN
          T1:=FALSE;
          T2:=FALSE;
          T3:=FALSE;
        END
        ELSE
        BEGIN
          T1:=TOTING(K);
          T2:=AT(K);
          T3:=VARY^.PROP[K]<>(TVCOND DIV 100 -3)
        END;
        IF ((TVCOND<=100) AND 
            ((TVCOND=0) OR PERCENT(TVCOND))) OR
           ((TVCOND>100) AND (TVCOND<=300) AND 
            (T1 OR ((TVCOND>200) AND T2))) OR
           ((TVCOND>300) AND T3) THEN
        BEGIN
          IF NEWLOC<=300 THEN
            EXIT(SET_NEW_LOC);
          IF NEWLOC<=500 THEN
          BEGIN
             NEWLOC:=NEWLOC-300;
             IF NEWLOC=1 THEN
               PLOVERALCOVE
             ELSE
               IF NEWLOC=2 THEN
                 DROP(EMERALD,VBL^.LOC)
               ELSE
                 IF NEWLOC=3 THEN
                   TROLLBRIDGE
                 ELSE
                   ERRORHALT(20);
          END
          ELSE
          BEGIN
            SPEAK(ARY^.RTEXT[NEWLOC-500]);
            NEWLOC:=VBL^.LOC;
            EXIT(SET_NEW_LOC);
          END;
        END;
        REPEAT
          IF ARY^.TRAVEL[KK]<0 THEN
            ERRORHALT(25);
          KK:=KK+1;
        UNTIL (TVCOND<>ARY^.TRAVEL3[KK]) AND
              (NEWLOC<>ARY^.TRAVEL2[KK]);
      UNTIL FALSE; { EXIT IS BY EXIT PROC}
    END; {NOT SPECIAL}
END;  { SET_NEW_LOC }


========================================================================================
DOCUMENT :usus Folder:VOL09:advverb.text
========================================================================================

PROCEDURE LEAVE;
BEGIN {LEAVE}
  SKIPDWARF:=TRUE;
  SKIPDESCRIBE:=TRUE;
  IF SPK<>0 THEN
    SPEAK(ARY^.RTEXT[SPK]);
  EXIT(DOWHATHESAYS);
END;  {LEAVE}
PROCEDURE MISCXIT;
BEGIN {MISCXIT}
  IF (VBL^.OBJ=COINS) AND HERE(VEND_MACHINE) THEN
  BEGIN
    DESTROY(COINS);
    DROP(BATTERY,VBL^.LOC);
    PSPEAK(BATTERY,0);
    SPK:=0;
    LEAVE;
  END
  ELSE
    IF (VBL^.OBJ=BIRD) AND AT(DRAGON) AND
       (VARY^.PROP[DRAGON]=0) THEN
    BEGIN
      SPK:=154;
      DESTROY(BIRD);
      VARY^.PROP[BIRD]:=0;
      IF VARY^.PLACE[SNAKE]=ARY^.PLAC[SNAKE] THEN
        VBL^.TALLY2:=VBL^.TALLY2+1;
      LEAVE;
    END
    ELSE
      IF (VBL^.OBJ=BEAR) AND AT(TROLL) THEN
      BEGIN
        SPK:=163;
        MOVE(TROLL,0);
        MOVE(TROLL+100,0);
        MOVE(TROLL2,ARY^.PLAC[TROLL]);
        MOVE(TROLL2+100,ARY^.FIXD[TROLL]);
        JUGGLE(CHASM);
        VARY^.PROP[TROLL]:=2;
      END
      ELSE
        IF (VBL^.OBJ=VASE) AND (VBL^.LOC<>ARY^.PLAC[PILLOW]) THEN
        BEGIN
          SPK:=0;
          IF AT(PILLOW) THEN
            VARY^.PROP[VASE]:=0
          ELSE
          BEGIN
            VARY^.PROP[VASE]:=2;
            VARY^.FIXED[VASE]:=-1;
          END;
          PSPEAK(VASE,VARY^.PROP[VASE]+1);
        END
        ELSE
          SPK:=54;
END;  {MISCXIT}
PROCEDURE ASKWHATTODOITTO;
BEGIN {ASKWHATTODOITTO}
  WRITELN(WD1,WD1X,' WHAT?');
  VBL^.OBJ:=0;
  RESTART:=1;
  EXIT(DOWHATHESAYS);
END;  {ASKWHATTODOITTO}
PROCEDURE FILL_IT;
BEGIN {FILL_IT}
  IF VBL^.OBJ=VASE THEN
  BEGIN
    SPK:=29;
    IF LIQLOC(VBL^.LOC)=0 THEN
      SPK:=144;
    IF (LIQLOC(VBL^.LOC)=0) OR TOTING(VASE) THEN
      LEAVE;
    SPEAK(ARY^.RTEXT[145]);
    VARY^.PROP[VASE]:=2;
    VARY^.FIXED[VASE]:=-1;
    MISCXIT;
    LEAVE;
  END;
  IF (VBL^.OBJ<>0) AND (VBL^.OBJ<>BOTTLE) THEN
    LEAVE;
  IF (VBL^.OBJ=0) AND NOT HERE(BOTTLE) THEN
    ASKWHATTODOITTO;
  SPK:=107;
  IF LIQLOC(VBL^.LOC)=0 THEN
    SPK:=106;
  IF LIQ<>0 THEN
    SPK:=105;
  IF SPK<>107 THEN
    LEAVE;
  VARY^.PROP[BOTTLE]:=((VARY^.COND[VBL^.LOC] MOD 4) DIV 2) * 2;
  K:=LIQ;
  IF TOTING(BOTTLE) THEN
    VARY^.PLACE[K]:=-1;
  IF K=OIL THEN
    SPK:=108;
  LEAVE;
END;  {FILL_IT}
PROCEDURE CARRY_IT;
BEGIN {CARRY_IT}
  IF TOTING(VBL^.OBJ) THEN
    LEAVE;
  SPK:=25;
  IF (VBL^.OBJ=PLANT) AND (VARY^.PROP[PLANT]<=0) THEN
    SPK:=115;
  IF (VBL^.OBJ=BEAR) AND (VARY^.PROP[BEAR]=1) THEN
    SPK:=169;
  IF (VBL^.OBJ=CHAIN) AND (VARY^.PROP[BEAR]<>0) THEN
    SPK:=170;
  IF VARY^.FIXED[VBL^.OBJ]<>0 THEN
    LEAVE;
  IF (VBL^.OBJ=WATER) OR (VBL^.OBJ=OIL) THEN
  BEGIN
    IF HERE(BOTTLE) AND (LIQ=VBL^.OBJ) THEN
      VBL^.OBJ:=BOTTLE
    ELSE
    BEGIN
      VBL^.OBJ:=BOTTLE;
      IF VARY^.PROP[BOTTLE]<>1 THEN
        SPK:=105
      ELSE
        IF TOTING(BOTTLE) THEN
          FILL_IT
        ELSE
          SPK:=104;
      LEAVE;
    END;
  END;
  IF VBL^.HLDING>MAXHLD THEN
  BEGIN
    SPK:=92;
    LEAVE;
  END;
  IF (VBL^.OBJ=BIRD) AND (VARY^.PROP[BIRD]=0) THEN
  BEGIN
    IF TOTING(ROD) THEN
    BEGIN
      SPK:=26;
      LEAVE;
    END;
    IF NOT TOTING(CAGE) THEN
    BEGIN
      SPK:=27;
      LEAVE;
    END;
    VARY^.PROP[BIRD]:=1;
  END;
  IF ((VBL^.OBJ=BIRD) OR (VBL^.OBJ=CAGE)) AND
      (VARY^.PROP[BIRD]<>0) THEN
    CARRY(BIRD+CAGE-VBL^.OBJ,VBL^.LOC);
  CARRY(VBL^.OBJ,VBL^.LOC);
  K:=LIQ;
  IF (VBL^.OBJ=BOTTLE) AND (K<>0) THEN
    VARY^.PLACE[K]:=-1;
  SPK:=54;
  LEAVE;
END;  {CARRY_IT}
PROCEDURE DISTURBDWARVES;
BEGIN {DISTURBDWARVES}
  SPEAK(ARY^.RTEXT[136]);
  ALLDONE:=TRUE;
  EXIT(DOWHATHESAYS);
END;  {DISTURBDWARVES}
PROCEDURE DROP_IT;
BEGIN {DROP IT}
  IF TOTING(ROD2) AND (VBL^.OBJ=ROD) AND NOT TOTING(ROD) THEN
    VBL^.OBJ:=ROD2;
  IF NOT TOTING(VBL^.OBJ) THEN
    LEAVE;
  IF (VBL^.OBJ=BIRD) AND HERE(SNAKE) THEN
  BEGIN
    SPK:=30;
    IF VBL^.CLOSED THEN
      DISTURBDWARVES;
    DESTROY(SNAKE);
    VARY^.PROP[SNAKE]:=1;
  END
  ELSE
    MISCXIT;
  K:=LIQ;
  IF K=VBL^.OBJ THEN
    VBL^.OBJ:=BOTTLE;
  IF (VBL^.OBJ=BOTTLE) AND (K<>0) THEN
    VARY^.PLACE[K]:=0;
  IF (VBL^.OBJ=CAGE) AND (VARY^.PROP[BIRD]<>0) THEN
    DROP(BIRD,VBL^.LOC);
  IF VBL^.OBJ=BIRD THEN
    VARY^.PROP[BIRD]:=0;
  DROP(VBL^.OBJ,VBL^.LOC);
  LEAVE;
END;  {DROP IT}
PROCEDURE SAY_IT;
VAR
  I : INTEGER;
BEGIN {SAY_IT}
  IF WD2='' THEN
  BEGIN
    WD2:=WD1;
    WD2X:=WD1X;
  END;
  I:=VOCAB(WD2,-1);
  IF (I=62) OR (I=65) OR (I=71) OR (I=2025) THEN
    RESTART:=1
  ELSE
    WRITELN('OKAY, "',WD2,WD2X,'"');
END;  {SAY_IT}
PROCEDURE L_U_IT;
BEGIN {L_U_IT}
  IF (VBL^.OBJ=CLAM) OR (VBL^.OBJ=OYSTER) THEN
  BEGIN
    IF VBL^.OBJ=OYSTER THEN
      K:=1
    ELSE
      K:=0;
    SPK:=124+K;
    IF TOTING(VBL^.OBJ) THEN
      SPK:=120+K;
    IF NOT TOTING(TRIDENT) THEN
      SPK:=122+K;
    IF VBL^.VERB=LOCK THEN
      SPK:=61;
    IF SPK=124 THEN
    BEGIN
      DESTROY(CLAM);
      DROP(OYSTER,VBL^.LOC);
      DROP(PEARL,105);
    END;
    LEAVE;
  END;
  IF VBL^.OBJ=DOOR THEN
    SPK:=111;
  IF (VBL^.OBJ=DOOR) AND (VARY^.PROP[DOOR]=1) THEN
    SPK:=54;
  IF VBL^.OBJ=CAGE THEN
    SPK:=32;
  IF VBL^.OBJ=KEYS THEN
    SPK:=55;
  IF (VBL^.OBJ=GRATE) OR (VBL^.OBJ=CHAIN) THEN
    SPK:=31;
  IF (SPK=31) AND HERE(KEYS) THEN
  BEGIN {KEYS HERE}
    IF VBL^.OBJ=CHAIN THEN
    BEGIN
      IF VBL^.VERB=LOCK THEN
      BEGIN
        IF VARY^.PROP[CHAIN]<>0 THEN
          SPK:=34
        ELSE
          IF VBL^.LOC<>ARY^.PLAC[CHAIN] THEN
            SPK:=173
          ELSE
          BEGIN
            SPK:=172;
            VARY^.PROP[CHAIN]:=2;
            IF TOTING(CHAIN) THEN
              DROP(CHAIN,VBL^.LOC);
            VARY^.FIXED[CHAIN]:=-1;
          END;
      END
      ELSE
      BEGIN
        IF VARY^.PROP[BEAR]=0 THEN
          SPK:=41
        ELSE
          IF VARY^.PROP[CHAIN]=0 THEN
            SPK:=37
          ELSE
          BEGIN
            SPK:=171;
            VARY^.PROP[CHAIN]:=0;
            VARY^.FIXED[CHAIN]:=0;
            IF VARY^.PROP[BEAR]<>3 THEN
              VARY^.PROP[BEAR]:=2;
            VARY^.FIXED[BEAR]:=2-VARY^.PROP[BEAR];
          END;
      END
    END
    ELSE
      IF VBL^.CLOSING THEN
      BEGIN
        SPK:=130;
        IF NOT VBL^.PANIC THEN
          VBL^.CLOCK2:=15;
        VBL^.PANIC:=TRUE;
      END
      ELSE
      BEGIN
        SPK:=34+VARY^.PROP[GRATE];
        IF VBL^.VERB=LOCK THEN
          VARY^.PROP[GRATE]:=0
        ELSE
        BEGIN
          SPK:=SPK+2;
          VARY^.PROP[GRATE]:=1;
        END;
      END;
  END;
  LEAVE;
END;  {L_U_IT}
PROCEDURE SAY_OK;
BEGIN {SAY_OK}
  SPK:=54;
  LEAVE;
END;  {SAY_OK}
PROCEDURE LAMP_ON;
BEGIN {LAMP_ON}
  IF HERE(LAMP) THEN
    IF VBL^.LIMIT<0 THEN
      SPK:=184
    ELSE
    BEGIN
      VARY^.PROP[LAMP]:=1;
      SPK:=0;
      SPEAK(ARY^.RTEXT[39]);
      SKIPDWARF:=TRUE;
      IF VBL^.WZDARK THEN
        EXIT(DOWHATHESAYS);
    END;
  LEAVE;
END;  {LAMP_ON}
PROCEDURE LAMP_OFF;
BEGIN {LAMP_OFF}
  IF HERE(LAMP) THEN
  BEGIN
    VARY^.PROP[LAMP]:=0;
    SPEAK(ARY^.RTEXT[40]);
    IF DARK THEN
      SPK:=16
    ELSE
      SPK:=0;
  END;
  LEAVE;
END;  {LAMP_OFF}
PROCEDURE WAVE_IT;
BEGIN {WAVE_IT}
  IF (NOT TOTING(VBL^.OBJ)) AND
     ((VBL^.OBJ<>ROD) OR NOT TOTING(ROD2)) THEN
    SPK:=29;
  IF (VBL^.OBJ=ROD) AND AT(FISSURE) AND TOTING(VBL^.OBJ) AND
     NOT VBL^.CLOSING  THEN
  BEGIN
    SPK:=0;
    VARY^.PROP[FISSURE]:=1-VARY^.PROP[FISSURE];
    PSPEAK(FISSURE,2-VARY^.PROP[FISSURE]);
  END;
  LEAVE;
END;  {WAVE_IT}
PROCEDURE KILL_IT;
VAR
  I,J : INTEGER;
BEGIN {KILL_IT}
  I:=0;
  FOR J:=1 TO 5 DO
    IF (VARY^.DLOC[J]=VBL^.LOC) AND (VBL^.DFLAG>=2) THEN
    BEGIN
      I:=J;
      J:=5;
    END;
  IF VBL^.OBJ=0 THEN
  BEGIN
    IF I<>0 THEN
      VBL^.OBJ:=DWARF;
    IF HERE(SNAKE) THEN
      VBL^.OBJ:=VBL^.OBJ*100 + SNAKE;
    IF AT(DRAGON) AND (VARY^.PROP[DRAGON]=0) THEN
      VBL^.OBJ:=VBL^.OBJ*100 + DRAGON;
    IF AT(TROLL) THEN
      VBL^.OBJ:=VBL^.OBJ*100 + TROLL;
    IF HERE(BEAR) AND (VARY^.PROP[BEAR]=0) THEN
      VBL^.OBJ:=VBL^.OBJ*100 + BEAR;
    IF VBL^.OBJ>100 THEN
      ASKWHATTODOITTO;
    IF VBL^.OBJ=0 THEN
    BEGIN
      IF HERE(BIRD) AND (VBL^.VERB<>THROW) THEN
        VBL^.OBJ:=BIRD;
      IF HERE(CLAM) OR HERE(OYSTER) THEN
        VBL^.OBJ:=VBL^.OBJ*100 + CLAM;
      IF VBL^.OBJ>100 THEN
        ASKWHATTODOITTO;
    END;
  END;
  IF VBL^.OBJ=BIRD THEN
  BEGIN
    SPK:=137;
    IF VBL^.CLOSED THEN
      LEAVE;
    DESTROY(BIRD);
    VARY^.PROP[BIRD]:=0;
    IF VARY^.PLACE[SNAKE]=ARY^.PLAC[SNAKE] THEN
      VBL^.TALLY2:=VBL^.TALLY2+1;
    SPK:=45;
  END;
  IF VBL^.OBJ=0 THEN
    SPK:=44;
  IF (VBL^.OBJ=CLAM) OR (VBL^.OBJ=OYSTER) THEN
    SPK:=150;
  IF VBL^.OBJ=SNAKE THEN
    SPK:=46;
  IF VBL^.OBJ=DWARF THEN
    SPK:=49;
  IF (VBL^.OBJ=DWARF) AND VBL^.CLOSED THEN
    DISTURBDWARVES;
  IF VBL^.OBJ=DRAGON THEN
    SPK:=167;
  IF VBL^.OBJ=TROLL THEN
    SPK:=157;
  IF VBL^.OBJ=BEAR THEN
    SPK:=165+(VARY^.PROP[BEAR]+1) DIV 2;
  IF (VBL^.OBJ<>DRAGON) OR (VARY^.PROP[DRAGON]<>0) THEN
    LEAVE;
  VBL^.VERB:=0;
  VBL^.OBJ:=0;
  IF NOT YES(49,0,0) THEN
  BEGIN
    RESTART:=2;
    SPK:=0;
    LEAVE;
  END;
  PSPEAK(DRAGON,1);
  VARY^.PROP[DRAGON]:=2;
  VARY^.PROP[RUG]:=0;
  K:=(ARY^.PLAC[DRAGON]+VARY^.FIXED[DRAGON]) DIV 2;
  MOVE(DRAGON+100,-1);
  MOVE(RUG+100,0);
  MOVE(DRAGON,K);
  MOVE(RUG,K);
  FOR I:=1 TO 100 DO
    IF (VARY^.PLACE[I]=ARY^.PLAC[DRAGON]) OR
       (VARY^.PLACE[I]=ARY^.FIXD[DRAGON]) THEN
      MOVE(I,K);
  VBL^.LOC:=K;
  K:=NULL;
  SET_NEW_LOC;
  EXIT(DOWHATHESAYS);
END;  {KILL_IT}
PROCEDURE POUR_IT;
BEGIN {POUR_IT}
  IF (VBL^.OBJ=BOTTLE) OR (VBL^.OBJ=0) THEN
    VBL^.OBJ:=LIQ;
  IF VBL^.OBJ=0 THEN
    ASKWHATTODOITTO;
  IF NOT TOTING(VBL^.OBJ) THEN
    LEAVE;
  SPK:=78;
  IF (VBL^.OBJ<>WATER) AND (VBL^.OBJ<>OIL) THEN
    LEAVE;
  VARY^.PROP[BOTTLE]:=1;
  VARY^.PLACE[VBL^.OBJ]:=0;
  SPK:=77;
  IF NOT (AT(PLANT) OR AT(DOOR)) THEN
    LEAVE;
  IF AT(DOOR) THEN
  BEGIN
    IF VBL^.OBJ=OIL THEN
    BEGIN
      SPK:=114;
      VARY^.PROP[DOOR]:=1;
    END
    ELSE
    BEGIN
      SPK:=113;
      VARY^.PROP[DOOR]:=0;
    END;
    LEAVE;
  END;
  SPK:=112;
  IF VBL^.OBJ<>WATER THEN
    LEAVE;
  PSPEAK(PLANT,VARY^.PROP[PLANT]+1);
  VARY^.PROP[PLANT]:=(VARY^.PROP[PLANT]+2) MOD 6;
  VARY^.PROP[PLANT2]:=VARY^.PROP[PLANT] DIV 2;
  K:=NULL;
  SET_NEW_LOC;
  EXIT(DOWHATHESAYS);
END;  {POUR_IT}
PROCEDURE EAT_IT;
BEGIN {EAT_IT}
  IF VBL^.OBJ=FOOD THEN
  BEGIN
    DESTROY(FOOD);
    SPK:=72;
    LEAVE;
  END;
  IF (VBL^.OBJ=BIRD) OR (VBL^.OBJ=SNAKE) OR (VBL^.OBJ=CLAM) OR
     (VBL^.OBJ=OYSTER) OR (VBL^.OBJ=DWARF) OR (VBL^.OBJ=DRAGON) OR
     (VBL^.OBJ=TROLL) OR (VBL^.OBJ=BEAR) THEN
    SPK:=71;
  LEAVE;
END;  {EAT_IT}
PROCEDURE DRINK_IT;
VAR 
  I : INTEGER;
BEGIN {DRINK_IT}
  IF (VBL^.OBJ=0) AND (LIQLOC(VBL^.LOC)<>WATER) AND
     ((LIQ<>WATER) OR NOT HERE(BOTTLE)) THEN
    ASKWHATTODOITTO;
  IF (VBL^.OBJ<>0) AND (VBL^.OBJ<>WATER) THEN
    SPK:=110;
  IF (SPK=110) OR (LIQ<>WATER) OR NOT HERE(BOTTLE) THEN
    LEAVE;
  VARY^.PROP[BOTTLE]:=1;
  VARY^.PLACE[WATER]:=0;
  SPK:=74;
  LEAVE;
END;  {DRINK_IT}
PROCEDURE RUB_IT;
BEGIN {RUB_IT}
  IF VBL^.OBJ<>LAMP THEN
    SPK:=76;
  LEAVE;
END;  {RUB_IT}
PROCEDURE FEED_IT;
BEGIN {FEED_IT}
  IF VBL^.OBJ=BIRD THEN
  BEGIN
    SPK:=100;
    LEAVE;
  END;
  IF (VBL^.OBJ=SNAKE) OR (VBL^.OBJ=DRAGON) OR (VBL^.OBJ=TROLL) THEN
  BEGIN
    IF (VBL^.OBJ=DRAGON) AND (VARY^.PROP[DRAGON]<>0) THEN
      SPK:=110;
    IF VBL^.OBJ=TROLL THEN
      SPK:=182;
    IF (VBL^.OBJ<>SNAKE) OR VBL^.CLOSED OR NOT HERE(BIRD) THEN
      LEAVE;
    SPK:=101;
    DESTROY(BIRD);
    VARY^.PROP[BIRD]:=0;
    VBL^.TALLY2:=VBL^.TALLY2+1;
    LEAVE;
  END;
  IF VBL^.OBJ=DWARF THEN
  BEGIN
    IF NOT HERE(FOOD) THEN
      LEAVE;
    SPK:=103;
    VBL^.DFLAG:=VBL^.DFLAG+1;
    LEAVE;
  END;
  IF VBL^.OBJ=BEAR THEN
  BEGIN
    IF VARY^.PROP[BEAR]=0 THEN
      SPK:=102;
    IF VARY^.PROP[BEAR]=3 THEN
      SPK:=110;
    IF NOT HERE(FOOD) THEN
      LEAVE;
    DESTROY(FOOD);
    VARY^.PROP[BEAR]:=1;
    VARY^.FIXED[AXE]:=0;
    VARY^.PROP[AXE]:=0;
    SPK:=168;
    LEAVE;
  END;
  SPK:=14;
  LEAVE;
END;  {FEED_IT}
PROCEDURE TOSS_IT;
VAR
  I : INTEGER;
PROCEDURE TOSS_IT_AWAY;
BEGIN {TOSS_IT_AWAY}
  SPEAK(ARY^.RTEXT[SPK]);
  DROP(AXE,VBL^.LOC);
  K:=NULL;
  SET_NEW_LOC;
  EXIT(DOWHATHESAYS);
END;  {TOSS_IT_AWAY}
BEGIN {TOSS_IT}
  IF TOTING(ROD2) AND (VBL^.OBJ=ROD) AND NOT TOTING(ROD) THEN
    VBL^.OBJ:=ROD2;
  IF NOT TOTING(VBL^.OBJ) THEN
    LEAVE;
  IF (VBL^.OBJ>=50) AND (VBL^.OBJ<=MAXTRS) AND AT(TROLL) THEN
  BEGIN
    SPK:=159;
    DROP(VBL^.OBJ,0);
    MOVE(TROLL,0);
    MOVE(TROLL+100,0);
    DROP(TROLL2,ARY^.PLAC[TROLL]);
    DROP(TROLL2+100,ARY^.FIXD[TROLL]);
    JUGGLE(CHASM);
    LEAVE;
  END;
  IF (VBL^.OBJ=FOOD) AND HERE(BEAR) THEN
  BEGIN
    VBL^.OBJ:=BEAR;
    FEED_IT;
  END;
  IF VBL^.OBJ<>AXE THEN
    DROP_IT;
  FOR I:=1 TO 5 DO
  BEGIN
    IF VARY^.DLOC[I]=VBL^.LOC THEN
    BEGIN
      SPK:=48;
      IF RAN(3)<>0 THEN
      BEGIN
        VARY^.DSEEN[I]:=FALSE;
        VARY^.DLOC[I]:=0;
        SPK:=47;
        VBL^.DKILL:=VBL^.DKILL+1;
        IF VBL^.DKILL=1 THEN
          SPK:=149;
      END;
      TOSS_IT_AWAY;
    END;
  END;
  SPK:=152;
  IF AT(DRAGON) AND (VARY^.PROP[DRAGON]=0) THEN
    TOSS_IT_AWAY;
  SPK:=158;
  IF AT(TROLL) THEN
    TOSS_IT_AWAY;
  IF HERE(BEAR) AND (VARY^.PROP[BEAR]=0) THEN
  BEGIN
    SPK:=164;
    DROP(AXE,VBL^.LOC);
    VARY^.FIXED[AXE]:=-1;
    VARY^.PROP[AXE]:=1;
    JUGGLE(BEAR);
    LEAVE;
  END;
  VBL^.OBJ:=0;
  KILL_IT;
END;  {TOSS_IT}
PROCEDURE FIND_IT;
VAR 
  I : INTEGER;
BEGIN {FIND_IT}
  IF AT(VBL^.OBJ) OR ((LIQ=VBL^.OBJ) AND AT(BOTTLE)) OR
     (K=LIQLOC(VBL^.LOC)) THEN
    SPK:=94;
  IF VBL^.OBJ=DWARF THEN
    FOR I:=1 TO 6 DO
      IF (VARY^.DLOC[I]=VBL^.LOC) AND (VBL^.DFLAG>=2) THEN
        SPK:=94;
  IF VBL^.CLOSED THEN
    SPK:=138;
  IF TOTING(VBL^.OBJ) THEN
    SPK:=24;
  LEAVE;
END;  {FIND_IT}
PROCEDURE BLAST_IT;
BEGIN {BLAST_IT}
  IF (VARY^.PROP[ROD2]<0) OR NOT VBL^.CLOSED THEN
    LEAVE;
  BONUS:=133;
  IF VBL^.LOC=115 THEN
    BONUS:=134;
  IF HERE(ROD2) THEN
    BONUS:=135;
  SPEAK(ARY^.RTEXT[BONUS]);
  ALLDONE:=TRUE;
  EXIT(DOWHATHESAYS);
END;  {BLAST_IT}
PROCEDURE READ_IT;
BEGIN {READ_IT}
  IF DARK THEN
  BEGIN
    WRITELN('I SEE NO ',WD1,WD1X,' HERE.');
    SPK:=0;
    LEAVE;
  END;
  IF VBL^.OBJ=MAGAZINE THEN
    SPK:=190;
  IF VBL^.OBJ=TABLET THEN
    SPK:=196;
  IF VBL^.OBJ=MESSAGE THEN
    SPK:=191;
  IF (VBL^.OBJ=OYSTER) AND VARY^.HINTED[2] AND TOTING(OYSTER) THEN
    SPK:=194;
  IF (VBL^.OBJ<>OYSTER) OR VARY^.HINTED[2] OR 
     NOT TOTING(OYSTER) OR NOT VBL^.CLOSED THEN
    LEAVE;
  VARY^.HINTED[2]:=YES(192,193,54);
  SPK:=0;
  LEAVE;
END;  {READ_IT}
PROCEDURE BREAK_IT;
BEGIN {BREAK_IT}
  IF VBL^.OBJ=MIRROR THEN
    SPK:=148;
  IF (VBL^.OBJ=VASE) AND (VARY^.PROP[VASE]=0) THEN
  BEGIN
    SPK:=198;
    IF TOTING(VASE) THEN
      DROP(VASE,VBL^.LOC);
    VARY^.PROP[VASE]:=2;
    VARY^.FIXED[VASE]:=-1;
    LEAVE;
  END
  ELSE
  BEGIN
    IF (VBL^.OBJ<>MIRROR) OR NOT VBL^.CLOSED THEN
      LEAVE;
    SPEAK(ARY^.RTEXT[197]);
    DISTURBDWARVES;
  END;
END;  {BREAK_IT}
PROCEDURE WAKE_IT;
BEGIN {WAKE_IT}
  IF (VBL^.OBJ<>DWARF) OR NOT VBL^.CLOSED THEN
    LEAVE;
  SPEAK(ARY^.RTEXT[199]);
  DISTURBDWARVES;
END;  {WAKE_IT}
PROCEDURE CARRY_SOMETHING;
VAR
  I : INTEGER;
BEGIN {CARRY_SOMETHING}
  IF (VARY^.ATLOC[VBL^.LOC]=0)  THEN
    ASKWHATTODOITTO;
  IF VARY^.LINK[VARY^.ATLOC[VBL^.LOC]]<>0 THEN
    ASKWHATTODOITTO;
  FOR I:=1 TO 5 DO
    IF (VARY^.DLOC[I]=VBL^.LOC) AND (VBL^.DFLAG>=2) THEN
      ASKWHATTODOITTO;
  VBL^.OBJ:=VARY^.ATLOC[VBL^.LOC];
  CARRY_IT;
END;  {CARRY_SOMETHING}
PROCEDURE L_U_SOMETHING;
BEGIN {L_U_SOMETHING}
  SPK:=28;
  IF HERE(CLAM) THEN
    VBL^.OBJ:=CLAM;
  IF HERE(OYSTER) THEN
    VBL^.OBJ:=OYSTER;
  IF AT(DOOR) THEN
    VBL^.OBJ:=DOOR;
  IF AT(GRATE) THEN
    VBL^.OBJ:=GRATE;
  IF (VBL^.OBJ<>0) AND HERE(CHAIN) THEN
    ASKWHATTODOITTO;
  IF HERE(CHAIN) THEN
    VBL^.OBJ:=CHAIN;
  IF VBL^.OBJ=0 THEN
    LEAVE;
  L_U_IT;
END;  {L_U_SOMETHING}
PROCEDURE EAT_SOMETHING;
BEGIN {EAT_SOMETHING}
  IF NOT HERE(FOOD) THEN
    ASKWHATTODOITTO;
  VBL^.OBJ:=FOOD;
  EAT_IT;
END;  {EAT_SOMETHING}
PROCEDURE QUIT2;
BEGIN {QUIT2}
  ALLDONE:=GAVEUP;
  IF GAVEUP THEN
    EXIT(DOWHATHESAYS);
  SPK:=0;
  LEAVE;
END;  {QUIT2}
PROCEDURE QUIT;
BEGIN {QUIT}
  GAVEUP:=YES(22,54,54);
  QUIT2;
END;  {QUIT}
PROCEDURE REPORT;
VAR
  I : INTEGER;
BEGIN {REPORT - INVENTORY}
  SPK:=98;
  FOR I:=1 TO 100 DO
    IF (I<>BEAR) AND TOTING(I) THEN
    BEGIN
      IF SPK=98 THEN
        SPEAK(ARY^.RTEXT[99]);
      PSPEAK(I,-1);
      SPK:=0;
    END;
  IF TOTING(BEAR) THEN
    SPK:=141;
  LEAVE;
END;  {REPORT}
PROCEDURE REPORT_SCORE;
BEGIN {REPORT_SCORE}
  SCORE:=GETSCORE(TRUE);
  WRITELN('IF YOU WERE TO QUIT NOW, YOU WOULD SCORE');
  WRITELN(SCORE,' OUT OF A POSSIBLE ',MAXSCORE);
  GAVEUP:=YES(143,54,54);
  QUIT2;
END;  {REPORT_SCORE}
PROCEDURE WORD_FOO;
BEGIN {WORD_FOO}
  K:=VOCAB(WD1,3);
  SPK:=42;
  IF VBL^.FOOBAR=1-K THEN
  BEGIN
    VBL^.FOOBAR:=K;
    IF K<>4 THEN
    BEGIN
      SPK:=54;
      LEAVE;
    END;
    IF (VARY^.PLACE[EGGS]=ARY^.PLAC[EGGS]) OR
       (TOTING(EGGS) AND (VBL^.LOC=ARY^.PLAC[EGGS])) THEN
      LEAVE;
    IF (VARY^.PLACE[EGGS]=0) AND (VARY^.PLACE[TROLL]=0) AND
       (VARY^.PROP[TROLL]=0) THEN
      VARY^.PROP[TROLL]:=1;
    K:=2;
    IF HERE(EGGS) THEN
      K:=1;
    IF VBL^.LOC=ARY^.PLAC[EGGS] THEN
      K:=0;
    MOVE(EGGS,ARY^.PLAC[EGGS]);
    PSPEAK(EGGS,K);
    SPK:=0;
    LEAVE;
  END;
  IF VBL^.FOOBAR<>0 THEN
    SPK:=151;
  LEAVE;
END;  {WORD_FOO}
PROCEDURE SET_BRIEF;
BEGIN {SET_BRIEF}
  SPK:=156;
  VBL^.ABBNUM:=10000;
  VBL^.DETAIL:=3;
  LEAVE;
END;  {SET_BRIEF}
PROCEDURE READ_SOMETHING;
BEGIN {READ_SOMETHING}
  IF HERE(MAGAZINE) THEN
    VBL^.OBJ:=MAGAZINE;
  IF HERE(TABLET) THEN
    VBL^.OBJ:=VBL^.OBJ*100 + TABLET;
  IF HERE(MESSAGE) THEN
    VBL^.OBJ:=VBL^.OBJ*100 + MESSAGE;
  IF VBL^.CLOSED AND TOTING(OYSTER) THEN
    VBL^.OBJ:=OYSTER;
  IF (VBL^.OBJ>100) OR (VBL^.OBJ=0) OR DARK THEN
    ASKWHATTODOITTO;
  READ_IT;
END;  {READ_SOMETHING}
PROCEDURE SUSPEND;
PROCEDURE SUSPEXIT;
BEGIN { SUSPEXIT }
  WRITELN('ERROR SUSPENDING GAME');
  CLOSE(INFILE);
  EXIT(SUSPEND);
END;  { SUSPEXIT }
BEGIN { SUSPEND }
  NAMEANDPW;
  VBL^.PASSWORD:=TESTPW;
  VBL^.VERSION:=VERSION;
  REWRITE(INFILE,NAMEOFUSER);
  I:=(SIZEOF(VARYS)+511) DIV 512;
  IF I<>BLOCKWRITE(INFILE,VARY^.DBLK,I) THEN
    SUSPEXIT;
  I:=(SIZEOF(VBLS)+511) DIV 512;
  IF I<>BLOCKWRITE(INFILE,VBL^.DBLK,I) THEN
    SUSPEXIT;
  CLOSE(INFILE,LOCK);
  WRITELN;
  WRITE('ADVENTURE GAME SAVED AS ',NAMEOFUSER);
  EXIT(ADVENTURE);
END;  { SUSPEND }
PROCEDURE ANALANITVERB;
BEGIN {ANALANITVERB}
  CASE VBL^.VERB OF
    1: CARRY_SOMETHING; { TAKE }
    2: ASKWHATTODOITTO; { DROP }
    3: ASKWHATTODOITTO; { SAY }
    4: L_U_SOMETHING;   { OPEN }
    5: SAY_OK;          { NOTHING }
    6: L_U_SOMETHING;   { LOCK }
    7: LAMP_ON;         { ON }
    8: LAMP_OFF;        { OFF }
    9: ASKWHATTODOITTO; { WAVE }
   10: ASKWHATTODOITTO; { CALM }
   11: LEAVE;           { WALK }
   12: KILL_IT;         { KILL }
   13: POUR_IT;         { POUR }
   14: EAT_SOMETHING;   { EAT }
   15: DRINK_IT;        { DRINK }
   16: ASKWHATTODOITTO; { RUB }
   17: ASKWHATTODOITTO; { TOSS }
   18: QUIT;            { QUIT }
   19: ASKWHATTODOITTO; { FIND }
   20: REPORT;          { INVENTORY }
   21: ASKWHATTODOITTO; { FEED }
   22: FILL_IT;         { FILL }
   23: BLAST_IT;        { BLAST }
   24: REPORT_SCORE;    { SCORE }
   25: WORD_FOO;        { FOO }
   26: SET_BRIEF;       { BRIEF }
   27: READ_SOMETHING;  { READ }
   28: ASKWHATTODOITTO; { BREAK }
   29: ASKWHATTODOITTO; { WAKE }
   30: SUSPEND;         { SUSPEND }
  END; {CASE}
  IF VBL^.VERB>29 THEN
    ERRORHALT(23);
END;  {ANALANITVERB}
PROCEDURE ANALATVERB;
BEGIN {ANALATVERB}
  CASE VBL^.VERB OF
    1: CARRY_IT;        { TAKE }
    2: DROP_IT;         { DROP }
    3: SAY_IT;          { SAY }
    4: L_U_IT;          { OPEN }
    5: SAY_OK;          { NOTHING }
    6: L_U_IT;          { LOCK }
    7: LAMP_ON;         { ON }
    8: LAMP_OFF;        { OFF }
    9: WAVE_IT;         { WAVE }
   10: LEAVE;           { CALM }
   11: LEAVE;           { WALK }
   12: KILL_IT;         { KILL }
   13: POUR_IT;         { POUR }
   14: EAT_IT;          { EAT }
   15: DRINK_IT;        { DRINK }
   16: RUB_IT;          { RUB }
   17: TOSS_IT;         { TOSS }
   18: LEAVE;           { QUIT }
   19: FIND_IT;         { FIND }
   20: FIND_IT;         { INVENTORY }
   21: FEED_IT;         { FEED }
   22: FILL_IT;         { FILL }
   23: BLAST_IT;        { BLAST }
   24: LEAVE;           { SCORE }
   25: LEAVE;           { FOO }
   26: LEAVE;           { BRIEF }
   27: READ_IT;         { READ }
   28: BREAK_IT;        { BREAK }
   29: WAKE_IT;         { WAKE }
   30: SUSPEND;         { SUSPEND }
  END; {CASE}
  IF VBL^.VERB>29 THEN
    ERRORHALT(24);
END;  {ANALATVERB}


========================================================================================
DOCUMENT :usus Folder:VOL09:castles.text
========================================================================================

PROGRAM CASTLES;                        
{A WARGAME}

CONST CLEARSCREEN = 89; 
      CSPREFIX = 27;
TYPE    GAME = RECORD
                PLACE   : ARRAY[1..7,1..7] OF CHAR;
                POP     : ARRAY[1..7,1..7] OF INTEGER;
                OWN     : ARRAY[1..7,1..7] OF INTEGER;
                TROOPS  : ARRAY[1..7,1..7] OF INTEGER;
                NAME    : ARRAY[1..4] OF STRING[12];
                MONEY   : ARRAY[1..4] OF REAL;
                ARMY    : ARRAY[1..4] OF INTEGER;
                SEQ     : ARRAY[1..4] OF INTEGER;
                TAX     : ARRAY[1..4] OF REAL;
                TAXBASE : ARRAY[1..4] OF INTEGER;
                CAS     : ARRAY[1..4] OF INTEGER;
                PAY     : ARRAY[1..4] OF REAL;
                NUMP    : INTEGER;
                TURN    : INTEGER;
                ROUND   : INTEGER;
                PTURN   : INTEGER;
                ROUNDSINTURN    : INTEGER;
               END; {RECORD - GAME}
                
VAR     SEED : REAL;
        DATA : GAME;
        GAMEDATA : FILE OF GAME;
        I,J,K,POSITION : INTEGER; 
        RESTART : BOOLEAN;
        VALID : SET OF 11..77;
        ANS,S,PD : STRING;
        AN : CHAR;
        ATLEASTONEPLAYERIN,ALLBUTONEPLAYEROUT : BOOLEAN; 
        
        
                
FUNCTION RANDOM : REAL;
BEGIN
        SEED := SEED * 27.182813 + 31.415917; 
        SEED := SEED - TRUNC(SEED);                    
        RANDOM := SEED;    
END; {RANDOM}

FUNCTION RND(LOW, HIGH : INTEGER):INTEGER;       
VAR RANGE : INTEGER;           
BEGIN
        RANGE := HIGH - LOW + 1;
        RND := TRUNC(RANDOM * RANGE + LOW);
END; {RND}

PROCEDURE SEQIT;
VAR I, J, SWAP : INTEGER;
BEGIN WITH DATA DO BEGIN
        FOR I := 1 TO NUMP-1 DO
        BEGIN
               J := RND(I,NUMP);
               SWAP := SEQ[I];
               SEQ[I] := SEQ[J];
               SEQ[J] := SWAP;
        END;
END; END; {SEQIT}

PROCEDURE SPLIT(VAR ST : STRING);
BEGIN {SPLIT}
     IF POSITION < LENGTH(ANS) THEN IF NOT(ANS[POSITION] IN ['0'..'9']) THEN
     REPEAT 
        POSITION := POSITION + 1;
     UNTIL (POSITION = LENGTH(ANS)) OR (ANS[POSITION] IN ['0'..'9']);
     
     IF POSITION < LENGTH(ANS) THEN IF ANS[POSITION] IN ['0'..'9'] THEN
     REPEAT 
        ST := CONCAT(ST,COPY(ANS,POSITION,1)); 
        POSITION := POSITION+1;
     UNTIL (NOT(ANS[POSITION] IN ['0'..'9'])) OR (POSITION = LENGTH(ANS));
     
     IF POSITION <= LENGTH(ANS) THEN
     BEGIN 
        IF ANS[POSITION] IN ['0'..'9'] THEN ST := CONCAT(ST,COPY(ANS,POSITION,1));                     
        POSITION := POSITION + 1;    
     END;
END; {SPLIT}      

PROCEDURE CONVERT(VAR STR : STRING; VAR INT : INTEGER);   
VAR     I,L,M : INTEGER;
BEGIN {CONVERT}      
   L := 2; {MAXIMUM NUMBER OF DIGITS TO CONVERT - FROM LEFT}
   L := LENGTH(STR) - L + 1;
   IF L < 1 THEN L := 1;
   M := 1;
   INT := 0;
   FOR I := LENGTH(STR) DOWNTO L DO   
   BEGIN
           INT := INT + (ORD(STR[I])-48) * M;
           M := M * 10;
   END;
END;{CONVERT}

PROCEDURE CLEARTHESCREEN;
BEGIN
        GOTOXY(0,0);
        WRITELN(CHR(CSPREFIX),CHR(CLEARSCREEN)); 
END; {CLEARTHESCREEN}

PROCEDURE OUTMSG;    
 BEGIN WITH DATA DO
 BEGIN 
  CLEARTHESCREEN;
  WRITELN('THE GAME IS OVER ...........');
  FOR I := 1 TO NUMP DO
   BEGIN
    IF ARMY[I] > 0 THEN BEGIN
     WRITELN;
     WRITELN;
     WRITELN('WARLORD ',NAME[I],',');
     WRITELN;
     WRITELN('THE WAR IS OVER, BUT THE GAME HAS JUST BEGUN........');
     FOR J := 1 TO 10000 DO BEGIN END;
     WRITELN;
     WRITELN; 
     WRITELN('YOU HAVE CONQUERED THE WHOLE OF THE LAND ... ');
     WRITELN;
     FOR J := 1 TO 10000 DO BEGIN END;
     WRITE('WARLORD'); 
     IF NUMP > 2 THEN WRITE('S');
     FOR J := 1 TO NUMP DO  
      BEGIN
       IF J<>I THEN 
        BEGIN
         WRITE(' ');
         IF (NUMP>2) AND ((J=NUMP) OR ((J=NUMP-1) AND (I=NUMP))) THEN  
          WRITE('AND '); 
         WRITE(NAME[J]);
         IF NUMP>3 THEN WRITE(',');
        END;
       END;
       IF NUMP > 2 THEN WRITE(' HAVE') ELSE WRITE(' HAS');   
       WRITELN(' BEEN');
       WRITELN('SUBJIGATED TO YOUR WILL AND COMMAND .............');  
       FOR J := 1 TO 10000 DO BEGIN END;
       WRITELN;
       WRITELN;
       WRITELN('IT IS UP TO YOU NOW TO THINK OF A JUST AND LASTING');
       WRITE('REWARD FOR THE PERSON');
       IF NUMP>2 THEN WRITE('S');
       WRITE(' WHO '); 
       IF NUMP>2 THEN WRITE('HAVE ') ELSE WRITE('HAS ');
       WRITELN('CAUSED YOU SO MMUCH GRIEF ......');
       FOR J := 1 TO 10000 DO BEGIN END;
       WRITELN;
       WRITELN;
       WRITELN;
       WRITELN('I HOPE YOU HAVE FUN.................................');
       WRITELN;
       EXIT(CASTLES);    
 END;
 END;
 END; 
 END;
  
  
PROCEDURE WAIT;      
BEGIN
        GOTOXY(39,15);
        WRITE('PRESS RETURN TO CONTINUE');  
        GOTOXY(55,13);
        READ(ANS);
        RESET(INPUT);
END;{WAIT}
        
PROCEDURE NEWGAME;
VAR    A,I,J,K,R : INTEGER;
       X  :  REAL;
       ANS : STRING[20];
        
        PROCEDURE CASTLE(IL, IH, JL, JH, P : INTEGER);
        BEGIN WITH DATA DO BEGIN
                I := RND(IL,IH); J := RND(JL,JH);
                P := SEQ[P];
                CAS[P] := I*10+J; PLACE[I,J] := 'C';        
                TROOPS[I,J] := ARMY[P]; OWN[I,J] := P;  
                POP[I,J] := TRUNC(RANDOM * 3.6 + 6);
        END; {WITH DATA}                
        END; {CASTLE PROCEDURE}        

        PROCEDURE RAND;
        BEGIN I := RND(1,7); J := RND(1,7);
        END; {RAND}
        
BEGIN {NEWGAME} WITH DATA DO BEGIN
   CLEARTHESCREEN;
   GOTOXY(20,5);
   WRITE('Do you want to restart an old game? ');
   READ(AN); 
   RESET(INPUT);
   IF (AN = 'Y') OR (AN = 'y') THEN
   BEGIN
      RESET(GAMEDATA,'CASTLES.DATA');
      GET(GAMEDATA);
      DATA := GAMEDATA^;
      CLOSE(GAMEDATA,LOCK);
      RESTART := TRUE;
   END
   ELSE
   BEGIN    
        REPEAT GOTOXY(20,7); 
               WRITE('How many players? ');   
               READ(AN);   
               IF EOF THEN RESET(INPUT);
               A := ORD(AN) - 48;
               IF NOT (A IN [2..4]) THEN 
               BEGIN
                  GOTOXY(0,15);
                  WRITE('2, 3, or 4 players only please.');
                  WAIT;
                  CLEARTHESCREEN;
               END; 
        UNTIL A IN [2..4];    
        NUMP := A;
        GOTOXY(20,9);
        WRITE('Enter any character. ');    
        READ(AN);
        RESET(INPUT);
        FOR A := 0 TO ORD(AN) DO X :=  RANDOM;   
        FOR  I := 1 TO NUMP DO      
        BEGIN
            REPEAT
                GOTOXY(20,9+I*2);
                WRITE('What is player ',PD[I],'''s name? ');   
                RESET(INPUT);
                READLN(ANS);
                IF EOF THEN RESET(INPUT);                
            UNTIL ANS <> '';        
                NAME[I] := ANS;
                FOR A := 0 TO LENGTH(ANS) DO X := RANDOM;
                ARMY[I] := RND(7,11); 
                MONEY[I] := 0;
        END;
        FOR I := 1 TO 7 DO FOR J:= 1 TO 7 DO
        BEGIN
                POP[I,J] := 0; TROOPS[I,J] := 0;     
                PLACE[I,J] := '*'; OWN[I,J] := 0;
        END;
        SEQIT;
        CASTLE(1,2,3,5,1); CASTLE(6,7,3,5,2);
        IF NUMP > 2 THEN CASTLE(3,5,1,2,3);
        IF NUMP > 3 THEN CASTLE(3,5,6,7,4);
        POP[4,4] := 9; PLACE[4,4] := 'X';
        K := 1;  
        REPEAT  RAND;
                IF PLACE[I,J] <> '*' THEN K :=1      
                ELSE BEGIN   K := K+1;
                        PLACE[I,J] := 'T';
                        POP[I,J] := TRUNC(RANDOM *3.5 + 4);
                END; {ELSE}
        UNTIL K > NUMP;  
        FOR K := 1 TO 9 DO      
        BEGIN
                IF K < 5 THEN
                BEGIN
                        REPEAT RAND UNTIL PLACE[I,J] = '*';
                        PLACE[I,J] := 'L';
                        REPEAT RAND UNTIL PLACE[I,J] = '*';
                        PLACE[I,J] := 'S';
                END; {WHILE K < 5}  
                REPEAT RAND UNTIL PLACE[I,J] = '*';
                PLACE[I,J] := 'F';
       END;
       FOR I := 1 TO 7 DO FOR J := 1 TO 7 DO  
       IF PLACE[I,J] = '*' THEN POP[I,J] := RND(1,3);  
       TURN := 1;
       RESTART := FALSE;        
    END;         
END; {WITH DATA}        
END; {NEWGAME}


PROCEDURE BOARD;

VAR     ROW, COL, I, J : INTEGER;  PLAYER : ARRAY[1..4] OF 'A'..'D';

BEGIN WITH DATA DO BEGIN
        CLEARTHESCREEN;
        FOR J := 1 TO 7 DO  
        BEGIN
                GOTOXY(J*7,0);
                WRITE(J);
        END;
        FOR I := 1 TO 7 DO
        BEGIN
                GOTOXY(0,I*2);
                WRITE(I);
        END;
        FOR I := 1 TO 7 DO FOR J := 1 TO 7 DO
        BEGIN
                GOTOXY(J*7-2,I*2);
                WRITE(PLACE[I,J]);    
                IF OWN[I,J] <> 0 
                   THEN WRITE(POP[I,J],PD[OWN[I,J]],TROOPS[I,J])      
                   ELSE WRITE('    ');
        END;
END;{WITH DATA} END; {BOARD}

PROCEDURE PLAY;
VAR STILLPLAYING,MOVEOK : BOOLEAN;    
    FROM,TX,NUMBER,PL,FI,FJ,TI,TJ,R,PT,DL,AL : INTEGER;
    DF : REAL;

        PROCEDURE INTEST;
        VAR F,T,N :STRING;
                    
        BEGIN {INTEST}
                        REPEAT
                             GOTOXY(55,14);
                             READLN(ANS); 
                             IF EOF THEN RESET(INPUT);
                        UNTIL ANS <> '';   
                        POSITION := 1;
                        F := ''; T := ''; N := '';
                        SPLIT(F); SPLIT(T); SPLIT(N);
                        CONVERT(F,FROM);
                        CONVERT(T,TX);        
                        CONVERT(N,NUMBER);
        END;{INTEST}              
        
        PROCEDURE MERROR(ERROR : INTEGER);  
        VAR     E : STRING[40];
        
        BEGIN
           MOVEOK := FALSE;
           E := 'Unidentified error.                    '; 
           CASE ERROR OF
              1: E := 'INVALID FROM POSITION                  '; 
              2: E := 'INVALID TO POSITION                    '; 
              3: E := 'You have no army there.                '; 
              4: E := 'One move at a time please.             '; 
              5: E := 'You can''t march into a lake!          ';   
              6: E := 'You don''t have that many troops there!';      
              7: E := 'You don''t have enough money.?         ';
              8: E := 'Invalid position.                      ';
              9: E := 'You don''t own that place.             ';
             10: E := 'You can''t place troops in the capital.';
             11: E := 'For no move enter a ''0'' from position. ';
             12: E := 'NOW you MUST take at least one.        '        
           END; 
               GOTOXY(0,15);
               WRITE(E);
               WAIT;
        END; {MERROR}

        PROCEDURE COMBAT;
                PROCEDURE RESULTS; 
                BEGIN WITH DATA DO BEGIN    
                    CLEARTHESCREEN;
                    WRITE('COMBAT RESULTS BETWEEN WARLORDS ');      
                    WRITELN(NAME[PL],' AND ',NAME[OWN[TI,TJ]]);          
                    WRITELN();
                    WRITE('ATTACKING WARLORD ',NAME[PL]);  
                    WRITELN(' LOST ',AL,' ARMIES');
                    WRITELN();
                    WRITE('DEFENDING WARLORD ');
                    WRITE(NAME[OWN[TI,TJ]],' LOST ');
                    WRITELN(DL,' ARMIES ');  
                END;{WITH DATA} END;{RESULTS} 
        BEGIN {COMBAT} WITH DATA DO BEGIN     
            CASE PLACE[TI,TJ] OF
                '*':    DF := 1;  
                'C':    DF := 4;
                'X':    DF := 3;
                'F':    DF := 1.75;
                'S':    DF := 2;
                'T':    DF := 1.5
            END;
            DL := 
            TRUNC((NUMBER * (RANDOM * 0.5 +
            0.5))/DF);
            AL :=
            TRUNC(TROOPS[TI,TJ] * (RANDOM * 0.5 + 
            0.5) * DF);
            IF AL > NUMBER THEN AL := NUMBER;
            IF DL > TROOPS[TI,TJ] THEN DL :=
            TROOPS[TI,TJ];
            RESULTS;
            TROOPS[TI,TJ] := TROOPS[TI,TJ] - DL;
            ARMY[OWN[TI,TJ]] := ARMY[OWN[TI,TJ]] - DL;        
            NUMBER := NUMBER - AL;
            ARMY[PL] := ARMY[PL] - AL;
            WRITE('ATTACK WAS ');
            IF TROOPS[TI,TJ] > 0 THEN
            BEGIN {UNSUCCESSFUL}
                    WRITELN('UNSUCCESSFUL');    
                    TROOPS[FI,FJ] := TROOPS[FI,FJ] +    
                    NUMBER;
                    IF TROOPS[FI,FJ] > 0 THEN
                    OWN[FI,FJ] := PL;
            END {UNSUCCESSFUL}
            ELSE
            BEGIN {SUCCESSFUL}
              WRITELN('SUCCESSFUL');    
              IF PLACE[TI,TJ] = 'C' THEN
              BEGIN {TAKE CAS}
                CAS[OWN[TI,TJ]] := 0;
                MONEY[PL] :=
                MONEY[PL] + MONEY[OWN[TI,TJ]];
                IF CAS[PL] = 0 THEN
                CAS[PL] := TI * 10 + TJ;  
              END; {TAKE CAS} 
              TROOPS[TI,TJ] := NUMBER;
              OWN[TI,TJ] := PL;
            END; {SUCCESSFUL}  
        WAIT;
        END;{WITH DATA} END;{COMBAT}
        
        PROCEDURE MOVE;      
        BEGIN WITH DATA DO BEGIN 
            IF (PLACE[TI,TJ] = 'C') AND (OWN[TI,TJ] = 0) THEN
            CAS[PL] := TX;
            IF ((PLACE[TI,TJ] = 'F') OR (PLACE[TI,TJ] = 'S')) AND
            (RANDOM <= 0.7) THEN
            BEGIN
                AL := TRUNC(RANDOM * NUMBER +1);
                NUMBER := NUMBER -AL;
                ARMY[PL] := ARMY[PL] - AL;
                IF PLACE[TI,TJ] = 'F'
                THEN WRITE(AL,' TROOPS LOST IN FOREST       ')        
                ELSE WRITE(AL,' TROOPS DROWNED IN SWAMP     ');
                WAIT;
            END;
            TROOPS[TI,TJ] := TROOPS[TI,TJ] + NUMBER;
            IF NUMBER > 0 THEN OWN[TI,TJ] := PL;
        END;{WITH DATA} END;{MOVE}     
        
   PROCEDURE ECONOMIC;    
   CONST   TAXRATE = 675.0;    
           PAYRATE = 325.0;
   VAR     N : STRING;    
           A, LINE : INTEGER; 
           
      PROCEDURE INEW;
      BEGIN 
         WRITELN();
         WRITE('How many? '); 
         READ(ANS);
         RESET(INPUT);
         POSITION := 1;
         N := '';
         SPLIT(N);
         CONVERT(N,A);
         MOVEOK := TRUE;
      END;
      
      PROCEDURE FIELDTROOPS; 
         BEGIN WITH DATA DO BEGIN {FT1} 
            REPEAT
               GOTOXY(0,7);
               WRITELN();  
               GOTOXY(0,7);    
               WRITE('Do you wish to rase field troops? ');        
               READ(AN); 
               RESET(INPUT);
            UNTIL (AN = 'Y') OR (AN = 'N')
               OR (AN = 'y') OR (AN = 'n'); 
            WRITELN();
            IF (AN = 'Y') OR (AN = 'y') THEN   
            BEGIN {FT2}
               REPEAT
                  INEW; 
                  MOVEOK := TRUE;
                  IF (A * 2000.0) > MONEY[I] THEN MERROR(7);
                  IF A = 0 THEN MERROR(12);
               UNTIL MOVEOK = TRUE;
               MONEY[I] := MONEY[I] - A * 2000.0;        
               ARMY[I] := ARMY[I] + A;
               PL := I;
               REPEAT
                  MOVEOK := TRUE;
                  BOARD; 
                  GOTOXY(0,15);
                  WRITE('Where do you want them? ');
                  INTEST;
                  IF NOT(FROM IN VALID) THEN MERROR(8) ELSE
                  BEGIN
                     J := FROM DIV 10; K := FROM MOD 10;        
                     IF OWN[J,K] <> I THEN MERROR(9);
                     IF PLACE[J,K] = 'X' THEN MERROR(10);
                     IF MOVEOK THEN
                     TROOPS[J,K] := TROOPS[J,K] + A;
                  END;
               UNTIL MOVEOK = TRUE;        
               BOARD;
               WAIT;
               CLEARTHESCREEN;
            END; {FT2}  
         END; {WITH DATA} END; {FT1}
         
         PROCEDURE CASTLETROOPS;
         BEGIN WITH DATA DO BEGIN {CASTLESTROOPS}
            REPEAT    
               GOTOXY(0,11);
               WRITELN();
               GOTOXY(0,11);    
               WRITE('Do you wish to raise castle troops? ');    
               READ(AN); 
               RESET(INPUT);
            UNTIL (AN = 'Y') OR (AN = 'y')  
               OR (AN = 'N') OR (AN = 'n');
            IF (AN = 'Y') OR (AN = 'y') THEN
            BEGIN
               REPEAT 
                  INEW; 
                  MOVEOK := TRUE;
                  IF (A * 2000.0) > MONEY[I] THEN MERROR(7);
                  IF A = 0 THEN MERROR(12);
               UNTIL MOVEOK = TRUE;
               J := CAS[I] DIV 10; K := CAS[I] MOD 10;
               TROOPS[J,K] := TROOPS[J,K] + A;
               MONEY[I] := MONEY[I] - A * 2000.0;
               ARMY[I] := ARMY[I] + A;
               WRITELN('TROOPS IN CASTLE NOW =        ',TROOPS[J,K]); 
            END;
            WAIT;
         END; {WITH DATA} END; {CASTLETROOPS}  
           
   BEGIN WITH DATA DO BEGIN {ECONOMICS}     
      ATLEASTONEPLAYERIN := FALSE;
      ALLBUTONEPLAYEROUT := TRUE ;
      FOR I := 1 TO NUMP DO        
      BEGIN  
         TAX[I] := 0;
         TAXBASE[I] := 0;
         ARMY[I] := 0;
      END;     
      FOR I:= 1 TO 7 DO FOR J := 1 TO 7 DO          
      BEGIN
         PL := OWN[I,J];
         IF PL <> 0 THEN
         BEGIN
            TAXBASE[PL] := TAXBASE[PL] + POP[I,J];
            IF PLACE[I,J] = 'T' THEN TAXBASE[PL] := TAXBASE[PL] + 1;
            ARMY[PL] := ARMY[PL] + TROOPS[I,J];        
         END;
      END;
      FOR I := 1 TO NUMP DO
      BEGIN
         TAX[I] := TAXBASE[I] * (TAXRATE + RANDOM * TAXRATE/4);   
         PAY[I] := ARMY[I] * (PAYRATE + RANDOM * PAYRATE/4);   
         IF CAS[I] <> 0 THEN
         BEGIN
            MONEY[I] := MONEY[I] - PAY[I];
            IF MONEY[I] < 0 THEN
            BEGIN
               TAX[I] := TAX[I] + MONEY[I];
               MONEY[I] := 0; 
            END;
            CLEARTHESCREEN;
            WRITELN('WARLORD ',PD[I],' ',NAME[I]);
            WRITELN('TREASURY BALANCE: ',MONEY[I] : 6 : 2);
            WRITELN('ARMIES: ',ARMY[I]);        
            WRITELN('TAXES COLLECTED: ',TAX[I]:6:2);
            WRITELN('POPULATION: ',TAXBASE[I]);
            IF ARMY[I] > 0 THEN 
             BEGIN
              IF ATLEASTONEPLAYERIN THEN ALLBUTONEPLAYEROUT := FALSE;
              ATLEASTONEPLAYERIN := TRUE; 
             END;
            IF MONEY[I] >= 2000 THEN FIELDTROOPS;
            MONEY[I] := MONEY[I] + TAX[I];
            GOTOXY(0,9);
            WRITE('TREASURY NOW EQUALS ',MONEY[I] : 6 : 2);
            IF MONEY[I] >= 2000 THEN CASTLETROOPS ELSE WAIT;            
         END;  
      END;
   END;{WITH  DATA} END;{ECONOMIC}
                   
   PROCEDURE SAVEGAME;
   BEGIN
      CLEARTHESCREEN;
      GOTOXY(20,8);         
      WRITE('Do you want to stop now? ');        
      READ(AN); 
      RESET(INPUT);
      IF (AN = 'Y') OR (AN = 'y') THEN STILLPLAYING :=FALSE;
      GOTOXY(20,10);   
      WRITE('Do you want to save this game? ');
      READ(AN);
      RESET(INPUT);
      IF (AN = 'Y') OR (AN = 'y') THEN
      BEGIN 
         REWRITE(GAMEDATA,'CASTLES.DATA');
         GAMEDATA^ := DATA;
         PUT(GAMEDATA);
         CLOSE(GAMEDATA,LOCK);
         WRITElN('Game saved.');
      END;
   END;{SAVEGAME}


BEGIN {PLAY} WITH DATA DO BEGIN

STILLPLAYING := TRUE;
WHILE STILLPLAYING DO
BEGIN {TURN}
   IF RESTART = FALSE THEN        
   BEGIN {CAMPAIGN}  
      ROUNDSINTURN := RND(1,4);          
      IF (TURN < 6) AND (ROUNDSINTURN > 2) THEN
              ROUNDSINTURN := ROUNDSINTURN - 1;
      FOR R := 1 TO ROUNDSINTURN DO
      BEGIN {ROUND}
         ROUND := R;
         SEQIT;  
         FOR PT := 1 TO NUMP DO  
         BEGIN {PTURN}
            PTURN := PT;  
            PL := SEQ[PTURN];
            IF ARMY[PL] > 0 THEN
            BEGIN {PLAYER}
               REPEAT {UNTIL MOVOK} 
                  BOARD;
                  GOTOXY(54,4);
                  WRITE('CAMPAGIN ',TURN);
                  GOTOXY(55,5);    
                  WRITE('ROUND ',ROUND);        
                  GOTOXY(55,6);
                  WRITE('WARLORD ',PD[PL]);
                  GOTOXY(55,7);
                  WRITE(NAME[PL]);
                  GOTOXY(0,15);
                  WRITE('  MOVE? (FROM TO NUMBER)');    
                  INTEST;
                  MOVEOK := TRUE; 
                  IF NOT(FROM = 0) THEN
                  BEGIN {CHECK MOVE1}
                     IF NOT (FROM IN VALID) THEN MERROR(1);        
                     IF NOT (TX IN VALID) THEN MERROR(2);
                     IF MOVEOK THEN
                     BEGIN {CHECK MOVE2}
                        FI := FROM DIV 10; FJ := FROM MOD 10;
                        TI := TX DIV 10 ; TJ:= TX MOD 10;
                        IF OWN[FI,FJ] <> PL THEN MERROR(3);
                        IF (ABS(TI-FI) > 1) 
                        OR (ABS(TJ-FJ) > 1) THEN MERROR(4); 
                        IF PLACE[TI,TJ] = 'L' THEN MERROR(5);   
                        IF (NUMBER > TROOPS[FI,FJ]) AND 
                           (OWN[FI,FJ] = PL) THEN MERROR(6);
                        IF NUMBER = 0 THEN MERROR(11);
                     END;{CHECK MOVE2} 
                  END;{CHECK MOVE1}
               UNTIL MOVEOK;
               IF NOT(FROM = 0) THEN
               BEGIN {DO MOVE}
                  TROOPS[FI,FJ] := TROOPS[FI,FJ] - NUMBER; 
                  IF TROOPS[FI,FJ] = 0 THEN OWN[FI,FJ] := 0; 
                  IF (OWN[TI,TJ] <> PL) AND (OWN[TI,TJ] <> 0)
                  THEN COMBAT
                  ELSE MOVE;
               END; {DO MOVE}
            END; {PLAYER}
         END; {PTURN}
      END; {ROUND}  
   END; {CAMPAIGN}  
   BOARD;
   GOTOXY(0,15);
   WRITE('END OF CAMPAIGN                        ');
   WAIT;
   RESTART := FALSE;
   SAVEGAME;
   IF STILLPLAYING THEN  
   BEGIN
      ECONOMIC;
      IF ALLBUTONEPLAYEROUT THEN OUTMSG;
      TURN := TURN + 1; 
   END;
END; {TURN}
END; {DATA} END; {PLAY}

        
BEGIN {DUMMY MAIN PROGRAM}    
WITH DATA DO BEGIN
SEED := 1.23456789;
VALID := [11..17,21..27,31..37,41..47,51..57,61..67,71..77];
RESTART := FALSE;
PD := 'ABCD';
FOR I := 1 TO 4 DO SEQ[I] := I;
NEWGAME;
PLAY;
END;{WITH DATA}
END.


========================================================================================
DOCUMENT :usus Folder:VOL09:catalog.9.text
========================================================================================

                     CATALOG OF VOLUME 9 -**- USUS LIBRARY
               GAMES:  Adventure, Castles, Spacewar, and Startrek

   name          size               description
   
ADV.TEXT          34    Source for ADVENTURE.
ADV.DOC.TEXT      20    Read this documentation on setting up the program.
ADV.MISCINFO       4    Tells ADV your screen dimensions.

ADVINIT.TEXT      22    Run this program to set up ADV's data files.

ADVS1.TEXT        42    These are the text files used by ADVINIT.
ADVS2.TEXT         8
ADVS3.TEXT        22
ADVS4.TEXT        10
ADVS5.TEXT        14
ADVS6.TEXT        38
ADVS7.TEXT         6
ADVS8.TEXT         4
ADVS9.TEXT         4
ADVS10.TEXT        4
ADVS11.TEXT        4
ADVSUBS.TEXT      42
ADVVERB.TEXT      42


CASTLES.TEXT      36    A board game for two or more players, in which you
CASTLES.DOC        6      and your opponents are warlords plundering each
                          other, raising armies, etc.


SPACEWAR.TEXT     20    Fast action for two players shooting it out in their
                          space ships...it'll require work to get it running
                          on your machine.


STARTREK.TEXT      6    A Pascal version of the classic game.
STAR.PART1.TEXT   24
STAR.PART2.TEXT   22
STAR.PART3.TEXT   22


VOLUME.9.TEXT     10    Documentation for this disk.


NOTE:   USUS Library material may be used only in accordance with policy 
        outlined elsewhere.  In particular, these programs may not be given to 
        nonmembers of USUS, nor may commercial use be made of them, without 
        the written permission of the authors.

        All programs will be the same for various formats, since no processor-
        dependent features are involved.


========================================================================================
DOCUMENT :usus Folder:VOL09:spacewar.text
========================================================================================

PROGRAM Spacewar;                                                           
 TYPE status = PACKED ARRAY[0..7] OF BOOLEAN; 
 VAR  serialtrix : RECORD CASE BOOLEAN OF
                           TRUE : (fdevaddr : INTEGER);
                           FALSE: (serialstatus : ^status);
                           END;
      hitset                  : ARRAY[0..7] OF SET OF 0..15;
      ch : CHAR; 
      dx,dy                  : ARRAY[0..7] OF INTEGER;
      shot,
      wait,
      otx,oty,
      orp,ox,oy, 
      myscore, yourscore, dt,      
      tx,ty,txv,tyv,
      mx,my,mxv,myv, 
      rp,xv,yv,x,y : INTEGER;              
      clship,ship             : ARRAY[0..7] OF STRING[8]; 
      targ,cltarg,tstring     : STRING[8];
        
 PROCEDURE Initships;
 
  PROCEDURE Inittstring; 
   VAR temp : INTEGER;
   BEGIN
    tstring := '        '; 
    FOR temp := 1 TO 8 DO tstring[temp] := CHR(0); 
   END;
   
  PROCEDURE Makeclstring;
   VAR temp : INTEGER;
   BEGIN
    FOR temp := 1 TO 8 DO IF ORD(tstring[temp])>12 THEN tstring[temp] := ' ';
   END;
   
  BEGIN 
   
   hitset[0] := [1,2,5,6,9,10,13,14];
   hitset[1] := [2,3,5,6,7,8,9,10,12,13];
   hitset[2] := [4,5,6,7,8,9,10,11];                 
   hitset[3] := [0,1,4,5,6,9,10,11,14,15];                          
   hitset[4] := hitset[0];    
   hitset[5] := hitset[1];
   hitset[6] := hitset[2];        
   hitset[7] := hitset[3];    
   
   targ := '[]   []'; 
   targ[3] := CHR(8);
   targ[4] := CHR(8);
   targ[5] := CHR(11);
   
   cltarg := '       ';
   cltarg[3] := CHR(8);
   cltarg[4] := CHR(8);
   cltarg[5] := CHR(11);
   
   Inittstring;    
   tstring[1] := ' ';
   tstring[2] := '|';  
   tstring[3] := CHR(8);
   tstring[4] := CHR(11);
   tstring[5] := '|';
   tstring[6] := CHR(8);
   tstring[7] := CHR(11);
   tstring[8] := '^';
   ship[0] := tstring; 
   Makeclstring;
   clship[0] := tstring;
  
   Inittstring;  
   tstring[1] := '/';
   tstring[2] := CHR(11);
   tstring[3] := '/';
   tstring[4] := CHR(11);
   tstring[5] := '+';
   ship[1] := tstring;
   Makeclstring;
   clship[1] := tstring;
   
   Inittstring;
   tstring[1] := CHR(11);
   tstring[2] := '-';
   tstring[3] := '-';
   tstring[4] := '>';
   ship[2] := tstring;
   Makeclstring;   
   clship[2] := tstring;      
   
   Inittstring;
   tstring[1] := CHR(11);                      
   tstring[2] := CHR(11);
   tstring[3] := '\';    
   tstring[4] := CHR(10);
   tstring[5] := '\';
   tstring[6] := CHR(10);
   tstring[7] := '+';    
   ship[3] := tstring;
   Makeclstring;
   clship[3] := tstring;
   
   tstring := ship[0];
   tstring[2] := 'v';
   tstring[8] := '|';
   ship[4] := tstring;  
   clship[4] := clship[0];
   
   tstring := ship[1];
   tstring[1] := '+';
   tstring[5] := '/';
   ship[5] := tstring;
   clship[5] := clship[1];
   
   tstring := ship[2];
   tstring[2] := '<';
   tstring[4] := '-';
   ship[6] := tstring;
   clship[6] := clship[2];
   
   tstring := ship[3];
   tstring[3] := '+';
   tstring[7] := '\';
   ship[7] := tstring;
   clship[7] := clship[3];
   
  END;
 
 PROCEDURE Explosion(x,y : INTEGER);  
  VAR temp1,temp2 : INTEGER;
  BEGIN
   WRITE(CHR(7));
   FOR temp1 := 1 TO 9 DO  
    BEGIN
     FOR temp2 := 0 TO 2 DO  
      BEGIN
      GOTOXY(x, y + temp2);  
      WRITE('***');
      END;
    END; 
   FOR temp2 := 0 TO 2 DO
    BEGIN
     GOTOXY(x,y + temp2); WRITE('   ');
    END;    
  END;  
  
 PROCEDURE Chkscore;
  BEGIN
   dt := 0; tx := 70; ty := 20; txv := 1; tyv := 1;      
   orp := 0;rp := 0; xv := 0; yv := 0; x := 40; y := 11;          
   WRITE(CHR(27),'*'); 
   GOTOXY(0,1);   
   WRITELN('M');
   WRITELN('E');
   WRITELN;
   WRITELN;  
   WRITELN;
   WRITELN;
   WRITELN;
   WRITELN;
   WRITELN('Y'); 
   WRITELN('O');
   WRITELN('U');
   GOTOXY(0,4);     
   WRITE(myscore);
   GOTOXY(0,13); 
   WRITE(yourscore);   
   WRITELN;
   
  FOR wait := 1 TO 5000 DO BEGIN END;
  
   IF myscore = 10 THEN WRITELN('I win'); 
   IF yourscore=10 THEN WRITELN('You win');  
   IF 10 IN [myscore,yourscore] THEN EXIT(Spacewar);
  END;
  
 PROCEDURE Chkcollisions;
  BEGIN  
   
   IF (dt<>0) AND (mx IN [tx,tx+1]) AND (my IN [ty,ty-1]) THEN   
    BEGIN
     Explosion(mx,my);
     yourscore := yourscore + 1;
     Chkscore;
    END;
    
     
   IF (ty - y > -3) AND (ty - y < 2) AND (tx - x > -2) AND (tx - x < 3)   
    THEN IF (ty-y+2)*4+tx-x+1 IN hitset[rp] THEN      
    BEGIN
     Explosion(x,y);
     myscore := myscore + 1;
     Chkscore;
    END;
    
   END;
   
 PROCEDURE Oposition;      
  VAR temp : INTEGER;   
  BEGIN   
  
  
  IF (dt<>0) AND (dt < 32) THEN { move missle }            
    BEGIN 
     dt := dt + 1;  
     GOTOXY(mx,my);             
     WRITE(' ');  
     IF (mx + mxv > 78) OR (mx + mxv < 1) THEN mxv := -mxv;         
     IF (my + myv > 22) OR (my + myv < 1) THEN myv := -myv;            
     mx := mx + mxv;   
     my := my + myv;    
     IF dt = 32 THEN {get rid of missle and randomize target}  
      BEGIN    
       shot := 0;
       IF txv < 2 THEN txv := txv + 1 ELSE txv := txv - 1;         
       IF tyv < 2 THEN tyv := tyv + 1 ELSE tyv := tyv - 1;  
       GOTOXY(mx, my); WRITE(' '); dt := 0;   
      END
     ELSE 
      BEGIN
       GOTOXY(mx,my);  
       WRITE('*');
      END;   
    END;    
     
           
   {move target}
   
   IF (tx + txv > 77) OR (tx + txv < 1) THEN txv := -txv;                           
   IF (ty + tyv > 22) OR (ty + tyv < 1) THEN tyv := -tyv;        
   tx := tx + txv;                       
   ty := ty + tyv;    
  
   IF (x + xv > 76) OR (x + xv < 1) THEN xv := -xv;             
   IF (y + yv > 21) OR (y + yv < 2) THEN yv := -yv;  
   x := x + xv;
   y := y + yv;
   
   GOTOXY(ox,oy);   WRITE(clship[orp]); 
   GOTOXY(x,y);     WRITE(ship[rp]);
   GOTOXY(otx,oty); WRITE(cltarg);    
   GOTOXY(tx,ty);   WRITE(targ);    
    
   ox := x; oy := y; orp := rp; otx := tx; oty := ty;
   
   Chkcollisions;    
     
 END;                     
  
 PROCEDURE Updvel; 
  BEGIN
   CASE ORD(ch) OF             
    12 : rp := (rp + 1) MOD 8;             
     8 : rp := (rp - 1) MOD 8;  
    10 : CASE rp OF 
          0 : IF yv > -4 THEN yv := yv - 1;  
          1 : BEGIN  
               IF xv < 4 THEN xv := xv + 1;  
               IF yv >-4 THEN yv := yv - 1;
              END;
          2 : IF xv < 4  THEN xv := xv + 1; 
          3 : BEGIN
               IF xv < 4 THEN xv := xv + 1;
               IF yv < 4 THEN yv := yv + 1;
              END;
          4 : IF yv < 4  THEN yv := yv + 1; 
          5 : BEGIN  
               IF yv < 4 THEN yv := yv + 1;    
               IF xv >-4 THEN xv := xv - 1; 
              END;
          6 : IF xv > -4 THEN xv := xv - 1;
          7 : BEGIN            
               IF xv >-4 THEN xv := xv - 1; 
               IF yv >-4 THEN yv := yv - 1;      
              END;
         END;
     11 : BEGIN 
            GOTOXY(mx,my); WRITE(' ');
            dt := 1; 
            shot := shot + 1;
            mx := x + dx[rp] ; my := y + dy[rp];
            mxv := xv; myv := yv;   
            IF shot MOD 4 = 0 THEN 
             BEGIN
              IF txv < 2 THEN txv := txv + 1 ELSE txv := txv - 1;        
              IF tyv < 2 THEN tyv := tyv + 1 ELSE tyv := tyv - 1;  
             END;
            CASE rp OF 
             0 : IF myv > -4 THEN myv := myv - 2;       
             1 : BEGIN
                  IF mxv < 4 THEN mxv := mxv + 2;   
                  IF myv >-4 THEN myv := myv - 2;             
                 END;
             2 : IF mxv < 4  THEN mxv := mxv + 2;     
             3 : BEGIN 
                  IF mxv < 4 THEN mxv := mxv + 2;     
                  IF myv < 4 THEN myv := myv + 2;    
                 END;
             4 : IF myv < 4  THEN myv := myv + 2;      
             5 : BEGIN   
                  IF myv < 4 THEN myv := myv + 2;   
                  IF mxv >-4 THEN mxv := mxv - 2;     
                 END;
             6 : IF mxv > -4 THEN mxv := mxv - 2;   
             7 : BEGIN
                  IF mxv >-4 THEN mxv := mxv - 2;      
                  IF myv >-4 THEN myv := myv - 2;      
                 END;
            END;
           END;
     END;    
    IF rp < 0 THEN rp := rp + 8;
   END;   
  
  
 BEGIN    
  serialtrix.fdevaddr := -1007;   {FC11}   
  dt := 0; rp := 0; xv := 0; yv := 0; x := 40; y := 11;     
  ox := 0; oy := 0; otx := 0; oty := 0; 
  orp := 0;
  myscore := 0; yourscore := 0;    
  
  { eventually these will start as random numbers } 
  tx := 70; ty := 20; txv := 1; tyv := 1; 
   
  dx[0] := 1;  dy[0] := -2;  
  dx[1] := 2;  dy[1] := -2;
  dx[2] := 2;  dy[2] := -1;
  dx[3] := 2;  dy[3] :=  0;
  dx[4] := 1;  dy[4] :=  0; 
  dx[5] := 0;  dy[5] :=  0;
  dx[6] := 0;  dy[6] := -1; 
  dx[7] := 0;  dy[7] := -2; 
  
  Initships; 
  
  WRITE(CHR(27),'*');        
  GOTOXY(x,y); WRITE(ship[rp]); 
   
  FOR wait := 1 TO 5000 DO BEGIN END;
  shot := 0;
  
    
  REPEAT     
   WHILE NOT serialtrix.serialstatus^[1] DO    
    BEGIN
     Oposition;
    END;  
   READ(keyboard,ch);         
   IF ORD(ch) IN [12,8,10,11] THEN Updvel;  
   UNTIL ch IN ['Q','q'];
  WRITELN('quit');   
 END.


========================================================================================
DOCUMENT :usus Folder:VOL09:star.part1.text
========================================================================================

                        {beginning of STAR.PART1.TEXT}

TYPE digits = 0..max_digit;
     quad_range = 0..galaxy_size;
     sect_range = 0..quad_size;
     quad_rec = RECORD
                  is_history : BOOLEAN;         {seen in long range scanner}
                  kling_base_num,               {number of klingon bases}
                  kling_num,                    {number of klingons}
                  fed_base_num,                 {number of federation bases}
                  star_num : digits;            {number of stars}
                END {of quad_rec};
     objects = (s_nothing, s_star, s_enterprise, s_nova, s_klingon,
                s_fed_base, s_kling_base);
     cond_types = (c_green, c_red, c_yellow, c_black, c_docked);
     sect_x_y = RECORD
                  x, y : sect_range;
                END {of sect_x_y};
     quad_x_y = RECORD
                  x, y : quad_range;
                END {of quad_x_y};
     klingon_rec = RECORD
                     position : sect_x_y;
                     energy_left : INTEGER;
                   END {of klingon_rec};
     device_rec = RECORD
                    name : STRING[20];
                    down_time : INTEGER;
                  END {of device_rec};

VAR seed : REAL;
    bell : CHAR;
    cur_year, start_year, end_year, cur_energy, cur_torps,
      start_klingons, total_k_bases, total_klingons, bad_points : INTEGER;
    cur_sect : sect_x_y;
    cur_quad : quad_x_y;
    device : ARRAY [min_device..max_device] OF device_rec;
    quadrant : ARRAY [sect_range, sect_range] OF objects;
    galaxy : ARRAY [quad_range, quad_range] OF quad_rec;
    klingons : ARRAY [0..max_klingons] OF klingon_rec;
    symbols : PACKED ARRAY [objects] OF CHAR;
    cond_names : ARRAY [cond_types] OF STRING[10];
    condition : cond_types;

FUNCTION random (low, hi : INTEGER) : INTEGER;
{Return a random number between two bounds}
BEGIN
  seed := ((seed * 11.0) + 7.0);
  seed := seed - TRUNC (seed / 1999.0) * 1999.0;
  random := TRUNC (seed / 1999.0 * (hi - low + 1)) + low;
END {of random};

FUNCTION distance (pos_1_x, pos_1_y : sect_range; pos_2 : sect_x_y) : INTEGER;
BEGIN
  distance := ROUND (SQRT (SQR (pos_1_x - pos_2.x) + SQR (pos_1_y - pos_2.y)));
END {of distance};
    
FUNCTION radians (degrees : INTEGER) : REAL;
BEGIN
  radians := degrees * 0.0174533;
END {of radians};

FUNCTION interval (number, min_value, max_value : INTEGER) : INTEGER;
BEGIN
  IF number < min_value THEN
    interval := min_value
  ELSE
    IF number > max_value THEN
      interval := max_value
    ELSE
      interval := number;
END {of interval};

PROCEDURE re_initialize;
VAR ch : CHAR;
BEGIN
  cur_energy := ent_energy;
  cur_torps := start_torps;
  FOR ch := min_device TO max_device DO
    device[ch].down_time := 0;
END {of re_initialize};

PROCEDURE initialize;
VAR r_num, total_fed_base, i, j : INTEGER;
BEGIN
  device['0'].name := 'Warp Engines';
  device['1'].name := 'Short Range Sensors';
  device['2'].name := 'Long Range Sensors';
  device['3'].name := 'Phaser Control';
  device['4'].name := 'Photon Tubes';
  device['5'].name := 'Damage Control';
  device['6'].name := 'History Computers';
  device['7'].name := 'Self Destruct';
  symbols[s_nothing] := no_sym;
  symbols[s_star] := star_sym;
  symbols[s_enterprise] := ent_sym;
  symbols[s_nova] := nova_sym;
  symbols[s_klingon] := kling_sym;
  symbols[s_fed_base] := f_base_sym;
  symbols[s_kling_base] := k_base_sym;
  cond_names[c_red] := 'Red';
  cond_names[c_green] := 'Green';
  cond_names[c_yellow] := 'Yellow';
  cond_names[c_black] := 'Black';
  cond_names[c_docked] := 'Docked';
  cur_sect.x := random (0, quad_size);
  cur_sect.y := random (0, quad_size);
  cur_quad.x := random (0, galaxy_size);
  cur_quad.y := random (0, galaxy_size);
  total_klingons := 0;
  total_k_bases := 0;
  FOR i := 0 TO galaxy_size DO
    FOR j := 0 TO galaxy_size DO
      WITH galaxy[i, j] DO
        BEGIN
          is_history := FALSE;
          r_num := random (0, SQR (galaxy_size));
          IF random (0, SQR (galaxy_size)) <= 6 THEN
            kling_base_num := 1
          ELSE
            kling_base_num := 0;
          total_k_bases := total_k_bases + kling_base_num;
          kling_num := TRUNC (EXP (-random (0, galaxy_size)) * max_digit) DIV 2;
          total_klingons := total_klingons + kling_num;
          IF random (0, SQR (galaxy_size)) < 3 THEN
            fed_base_num := 1
          ELSE
            fed_base_num := 0;
          total_fed_base := total_fed_base + fed_base_num;
          star_num := random (0, quad_size);
        END {of WITH};
  start_klingons := total_klingons;
  IF total_fed_base = 0 THEN
    galaxy[random (0, galaxy_size), random (0, galaxy_size)].fed_base_num := 1;
  IF total_k_bases = 0 THEN
    BEGIN
      galaxy[random (0, galaxy_size), random (0, galaxy_size)].kling_base_num 
                                                                          := 1;
      total_k_bases := 1;
    END {of IF};
  cur_year := random (3000, 4000);
  start_year := cur_year;
  end_year := start_year + random (10, 40);
  bad_points := 0;
  bell := CHR (alarm);
  re_initialize;
END {of initialize};

PROCEDURE set_condition;
VAR i, j : INTEGER;
BEGIN
  IF galaxy[cur_quad.x, cur_quad.y].kling_base_num <> 0 THEN
    condition := c_black
  ELSE
    IF galaxy[cur_quad.x, cur_quad.y].kling_num <> 0 THEN
      condition := c_red
    ELSE
      IF cur_energy < ent_energy DIV 10 THEN
        condition := c_yellow
      ELSE
        condition := c_green;
  FOR i := cur_sect.x - 1 TO cur_sect.x + 1 DO
    FOR j := cur_sect.y - 1 TO cur_sect.y + 1 DO
      IF quadrant[interval (i, 0, quad_size), interval (j, 0, quad_size)] =
         s_fed_base THEN
        condition := c_docked;
END {of set_condition};

PROCEDURE klingon_attack;
VAR hit, i : INTEGER;
    ship_type : STRING;
BEGIN
  WITH galaxy[cur_quad.x, cur_quad.y] DO
    IF (kling_base_num <> 0) OR (kling_num <> 0) THEN
      BEGIN
        IF condition = c_docked THEN
          WRITELN ('Starbase shields protect the Enterprise')
        ELSE
          FOR i := 0 TO max_klingons DO
            WITH klingons[i] DO
              IF energy_left > 0 THEN
                BEGIN
                  hit := TRUNC (energy_left /
                                distance (position.x, position.y, cur_sect) * 
                                (10 + random (0, 10)) / 10);
                  cur_energy := cur_energy - hit;
                  IF energy_left = ent_energy THEN
                    ship_type := 'Starbase '
                  ELSE
                    ship_type := '';
                  WRITELN (hit, ' unit hit on Enterprise from Klingon ',
                           ship_type, 'at sector ', position.x, '-', 
                           position.y, ' (', cur_energy, ' left)');
                END {of IF energy_left};
      END {of IF (};
END {of klingon_attack};

PROCEDURE print_digit (number : INTEGER; VAR must_print : BOOLEAN);
BEGIN
  must_print := must_print OR (number <> 0);
  IF must_print THEN
    WRITE (number)
  ELSE
    WRITE (' ');
END {of print_digit};
  
PROCEDURE setup_quad (quad : quad_x_y; VAR ent_sect : sect_x_y);
VAR i, j, nova_count, kling_index : INTEGER;

  PROCEDURE setup_stuff (object : objects; count : INTEGER);
  VAR x, y : INTEGER;
  BEGIN
    WHILE count <> 0 DO
      BEGIN
        REPEAT
          x := random (0, quad_size);
          y := random (0, quad_size);
        UNTIL quadrant[x, y] = s_nothing;
        quadrant[x, y] := object;
        count := count - 1;
      END {of WHILE};
  END {of setup_stuff};
  
BEGIN
  FOR i := 0 TO quad_size DO
    FOR j := 0 TO quad_size DO
      quadrant[i, j] := s_nothing;
  ent_sect.x := random (0, quad_size);
  ent_sect.y := random (0, quad_size);
  quadrant[ent_sect.x, ent_sect.y] := s_enterprise;
  WITH galaxy[quad.x, quad.y] DO
    BEGIN
      nova_count := random (0, star_num DIV 2);
      setup_stuff (s_star, star_num - nova_count);
      setup_stuff (s_nova, nova_count);
      setup_stuff (s_klingon, kling_num);
      setup_stuff (s_fed_base, fed_base_num);
      setup_stuff (s_kling_base, kling_base_num);
    END {of WITH};
  kling_index := 0;
  FOR i := 0 TO quad_size DO
    FOR j := 0 TO quad_size DO
      IF quadrant[i, j] IN [s_klingon, s_kling_base] THEN
        WITH klingons[kling_index] DO
          BEGIN
            position.x := i;
            position.y := j;
            IF quadrant[i, j] = s_kling_base THEN
              energy_left := ent_energy
            ELSE
              energy_left := kling_energy;
            kling_index := kling_index + 1;
          END {of WITH};
  FOR kling_index := kling_index TO max_klingons DO
    klingons[kling_index].energy_left := 0;
END {of setup_quad};

PROCEDURE print_quadrant;
VAR i, j : quad_range;
BEGIN
  set_condition;
  IF device['1'].down_time <> 0 THEN
    WRITELN ('*** Short Range Sensors Inoperable ***')
  ELSE 
    BEGIN
      WRITELN ('----------------------');
      FOR i := 0 TO quad_size DO
        BEGIN
          FOR j := 0 TO quad_size DO 
            WRITE (symbols[quadrant[i, j]], ' ');
          WRITE ('   ');
          CASE i OF
            0 : WRITELN ('Stardate         ', cur_year);
            1 : WRITELN ('Condition        ', cond_names[condition]);
            2 : WRITELN ('Quadrant         ', cur_quad.x, '-', cur_quad.y);
            3 : WRITELN ('Sector           ', cur_sect.x, '-', cur_sect.y);
            4 : WRITELN ('Energy           ', cur_energy);
            5 : WRITELN ('Photon torpedoes ', cur_torps);
            6 : WRITELN ('Klingons left    ', total_klingons);
            7 : WRITELN;
          END {of CASE};
        END {of FOR i};
      WRITELN ('----------------------');
    END {of ELSE};
END {of print_quadrant};

PROCEDURE print_galaxy (top_x, left_y : INTEGER; size : INTEGER; 
                        mark_history : BOOLEAN);
VAR i, j : INTEGER;
    must_print : BOOLEAN;

  PROCEDURE print_separator (entries : INTEGER);
  VAR count : INTEGER;
  BEGIN
    FOR count := 0 TO entries DO
      WRITE ('|-----');
    WRITELN ('|');
  END {of print_separator};

BEGIN
  IF mark_history THEN
    WRITELN ('Long Range Sensor Scan For Quadrant ', cur_quad.x, '-', 
             cur_quad.y)
  ELSE
    BEGIN
      WRITELN ('History Computer Report; Stardate ', cur_year);
      IF condition <> c_docked THEN
        cur_energy := cur_energy - 100;
    END {of ELSE};
  print_separator (size);
  FOR i := top_x TO top_x + size DO
    BEGIN
      FOR j := left_y TO left_y + size DO
        IF (i IN [0..quad_size]) AND (j IN [0..quad_size]) THEN
          WITH galaxy[i, j] DO
            IF mark_history OR is_history THEN
              BEGIN
                is_history := is_history OR (device['6'].down_time = 0);
                must_print := FALSE;
                WRITE ('|');
                print_digit (kling_base_num, must_print);
                print_digit (kling_num, must_print);
                print_digit (fed_base_num, must_print);
                must_print := TRUE;
                print_digit (star_num, must_print);
                WRITE (' ');
              END {of WITH}
            ELSE
              WRITE ('|+++++')
        ELSE
          WRITE ('|xxxxx');
      WRITELN ('|');
      print_separator (size);
    END {of FOR i};
END {of print_galaxy};

PROCEDURE print_damage;
VAR ch : CHAR;
BEGIN
  WRITELN ('Device name:      Repair Time:');
  FOR ch := min_device TO max_device DO
    WRITELN (device[ch].name:20, device[ch].down_time:5);
END {of print_damage};

                        {ending of STAR.PART1.TEXT}


========================================================================================
DOCUMENT :usus Folder:VOL09:star.part2.text
========================================================================================

                         {beginning of STAR.PART2.TEXT}

PROCEDURE move_enterprise;
VAR course : INTEGER;
    x_inc, y_inc, x_pos, y_pos, warp : REAL;

  PROCEDURE handle_damage;
  VAR ch, start_ch : CHAR;
  BEGIN
    FOR ch := min_device TO max_device DO
      IF device[ch].down_time <> 0 THEN
        device[ch].down_time := device[ch].down_time - 1;
    IF random (0, 100) < 6 THEN
      BEGIN
        ch := CHR (random (ORD (min_device), ORD (max_device)));
        WRITELN ('*** Space storm, ', device[ch].name, ' damaged ***');
        device[ch].down_time := random (device[ch].down_time, 5);
      END {of IF}
    ELSE
      IF random (0, 100) < 12 THEN
        BEGIN
          ch := CHR (random (ORD (min_device), ORD (max_device)));
          start_ch := ch;
          REPEAT
            IF ch = max_device THEN
              ch := min_device
            ELSE
              ch := SUCC (ch);
          UNTIL (ch = start_ch) OR (device[ch].down_time <> 0);

          IF device[ch].down_time <> 0 THEN
            BEGIN
              WRITELN ('*** Truce, ', device[ch].name, 
                       ' state of repair improved ***');
              device[ch].down_time := random (0, device[ch].down_time - 1);
            END {of IF device};
        END {of IF random};
  END {of handle_damage};
  
  PROCEDURE move_intra (VAR x_pos, y_pos, x_inc, y_inc : REAL; 
                        course : INTEGER; warp : REAL);
  BEGIN
    x_inc := -COS (radians (course));
    y_inc := SIN (radians (course));
    x_pos := cur_sect.x;
    y_pos := cur_sect.y;
    WHILE (ROUND (x_pos) IN [0..quad_size]) AND
          (ROUND (y_pos) IN [0..quad_size]) AND (warp >= 0.125) DO
      IF quadrant[ROUND (x_pos), ROUND (y_pos)] = s_nothing THEN
        BEGIN
          x_pos := x_pos + x_inc;
          y_pos := y_pos + y_inc;
          warp := warp - 0.125;
        END {of IF}
      ELSE
        warp := 0.0;
  END {of move_intra};

BEGIN {of move_enterprise}
  WRITE ('Course: ');
  READLN (course);
  WRITE ('Warp factor (0-12): ');
  READLN (warp);
  IF (warp < 0.0) OR (warp > 12.0) OR 
     ((warp > 0.2) AND (device[min_device].down_time <> 0)) THEN
    WRITELN ('Can''t move that fast !!')
  ELSE
    BEGIN
      cur_year := cur_year + 1;
      cur_energy := TRUNC (cur_energy - 8 * warp);
      handle_damage;
      quadrant[cur_sect.x, cur_sect.y] := s_nothing;
      move_intra (x_pos, y_pos, x_inc, y_inc, course, warp);
      IF (ROUND (x_pos) IN [0..quad_size]) AND 
                                         (ROUND (y_pos) IN [0..quad_size]) THEN
        IF quadrant[ROUND (x_pos), ROUND (y_pos)] = s_fed_base THEN
          BEGIN
            WRITELN ('Collision with starbase''s elastic shields at sector ',
                     ROUND (x_pos), '-', ROUND (y_pos));
            move_intra (x_pos, y_pos, x_inc, y_inc, (course + 180) MOD 360, warp);
          END {of IF};
      IF (ROUND (x_pos) IN [0..quad_size]) AND 
                                         (ROUND (y_pos) IN [0..quad_size]) THEN
        BEGIN
          IF quadrant[ROUND (x_pos), ROUND (y_pos)] IN 
                                 [s_star, s_nova, s_klingon, s_kling_base] THEN
            BEGIN
              WRITELN ('Enterprise blocked by object at sector ', ROUND (x_pos),
                       '-', ROUND (y_pos));
              x_pos := x_pos - x_inc;
              y_pos := y_pos - y_inc;
            END {of IF quadrant};
          cur_sect.x := interval (ROUND (x_pos), 0, quad_size);
          cur_sect.y := interval (ROUND (y_pos), 0, quad_size);
          quadrant[cur_sect.x, cur_sect.y] := s_enterprise;
        END {of IF ROUND}
      ELSE
        BEGIN           {Inter-Quadrant moving}
          cur_quad.x := interval (TRUNC (cur_quad.x + warp * x_inc +
                                         cur_sect.x * 0.125), 0, galaxy_size);
          cur_quad.y := interval (TRUNC (cur_quad.y + warp * y_inc +
                                         cur_sect.y * 0.125), 0, galaxy_size);
          setup_quad (cur_quad, cur_sect);
        END {of IF};
    END {of ELSE};
  set_condition;
  IF condition = c_docked THEN
    re_initialize;
END {of move_enterprise};

PROCEDURE fire_phasers;
VAR i, fire_amount, hit : INTEGER;
BEGIN
  WRITELN ('Phasers locked on target.  Energy available = ', cur_energy);
  WRITE ('Number of units to fire: ');
  READLN (fire_amount);
  IF fire_amount > cur_energy THEN
    WRITELN ('Unable to fire.')
  ELSE
    IF fire_amount > 0 THEN
      BEGIN
        IF condition <> c_docked THEN
          cur_energy := cur_energy - fire_amount;
        FOR i := 0 TO max_klingons DO
          WITH klingons[i] DO
            IF energy_left > 0 THEN
              BEGIN
                hit := TRUNC (fire_amount /
                              distance (position.x, position.y, cur_sect) * 
                              (10 + random (0, 10))) DIV 10;
                energy_left := energy_left - hit;
                WRITE (hit, ' unit hit on Klingon at sector ', position.x, '-',
                       position.y);
                IF energy_left > 0 THEN
                  WRITELN (' (', energy_left, ' left)')
                ELSE
                  BEGIN
                    WRITELN ('.  Klingon DESTROYED', bell);
                    total_klingons := total_klingons - 1;
                    galaxy[cur_quad.x, cur_quad.y].kling_num := 
                                  galaxy[cur_quad.x, cur_quad.y].kling_num - 1;
                    quadrant[position.x, position.y] := s_nothing;
                  END {of ELSE};
              END {of IF energy_left}
      END {of IF >};
END {of fire_phasers};

PROCEDURE fire_torpedoes;
VAR i, course : INTEGER;
    hit_something : BOOLEAN;
    x_inc, y_inc, x_pos, y_pos : REAL;
                             
  PROCEDURE hit_nova (nova_x, nova_y : sect_range; VAR kling_num : INTEGER);
  VAR hit, i : INTEGER;
  BEGIN
    WRITELN ('Torpedo causes unstable star to nova');
    IF condition <> c_docked THEN
      BEGIN
        hit := 600 * random (0, 10) DIV distance (nova_x, nova_y, cur_sect);
        IF hit > 0 THEN
          WRITELN ('Enterprise loses ', hit, ' units of energy');
        cur_energy := cur_energy - hit;
      END {of IF};
    FOR i := 0 TO max_klingons DO
      WITH klingons[i] DO
        IF energy_left > 0 THEN
          BEGIN
            energy_left := energy_left - 120 * random (0, 10) DIV 
                             distance (nova_x, nova_y, position);
            IF energy_left <= 0 THEN
              BEGIN
                quadrant[position.x, position.y] := s_nothing;
                total_klingons := total_klingons - 1;
                kling_num := kling_num - 1;
              END {of IF <=};
          END {of IF >};
  END {of hit_nova};

  PROCEDURE hit_kling_base (VAR kling_base_num : INTEGER);
  VAR i, k_docked : INTEGER;
      quad_x, quad_y : quad_range;
  BEGIN 
    WRITELN ('*** Klingon Starbase DESTROYED ***', bell);
    kling_base_num := kling_base_num - 1;
    k_docked := 0;
    FOR i := 1 TO random (0, SQR (galaxy_size)) DO
      BEGIN
        REPEAT
          quad_x := random (0, galaxy_size);
          quad_y := random (0, galaxy_size);
        UNTIL (quad_x <> cur_quad.x) OR (quad_y <> cur_quad.y);
        k_docked := k_docked + galaxy[quad_x, quad_y].kling_num;
        galaxy[quad_x, quad_y].kling_num := 0;
      END {of FOR};
    WRITELN (k_docked, ' Klingons were killed while docked');
    total_klingons := total_klingons - k_docked;
  END {of hit_kling_base};

BEGIN {of fire_torpedoes}
  IF cur_torps = 0 THEN
    WRITELN ('All photon torpedoes expended.')
  ELSE
    BEGIN
      WRITE ('Torpedo course: ');
      READLN (course);
      IF condition <> c_docked THEN
        cur_torps := cur_torps - 1;
      x_inc := -COS (radians (course));
      y_inc := SIN (radians (course));
      x_pos := cur_sect.x;
      y_pos := cur_sect.y;
      hit_something := FALSE;
      WRITELN ('Torpedo track:');
      WITH galaxy[cur_quad.x, cur_quad.y] DO
        WHILE NOT hit_something AND (ROUND (x_pos) IN [0..quad_size]) AND
              (ROUND (y_pos) IN [0..quad_size]) DO
          CASE quadrant[ROUND (x_pos), ROUND (y_pos)] OF
            s_enterprise,
            s_nothing    : BEGIN
                             WRITELN (ROUND (x_pos), '-', ROUND (y_pos));
                             x_pos := x_pos + x_inc;
                             y_pos := y_pos + y_inc;
                           END {of s_nothing};
            s_star       : BEGIN
                             hit_something := TRUE;
                             WRITELN ('Star destroyed, you got the planets, ',
                                      'too!  Nice shot!');
                             bad_points := bad_points + random (0, 500);
                             star_num := star_num - 1;
                           END {of s_star};
            s_nova       : BEGIN
                             hit_something := TRUE;
                             star_num := star_num - 1;
                             hit_nova (ROUND (x_pos), ROUND (y_pos), kling_num);
                           END {of s_nova};
            s_klingon    : BEGIN
                             hit_something := TRUE;
                             WRITE ('*** Klingon DESTROYED ***', bell);
                             IF random (0, 100) < 30 THEN
                               WRITE (' (The only good Klingon is a dead',
                                      ' Klingon)');
                             WRITELN;
                             kling_num := kling_num - 1;
                             total_klingons := total_klingons - 1;
                             FOR i := 0 TO max_klingons DO
                               WITH klingons[i] DO
                                 IF (energy_left > 0) AND 
                                    (ROUND (x_pos) = position.x) AND 
                                    (ROUND (y_pos) = position.y) THEN
                                   energy_left := 0;
                           END {of s_klingon};
            s_fed_base   : BEGIN
                             hit_something := TRUE;
                             WRITELN ('*** Starbase destroyed ... ',
                                      'Congratulations ... Dummy ***');
                             bad_points := bad_points + random (0, 500);
                             fed_base_num := fed_base_num - 1;
                           END {of s_fed_base};
            s_kling_base : BEGIN
                             hit_something := TRUE;
                             hit_kling_base (kling_base_num);
                             total_k_bases := total_k_bases - 1;
                           END {of s_kling_base};
          END {of CASE};
      IF hit_something THEN
        quadrant[ROUND (x_pos), ROUND (y_pos)] := s_nothing
      ELSE
        WRITELN ('Torpedo missed.');
    END {of ELSE};
END {of fire_torpedoes};

PROCEDURE self_destruct;
VAR ch : CHAR;
BEGIN
  REPEAT
    WRITE ('Are you SURE ? ');
    READ (ch);
    WRITELN;
  UNTIL ch IN ['y', 'Y', 'n', 'N'];
  IF ch IN ['y', 'Y'] THEN
    EXIT (star_trek);
END {of self_destruct};

PROCEDURE command;
VAR ch : CHAR;
    valid_command : BOOLEAN;
BEGIN
  REPEAT
    WRITE ('Command: ');
    READLN (ch);
    WRITELN;
    valid_command := ch IN [min_device..max_device];
    IF valid_command THEN
      BEGIN
        IF (device[ch].down_time <> 0) AND (ch > SUCC (min_device)) THEN
          WRITELN ('*** ', device[ch].name, ' INOPERABLE ***')
        ELSE
          CASE ch OF 
            '0' : move_enterprise;
            '1' : print_quadrant;
            '2' : print_galaxy (cur_quad.x - 1, cur_quad.y - 1, 2, TRUE);
            '3' : fire_phasers;
            '4' : fire_torpedoes;
            '5' : print_damage;
            '6' : print_galaxy (0, 0, galaxy_size, FALSE);
            '7' : self_destruct;
          END {of CASE};
      END {of IF}
    ELSE
      BEGIN
        WRITELN ('0 = Set course');
        WRITELN ('1 = Short range sensor scan');
        WRITELN ('2 = Long range sensor scan');
        WRITELN ('3 = Fire phasors');
        WRITELN ('4 = Fire photon torpedoes');
        WRITELN ('5 = Damage control report');
        WRITELN ('6 = History computer report');
        WRITELN ('7 = Self destruct');
      END {of ELSE};
  UNTIL valid_command;
  IF ch IN ['0', '3', '4'] THEN
    BEGIN
      klingon_attack;
      print_quadrant;
    END {of IF};
END {of command};

                         {ending of STAR.PART2.TEXT}


========================================================================================
DOCUMENT :usus Folder:VOL09:star.part3.text
========================================================================================

                         {begining of STAR.PART3.TEXT}

PROCEDURE instructions;
VAR ch : CHAR;

  PROCEDURE space_wait;
  BEGIN
    WRITELN;
    WRITE ('Type <space> to continue');
    READ (ch);
    WRITELN;
  END {of space_wait};
  
  PROCEDURE page_1;
  BEGIN
    WRITELN ('The galaxy is divided into 64 quadrants with the');
    WRITELN ('following coordinates:');
    WRITELN;
    WRITELN ('  0   1   2   3   4   5   6   7');
    WRITELN ('---------------------------------');
    WRITELN ('|   |   |   |   |   |   |   |   |  0');
    WRITELN ('---------------------------------');
    WRITELN ('|   |   |   |   |   |   |   |   |  1');
    WRITELN ('---------------------------------');
    WRITELN ('|   |   |   |   |   |   |   |   |  2');
    WRITELN ('---------------------------------');
    WRITELN ('|   |   |   |   |   |   |   |   |  3');
    WRITELN ('---------------------------------');
    WRITELN ('|   |   |   |   |   |   |   |   |  4');
    WRITELN ('---------------------------------');
    WRITELN ('|   |   |   |   |   |   |   |   |  5');
    WRITELN ('---------------------------------');
    WRITELN ('|   |   |   |   |   |   |   |   |  6');
    WRITELN ('---------------------------------');
    WRITELN ('|   |   |   |   |   |   |   |   |  7');
    WRITELN;
    WRITELN ('Each quadrant is similarly divided into 64 sectors.');
    space_wait;
  END {of page_1};
    
  PROCEDURE page_2;
  BEGIN
    WRITELN;
    WRITELN ('::: DEVICES :::');
    WRITELN;
    WRITELN (' :: Warp Engines ::');
    WRITELN;
    WRITELN (' Course = a number in degrees.');
    WRITELN ('   Numbers indicate direction starting at the top and');
    WRITELN ('   going counter clockwise.');
    WRITELN;
    WRITELN ('                     0');
    WRITELN ('                 315 | 45');
    WRITELN ('                    \|/');
    WRITELN ('               270 --*-- 90');
    WRITELN ('                    /|\');
    WRITELN ('                 225 | 135');
    WRITELN ('                    180');
    WRITELN;
    WRITELN (' Warp Factor = a REAL number from 0 to 12.');
    WRITELN ('   Distance traveled = <warp factor> quadrants.');
    WRITELN ('     Warp  .2  =  The Enterprise travels 1 sector.');
    WRITELN ('           .5  =                         4 sectors.');
    WRITELN ('            1  =                         1 quadrant.');
    WRITELN ('            2  =                         2 quadrants.');
    space_wait;
  END {of page_2};
  
  PROCEDURE page_3;
  BEGIN
    WRITELN;
    WRITELN ('   For example, if you travel from quadrant 1-1 in the');
    WRITELN ('   direction of 90 degrees at warp 2, you would stop at');
    WRITELN ('   quadrant 1-3 in the next stardate.  NOTE: every use of');
    WRITELN ('   the warp engines takes one stardate.  If the Enterprise');
    WRITELN ('   is blocked by something during an intra-quadrant travel,');
    WRITELN ('   it will stop in front of it (and waste a stardate).');
    WRITELN;
    WRITELN (' :: Short Range Sensors ::');
    WRITELN;
    WRITELN ('  The short range sensors display a detailed view of the ');
    WRITELN ('  quadrant currently occupied by the Enterprise.  The ');
    WRITELN ('  The following symbols have meanings as follows:');
    WRITELN;
    WRITELN ('          Symbol          Meaning');
    WRITELN ('             ', no_sym, '            empty space');
    WRITELN ('             ', star_sym, '            a stable star');
    WRITELN ('             ', nova_sym, '            an unstable star');
    WRITELN ('             ', ent_sym, '            the Enterprise');
    WRITELN ('             ', f_base_sym, '            a Federation base');
    WRITELN ('             ', kling_sym, '            a Klingon ship');
    WRITELN ('             ', k_base_sym, '            a Klingon base');
    space_wait;
  END {of page_3};

  PROCEDURE page_4;
  BEGIN
    WRITELN;
    WRITELN (' :: Long Range Sensors ::');
    WRITELN;
    WRITELN ('  The long range sensors display the objects in the nine');
    WRITELN ('  closest quadrants.  Each digit in each box means ');
    WRITELN ('  means something:');
    WRITELN;
    WRITELN ('    The ONES digit represents the number of STARS.');
    WRITELN ('        TENS                                FEDERATION BASES.');
    WRITELN ('        HUNDREDS                            KLINGON SHIPS');
    WRITELN ('        THOUSANDS                           KLINGON BASES');
    WRITELN;
    WRITELN ('  For example:');
    WRITELN ('    319 means 3 Klingons, 1 Federation base, and 9 stars.');
    WRITELN ('    206 means 2 Klingons, 0 Federation bases, and 6 stars.');
    WRITELN ('   1007 means 1 Klingon base and 7 stars.');
    WRITELN;
    WRITELN (' :: Phasers ::');
    WRITELN;
    WRITELN ('  Any portion of the energy available can be fired.  The');
    WRITELN ('  battle computer divides this amount among the Klingon');
    WRITELN ('  ships in the quadrant and determines the various directions');
    space_wait;
  END {of page_4};
  
  PROCEDURE page_5;
  BEGIN
    WRITELN;
    WRITELN ('  of fire.  The effectiveness of a hit depends mostly on the');
    WRITELN ('  distance to the target.  A Klingon battle cruiser starts with');
    WRITELN (kling_energy:5, ' units of energy.  It can fire an amount equal to');
    WRITELN ('  whatever energy is left.  Note that phasers are ineffective ');
    WRITELN ('  against stars, Klingon bases, and Federation bases.');
    WRITELN;
    WRITELN (' :: Photon Torpedoes ::');
    WRITELN;
    WRITELN ('  Initially the Enterprise has ', start_torp, ' photon torpedoes.');
    WRITELN ('  One torpedo destroys whatever it hits.  The range of the');
    WRITELN ('  photon torpedoes (like phasers) is limited to the current');
    WRITELN ('  quadrant.  The course of a photon torpedo is set the same');
    WRITELN ('  way as that of the Enterprise.  Torpedoes and phasers are');
    WRITELN ('  restocked when the Enterprise docks at a Federation base.');
    WRITELN;
    WRITELN (' :: Damage Control Report ::');
    WRITELN;
    WRITELN ('  The damage control report lists the state of repair of each');
    WRITELN ('  device.  A non-zero state indicates the number of stardates');
    WRITELN ('  required to repair the device.  Devices can be damaged by');
    WRITELN ('  space storms, and are repaired by time and truces.');
    space_wait;
  END {of page_5};
    
  PROCEDURE page_6;
  BEGIN
    WRITELN;
    WRITELN (' :: History Computers ::');
    WRITELN;
    WRITELN ('  The history computers keep a record of all the quadrants');
    WRITELN ('  scanned with the long range scanners.  The history report');
    WRITELN ('  uses the same display format as the long range scanners,');
    WRITELN ('  except that the entire galaxy is displayed.  A quadrant');
    WRITELN ('  that has not been scanned is printed as "+++++".');
    WRITELN;
    WRITELN (' :: Suicide Device ::');
    WRITELN;
    WRITELN ('  It is possible to implement a self-destruct sequence merely');
    WRITELN ('  by invoking this command.  The game is terminated.');
    WRITELN;
    WRITELN ('To get a list of all commands, type "9" when asked for a');
    WRITELN ('command.  All commands are terminated by the [RETURN] key.');
    WRITELN ('You have at least on supporting starbase.  Your energy and');
    WRITELN ('photon torpedoes are replenished when you are docked at a');
    WRITELN ('Federation starbase.  G O O D   L U C K !');
    WRITELN;
    space_wait;
  END {of page_6};
    
BEGIN
  WRITELN ('Orders:  Stardate ', cur_year);
  WRITELN;
  WRITELN ('As commander of the United Starship Enterprise,');
  WRITELN ('your mission is to rid the galaxy of the deadly');
  WRITELN ('Klingon menace.  To do this, you must destroy the ');
  WRITELN ('Klingon invasion force of ', total_klingons, ' battle cruisers.');
  WRITELN ('You have ', end_year - cur_year + 1, ' solar years to complete');
  WRITELN ('your mission (i.e. until stardate ', end_year, ').  The ');
  WRITELN ('Enterprise is currently in quadrant ', cur_quad.x, '-', 
           cur_quad.y, ', sector ', cur_sect.x, '-', cur_sect.y, '.');
  WRITELN;
  WRITE ('Do you need further instructions (y/n) ? ');
  READ (ch);
  WRITELN;
  WRITELN;
  IF ch IN ['Y', 'y'] THEN
    BEGIN
      page_1;
      page_2;
      page_3;
      page_4;
      page_5;
      page_6;
      WRITELN;
      WRITELN;
    END {of IF};
END {of instructions};

PROCEDURE finish_game;
VAR rating : INTEGER;
BEGIN
  IF (cur_energy <= 0) OR (cur_year >= end_year) THEN
    BEGIN
      WRITELN ('It is stardate ', cur_year, '.  The Enterprise has been');
      WRITELN ('destroyed.  The Federation will be conquered.  There');
      WRITELN ('are still ', total_klingons, ' Klingon battle cruisers.');
      WRITELN ('You are dead.');
    END {of IF}
  ELSE
    BEGIN
      rating := start_klingons DIV (cur_year - start_year) * 100;
      WRITELN ('It is stardate ', cur_year, '.  The last Klingon battle');
      WRITELN ('cruiser in the galaxy has been destroyed.  The Federation');
      WRITE ('has been saved.  ');
      IF bad_points > rating THEN
        BEGIN
          WRITELN ('However, because of your wanton ');
          WRITELN ('destruction of Federation bases and planet systems,');
          WRITELN ('you have been thrown in the brig never to see the');
          WRITELN ('light of day again.');
        END {of IF bad_points}
      ELSE
        BEGIN
          WRITELN ('You are a hero and a new admiral.');
          WRITELN (start_klingons, ' Klingons in ', cur_year - start_year,
                   ' years gives a rating of ', rating);
        END {of ELSE bad_points};
    END {of ELSE};
  END {of finish_game};
      
                          {ending of STAR.PART3.TEXT}
      

========================================================================================
DOCUMENT :usus Folder:VOL09:startrek.text
========================================================================================

PROGRAM star_trek;

CONST ent_energy = 5000;        {units of energy to start enterprise}
      start_torps = 10;         {photon torpedos to start}
      kling_energy = 300;       {units of energy to start klingon ships}
      galaxy_size = 7;          {square size of galaxy - 1}
      quad_size = 7;            {square size of quadrant - 1}
      max_digit = 9;            {maximum value of single digit}
      min_device = '0';         {lowest device number}
      max_device = '7';         {highest device number}
      max_klingons = 11;        {maximum number of klingon entities in 1 quad}
      no_sym = '.';             {symbol for nothingness}
      star_sym = '*';           {symbol for star}
      nova_sym = '+';           {symbol for nova}
      ent_sym = 'E';            {symbol for enterprise}
      f_base_sym = 'B';         {symbol for federation base}
      kling_sym = 'K';          {symbol for klingon ship}
      k_base_sym = '@';         {symbol for klingon base}
      alarm = 7;                {terminal alarm}
      
{$I star.part1.text}
{$I star.part2.text}
{$I star.part3.text}

BEGIN {of star_trek}
  seed := 3.14159;
  initialize;
  setup_quad (cur_quad, cur_sect);
  set_condition;
  instructions;
  klingon_attack;
  print_quadrant;
  WHILE (cur_energy > 0) AND (total_klingons > 0) AND 
        (total_k_bases > 0) AND (cur_year <> end_year) DO
    command;
  finish_game;
END {of star_trek}.


========================================================================================
DOCUMENT :usus Folder:VOL09:volume.9.text
========================================================================================

                    DOCUMENTATION FOR USUS LIBRARY VOLUME 9
                                     Games

     The programs on this disk represent games in various stages of develop-
ment, from ADVENTURE, which is superb and complete, to SPACEWAR, which will
work fine now if you and a friend have your Microengines hooked together,
but needs work for other configurations.

ADVENTURE.....There are a number of files on this disk that comprise the game 
              Adventure, all of which boil down to four (a code file and three 
              data files) when the game is actually run.  This is the FULL, 
              ORIGINAL FORTRAN Adventure, translated into UCSD Pascal via a 
              PL/I version.  Several of us have played it, and we have all 
              found it the fastest disk-based ADVENTURE going.  Splendid job, 
              Mike Turner!
              
              To get started, READ THE DOCUMENTATION, which tells you how to 
              set up the data files with ADVINIT, and don't forget 
              ADV.MISCINFO, which tells the system how big your screen is.  
              Total setup time with a fresh disk is about 10 minutes, required 
              once only.
              
STARTREK......Barry Demchak wrote a good if relatively routine Pascal version
              of the BASIC classic; it has the added feature of Klingon
              starbases to make life interesting.  
              
              Startrek always seems to inspire game programmers to further 
              heights, and if this is your passion, Barry's given you a good 
              start...maybe add real time?  If so, several caveats:  use a
              counter to time moves, rather than the system clock, which few
              of us have (and scale the counter with a startup query of slow,
              medium, or fast processor).  Put all your screen control in one
              place so we can find it, perhaps in your own screen control unit
              (a USUS standard screen control unit is being drafted).
              
CASTLES.......This is Pat Horton's implementation of a strategic board game.  
              Board and move codes are described in CASTLES.DOC, which you 
              should probably have printed out and sitting beside you when you
              play.
              
SPACEWAR......Pat Horton has done an excellent job of putting together the
              start of the classic battling space ships.  It is designed to be
              used with two computers hooked together by their remote ports
              (or is it two terminals and one computer?).  To get an idea of
              how the game functions with only one terminal, delete the 8th
              line from the end ("WHILE NOT...") and play with one ship
              inoperative.
              
              Playing is easy, since there are only five commands.  Control H, 
              J, K, and L are used to control the ship:  ^H and ^L turn it 45 
              degrees to the right and to the left; ^J causes the ship to 
              accelerate in its current direction; and ^K causes the ship to
              fire.  Typing a "q" or "Q" quits the game.
              
              This version lacks a sun, although there seems to be a 
              gravitational field pulling you toward the center.  If you move 
              to the edge of the screen, you'll bounce back like a tennis 
              ball, rather than appearing on the other side of the screen as 
              is usually done.  "Bullets" fired have little momentum, and 
              mostly follow your ship; I saw only one at a time.  Action
              happens only if you or your opponent press a key, though it
              keeps up with "repeat" keys nicely and moves fast.  Pat has
              done a nice job of indicating the orientation of your ship (it
              requires all printing ASCII characters, however, and may not
              work on a standard Apple).  There are several instances of 
              writing an ESC-"*" sequence to the screen, which I believe is 
              meant to clear it.
              
              
                                 Good playing!!
                        Jim Gagne, USUS Library Chairman
       Datamed Research, Inc., 1433 Roscomare Road, Los Angeles, CA 90024

========================================================================================
DOCUMENT :usus Folder:VOL10:benchmark.text
========================================================================================

program BENCHMARK; 

type

      REC2_TYPE=record
        next:^REC2_TYPE
      end;
      
var   NUM_LOOPS:integer;
      I,J,K,L,TEST:integer;
      R,S,T:real;
      A:array [1..100] of integer;
      B:array [1..100] of real;
      STR1,STR2,STR3:string[80]; 
      CH:char;
      REC1:record 
             FIRSTI,SECONDI:integer;
             FIRSTR,SECONDR:real;
           end;
      ROOT,PTR:^REC2_TYPE;
      CSET:set of char;
      
procedure prompt;
  
procedure prompt1;
begin
  writeln('21. CASE statements.                 22. PROCEDURE calls.');
  writeln('23. PROC. calls w/INTEGER param.     24. PROC. calls w/REAL param.');
  writeln('25. PROC. calls w/local var.         26. SET unions.');
  writeln('27. SET differences.                 28. SET IN''s.');
  writeln('29. pointer transfers.               30. STRING transfers.'); 
  writeln('31. STRING comparison.'); 
  writeln;
  writeln('STRING functions    32. LENGTH   33. COPY   34. POS   35. CONCAT');
  writeln('                    36. DELETE   37. INSERT');
  writeln('number crunching    38. SIN   39. COS   40. EXP   41. ATAN');
  writeln('                    42. LN    43. LOG   44. PWROFTEN   45. TRUNC'); 
  writeln('                    46. ROUND');
end;

begin
  gotoxy(0,0);
  write(chr(26));
  writeln(' 1. null FOR loops (TO).              2. null FOR loops (DOWNTO).'); 
  writeln(' 3. INTEGER increments (FOR loop).    4. null WHILE loops.');
  writeln(' 5. null REPEAT loops.                6. INTEGER adds.');
  writeln(' 7. INTEGER multiplies.               8. INTEGER divides.'); 
  writeln(' 9. REAL increments.                 10. REAL adds'); 
  writeln('11. REAL multiplies.                 12. REAL divides.'); 
  writeln('13. INTEGER transfers.               14. INTEGER ARRAY transfers.'); 
  writeln('15. REAL transfers.                  16. REAL ARRAY transfers.');
  writeln('17. INTEGER RECORD transfers.        18. REAL RECORD transfers.'); 
  writeln('19. INTEGER IF comparisons.          20. REAL IF comparisons.');
  prompt1;
end; {PROMPT}

procedure SPACEBAR;
begin
  repeat
    read(keyboard,CH)
  until CH=' '
end; {SPACEBAR}

procedure DUMMY1; 
begin 
end; {DUMMY1} 

procedure DUMMY2(I:integer); 
begin
end; {DUMMY2}

procedure DUMMY3(I:real);
begin 
end; {DUMMY3}

procedure DUMMY4;
var I:integer;
begin
end; {DUMMY4}

procedure TEST1;
begin 
  write('1--> hit SPACEBAR to start ',NUM_LOOPS,' null FOR loops (TO) timing...');
  SPACEBAR;
  write(chr(7)); 
  for I:=1 to NUM_LOOPS do begin end;
  writeln;
  write(chr(7),'     end null FOR loops (TO) timing...'); 
  writeln;
  writeln
end; {TEST1} 

procedure TEST2;
begin 
  write('2--> hit SPACEBAR to start ',NUM_LOOPS,' null FOR loops (DOWNTO) timing...');
  SPACEBAR;
  write(chr(7)); 
  for I:=NUM_LOOPS downto 1 do begin end;
  writeln;
  write(chr(7),'     end null FOR loops (DOWNTO) timing...'); 
  writeln;
  writeln
end; {TEST2} 

procedure TEST3;
begin 
  write('3--> hit SPACEBAR to start ',NUM_LOOPS,' integer increments (FOR loop) timing...');
  SPACEBAR;
  J:=0;
  write(chr(7)); 
  for I:=1 to NUM_LOOPS do begin J:=J+1 end; 
  writeln;
  write(chr(7),'     end integer increments (FOR loop) timing...'); 
  writeln;
  writeln
end; {TEST3} 

procedure TEST4;
begin 
  write('4--> hit SPACEBAR to start ',NUM_LOOPS,' null WHILE loops timing...'); 
  SPACEBAR;
  J:=0;
  write(chr(7)); 
  while (J<NUM_LOOPS) do begin J:=J+1 end; 
  writeln;
  write(chr(7),'     end null WHILE loops timing...');
  writeln;
  writeln
end; {TEST4} 

procedure TEST5;
begin 
  write('5--> hit SPACEBAR to start ',NUM_LOOPS,' null REPEAT loops timing...');
  SPACEBAR;
  J:=0;
  write(chr(7)); 
  repeat J:=J+1 until (J=NUM_LOOPS);
  writeln; 
  write(chr(7),'     end null REPEAT loops timing...'); 
  writeln;
  writeln
end; {TEST5} 

procedure TEST6;
begin 
  write('6--> hit SPACEBAR to start ',NUM_LOOPS,' INTEGER adds timing...');
  SPACEBAR;
  write(chr(7)); 
  for I:=1 to NUM_LOOPS do begin J:=J+K end; 
  writeln;
  write(chr(7),'     end INTEGER adds timing...'); 
  writeln;
  writeln
end; {TEST6} 

procedure TEST7;
begin 
  write('7--> hit SPACEBAR to start ',NUM_LOOPS,' INTEGER mulitplies timing...'); 
  SPACEBAR;
  write(chr(7)); 
  for I:=1 to NUM_LOOPS do begin J:=K*1 end; 
  writeln;
  write(chr(7),'     end INTEGER mulitplies timing...'); 
  writeln;
  writeln
end; {TEST7} 

procedure TEST8;
begin 
  write('8--> hit SPACEBAR to start ',NUM_LOOPS,' INTEGER divides timing...');
  SPACEBAR;
  write(chr(7)); 
  for I:=1 to NUM_LOOPS do begin J:=K div 1 end; 
  writeln;
  write(chr(7),'     end INTEGER divides timing...'); 
  writeln;
  writeln
end; {TEST8} 

procedure TEST9;
begin 
  write('9--> hit SPACEBAR to start ',NUM_LOOPS,' REAL increments timing...');
  SPACEBAR;
  write(chr(7)); 
  for I:=1 to NUM_LOOPS do begin R:=R+1.0 end;
  writeln;
  write(chr(7),'     end REAL increments timing...'); 
  writeln;
  writeln
end; {TEST9} 

procedure TEST10;
begin 
  write('10--> hit SPACEBAR to start ',NUM_LOOPS,' REAL adds timing...');
  SPACEBAR;
  write(chr(7)); 
  for I:=1 to NUM_LOOPS do begin R:=R+S end; 
  writeln;
  write(chr(7),'      end REAL adds timing...'); 
  writeln;
  writeln
end; {TEST10} 

procedure TEST11;
begin 
  write('11--> hit SPACEBAR to start ',NUM_LOOPS,' REAL multiplies timing...');
  SPACEBAR;
  write(chr(7)); 
  for I:=1 to NUM_LOOPS do begin R:=S*T end; 
  writeln;
  write(chr(7),'      end REAL multiplies timing...'); 
  writeln;
  writeln
end; {TEST11} 

procedure TEST12;
begin 
  write('12--> hit SPACEBAR to start ',NUM_LOOPS,' REAL divides timing...');
  SPACEBAR;
  write(chr(7)); 
  for I:=1 to NUM_LOOPS do begin R:=S/T end; 
  writeln;
  write(chr(7),'      end REAL divides timing...'); 
  writeln;
  writeln
end; {TEST12} 

procedure TEST13;
begin 
  write('13--> hit SPACEBAR to start ',NUM_LOOPS,' INTEGER transfers timing...');
  SPACEBAR;
  write(chr(7)); 
  for I:=1 to NUM_LOOPS do begin J:=K end; 
  writeln;
  write(chr(7),'      end INTEGER transfers timing...'); 
  writeln;
  writeln
end; {TEST13} 

procedure TEST14; 
begin 
  J:=5;
  K:=12;
  write('14--> hit SPACEBAR to start ',NUM_LOOPS,' INTEGER ARRAY transfers timing...'); 
  SPACEBAR;
  write(chr(7)); 
  for I:=1 to NUM_LOOPS do begin A[J]:=A[K] end; 
  writeln;
  write(chr(7),'      end INTEGER ARRAY transfers timing...'); 
  writeln;
  writeln
end; {TEST14} 

procedure TEST15;
begin 
  write('15--> hit SPACEBAR to start ',NUM_LOOPS,' REAL transfers timing...');
  SPACEBAR;
  write(chr(7)); 
  for I:=1 to NUM_LOOPS do begin R:=S end; 
  writeln;
  write(chr(7),'      end REAL transfers timing...'); 
  writeln;
  writeln
end; {TEST15} 

procedure TEST16;
begin 
  J:=5;
  K:=12;
  write('16--> hit SPACEBAR to start ',NUM_LOOPS,' REAL ARRAY transfers timing...'); 
  SPACEBAR;
  write(chr(7)); 
  for I:=1 to NUM_LOOPS do begin B[J]:=B[K] end; 
  writeln;
  write(chr(7),'      end REAL ARRAY transfers timing...'); 
  writeln;
  writeln
end; {TEST16} 

procedure TEST17;
begin 
  write('17--> hit SPACEBAR to start ',NUM_LOOPS,' INTEGER RECORD transfers timing...'); 
  SPACEBAR;
  write(chr(7)); 
  for I:=1 to NUM_LOOPS do begin REC1.FIRSTI:=REC1.SECONDI end;
  writeln;
  write(chr(7),'      end INTEGER RECORD transfers timing...'); 
  writeln;
  writeln
end; {TEST17} 

procedure TEST18;
begin 
  write('18--> hit SPACEBAR to start ',NUM_LOOPS,' REAL RECORD transfers timing...');
  SPACEBAR;
  write(chr(7)); 
  for I:=1 to NUM_LOOPS do begin REC1.FIRSTR:=REC1.SECONDR end;
  writeln;
  write(chr(7),'      end REAL RECORD transfers timing...'); 
  writeln;
  writeln
end; {TEST18} 

procedure TEST19;
begin 
  J:=5;
  K:=12;
  write('19--> hit SPACEBAR to start ',NUM_LOOPS,' INTEGER IF comparisions timing...'); 
  SPACEBAR;
  write(chr(7)); 
  for I:=1 to NUM_LOOPS do if (J<K) then begin end; 
  writeln;
  write(chr(7),'      end INTEGER IF comparisions timing...'); 
  writeln;
  writeln
end; {TEST19} 

procedure TEST20;
begin 
  R:=5.0;
  S:=12.0;
  write('20--> hit SPACEBAR to start ',NUM_LOOPS,' REAL IF comparisons timing...'); 
  SPACEBAR;
  write(chr(7)); 
  for I:=1 to NUM_LOOPS do if (R<S) then begin end; 
  writeln;
  write(chr(7),'      end REAL IF comparisons timing...'); 
  writeln;
  writeln
end; {TEST20} 

procedure TEST21;
begin 
  J:=2;
  write('21--> hit SPACEBAR to start ',NUM_LOOPS,' CASE statements timing...');
  SPACEBAR;
  write(chr(7)); 
  for I:=1 to NUM_LOOPS do
    case J of
      1:begin end;
      2:begin end;
      3:begin end;
      4:begin end;
   end;
  writeln;
  write(chr(7),'      end CASE statements timing...'); 
  writeln;
  writeln
end; {TEST21} 

procedure TEST22;
begin 
  write('22--> hit SPACEBAR to start ',NUM_LOOPS,' PROCEDURE calls timing...');
  SPACEBAR;
  write(chr(7)); 
  for I:=1 to NUM_LOOPS do DUMMY1;
  writeln;
  write(chr(7),'      end PROCEDURE calls timing...'); 
  writeln;
  writeln
end; {TEST22} 

procedure TEST23;
begin 
  write('23--> hit SPACEBAR to start ',NUM_LOOPS,' PROCEDURE calls (INTEGER param) timing...'); 
  SPACEBAR;
  write(chr(7)); 
  for I:=1 to NUM_LOOPS do DUMMY2(I);
  writeln; 
  write(chr(7),'      end PROCEDURE calls (INTEGER param) timing...'); 
  writeln;
  writeln
end; {TEST23} 

procedure TEST24;
begin 
  write('24--> hit SPACEBAR to start ',NUM_LOOPS,' PROCEDURE calls (REAL param) timing...');
  SPACEBAR;
  write(chr(7)); 
  for I:=1 to NUM_LOOPS do DUMMY3(R);
  writeln; 
  write(chr(7),'      end PROCEDURE calls (REAL param) timing...'); 
  writeln;
  writeln
end; {TEST24} 

procedure TEST25;
begin 
  write('25--> hit SPACEBAR to start ',NUM_LOOPS,' PROCEDURE calls (local var) timing...');
  SPACEBAR;
  write(chr(7)); 
  for I:=1 to NUM_LOOPS do DUMMY4;
  writeln;
  write(chr(7),'      end PROCEDURE calls (local var) timing...'); 
  writeln;
  writeln
end; {TEST25} 

procedure TEST26;
begin 
  write('26--> hit SPACEBAR to start ',NUM_LOOPS,' SET unions timing...');
  SPACEBAR;
  write(chr(7)); 
  for I:=1 to NUM_LOOPS do begin CSET:=CSET+['a','b'] end;
  writeln;
  write(chr(7),'      end SET unions timing...'); 
  writeln;
  writeln
end; {TEST26} 

procedure TEST27;
begin 
  write('27--> hit SPACEBAR to start ',NUM_LOOPS,' SET differences timing...');
  SPACEBAR;
  write(chr(7)); 
  for I:=1 to NUM_LOOPS do begin CSET:=CSET-['a','b'] end;
  writeln;
  write(chr(7),'      end SET differences timing...'); 
  writeln;
  writeln
end; {TEST27} 

procedure TEST28;
begin 
  write('28--> hit SPACEBAR to start ',NUM_LOOPS,' SET IN''s timing...');
  SPACEBAR;
  write(chr(7)); 
  for I:=1 to NUM_LOOPS do if (CH in CSET) then begin end; 
  writeln;
  write(chr(7),'      end SET IN''s timing...'); 
  writeln;
  writeln
end; {TEST28} 

(*$I BENCHMARK1.TEXT*)

begin  {MAIN PROGRAM}
  write(chr(26),chr(30));
  J:=100; K:=200; L:=300; R:=400; S:=500; T:=600;
  write('Enter number of loops per test:  ');
  readln(NUM_LOOPS);
  repeat
    PROMPT;
    writeln;
    write('Enter test (enter "0" for all, negative number to quit):  ');
    readln(TEST); 
    write(chr(26),chr(30));
    if (TEST>=0) then 
      case TEST of
         0:begin
             TEST1; TEST2; TEST3; TEST4; TEST5; TEST6; TEST7; TEST8; 
             TEST9; TEST10; TEST11; TEST12; TEST13; TEST14; TEST15;
             TEST16; TEST17; TEST18; TEST19; TEST20; TEST21; TEST22;
             TEST23; TEST24; TEST25; TEST26; TEST27; TEST28; TEST29; 
             TEST30; TEST31; TEST32; TEST33; TEST34; TEST35; TEST36;
             TEST37; TEST38; TEST39; TEST40; TEST41; TEST42; TEST43;
             TEST44; TEST45; TEST46;
           end; 
         1:TEST1; 2:TEST2; 3:TEST3; 4:TEST4; 5:TEST5; 6:TEST6; 7:TEST7; 
         8:TEST8; 9:TEST9; 10:TEST10; 11:TEST11; 12:TEST12; 13:TEST13; 
        14:TEST14; 15:TEST15; 16:TEST16; 17:TEST17; 18:TEST18; 19:TEST19;
        20:TEST20; 21:TEST21; 22:TEST22; 23:TEST23; 24:TEST24; 25:TEST25;
        26:TEST26; 27:TEST27; 28:TEST28; 29:TEST29; 30:TEST30; 31:TEST31;
        32:TEST32; 33:TEST33; 34:TEST34; 35:TEST35; 36:TEST36; 37:TEST37;
        38:TEST38; 39:TEST39; 40:TEST40; 41:TEST41; 42:TEST42; 43:TEST43;
        44:TEST44; 45:TEST45; 46:TEST46;
      end;
  until (TEST<0);
end.




========================================================================================
DOCUMENT :usus Folder:VOL10:benchmark1.text
========================================================================================

procedure TEST29;
begin 
  new(ROOT);
  new(ROOT^.NEXT);
  ROOT^.NEXT^.NEXT:=ROOT; 
  PTR:=ROOT; 
  write('29--> hit SPACEBAR to start ',NUM_LOOPS,
       ' pointer transfers timing...'); 
  SPACEBAR;
  write(chr(7)); for I:=1 to NUM_LOOPS do begin PTR:=PTR^.NEXT end;
  writeln;
  write(chr(7),'      end pointer transfers timing...'); 
  writeln;
  writeln
end; {TEST29} 

procedure TEST30;
begin
  STR1:='27--> hit SPACEBAR to start NUM_LOOPS STRING operations timing...';
  write('30--> hit SPACEBAR to start ',NUM_LOOPS,' STRING transfers timing...'); 
  SPACEBAR; 
  write(chr(7)); 
  for I:=1 to NUM_LOOPS do begin STR2:=STR1 end;
  writeln;
  write(chr(7),'      end STRING transfers timing...'); 
  writeln;
  writeln
end; {TEST30} 

procedure TEST31;
begin
  STR1:='27--> hit SPACEBAR to start NUM_LOOPS STRING operations timing...';
  STR2:='27--> hit SPACEBAR to start NUM_LOOPS STRING operations timing.. ';
  write('31--> hit SPACEBAR to start ',NUM_LOOPS,' STRING comparison timing...'); 
  SPACEBAR; 
  write(chr(7)); 
  for I:=1 to NUM_LOOPS do if (STR2=STR1) then begin end; 
  writeln;
  write(chr(7),'      end STRING comparison timing...');
  writeln;
  writeln
end; {TEST31} 

procedure TEST32;
begin 
  STR1:='27--> hit SPACEBAR to start NUM_LOOPS STRING operations timing...';
  write('32--> hit SPACEBAR to start ',NUM_LOOPS,' LENGTH operations timing...');
  SPACEBAR;
  write(chr(7)); 
  for I:=1 to NUM_LOOPS do begin J:=length(STR1) end; 
  writeln;
  write(chr(7),'      end LENGTH operations timing...'); 
  writeln;
  writeln
end; {TEST32} 

procedure TEST33;
 begin
  STR1:='27--> hit SPACEBAR to start NUM_LOOPS STRING operations timing...';
  write('33--> hit SPACEBAR to start ',NUM_LOOPS,' COPY operations timing...');
  SPACEBAR;
  write(chr(7)); 
  for I:=1 to NUM_LOOPS do begin STR2:=copy(STR1,1,65) end; 
  writeln;
  write(chr(7),'      end COPY operations timing...'); 
  writeln;
  writeln
end; {TEST33} 

procedure TEST34; 
begin
  STR1:='27--> hit SPACEBAR to start NUM_LOOPS STRING operations timing...';
  write('34--> hit SPACEBAR to start ',NUM_LOOPS,' POS operations timing...');
  SPACEBAR;
  write(chr(7)); 
  for I:=1 to NUM_LOOPS do begin J:=pos('...',STR1) end;
  writeln;
  write(chr(7),'      end POS operations timing...'); 
  writeln;
  writeln
end; {TEST34} 

procedure TEST35; 
begin
  STR1:='27--> hit SPACEBAR to start NUM_LOOPS STRING operations timing...';
  STR2:='This is it!!  '; 
  write('35--> hit SPACEBAR to start ',NUM_LOOPS,' CONCAT operations timing...'); 
  SPACEBAR;
  write(chr(7)); 
  for I:=1 to NUM_LOOPS do begin STR3:=concat(STR1,STR2) end; 
  writeln;
  write(chr(7),'      end CONCAT operations timing...'); 
  writeln;
  writeln
end; {TEST35} 

procedure TEST36;
begin 
  STR1:='27--> hit SPACEBAR to start NUM_LOOPS STRING operations timing...';
  write('36--> hit SPACEBAR to start ',NUM_LOOPS,' DELETE operations timing...');
  SPACEBAR;
  write(chr(7)); 
  for I:=1 to NUM_LOOPS do begin delete(STR1,6,11) end; 
  writeln;
  write(chr(7),'      end DELETE operations timing...'); 
  writeln;
  writeln
end; {TEST36} 

procedure TEST37;
begin
  STR1:='27--> hit SPACEBAR to start NUM_LOOPS STRING operations timing...';
  write('37--> ht SPACEBAR to start ',NUM_LOOPS,' INSERT operations timing...');
  SPACEBAR;
  write(chr(7)); 
  for I:=1 to NUM_LOOPS do begin insert('STR1 = ',STR1,1) end;
  writeln;
  write(chr(7),'      end INSERT operations timing...'); 
  writeln;
  writeln
end; {TEST37} 

procedure TEST38; 
begin
  write('38--> hit SPACEBAR to start ',NUM_LOOPS,' SIN evaluations timing...');
  SPACEBAR;
  write(chr(7)); 
  for I:=1 to NUM_LOOPS do begin R:=sin(I) end; 
  writeln;
  write(chr(7),'      end SIN evaluations timing...'); 
  writeln;
  writeln
end; {TEST38} 

procedure TEST39;
begin
  write('39--> hit SPACEBAR to start ',NUM_LOOPS,' COS evaluations timing...');
  SPACEBAR;
  write(chr(7)); 
  for I:=1 to NUM_LOOPS do begin R:=cos(I) end; 
  writeln;
  write(chr(7),'      end COS evaluations timing...'); 
  writeln;
  writeln
end; {TEST39} 

procedure TEST40;
begin
  write('40--> hit SPACEBAR to start ',NUM_LOOPS,' EXP evaluations timing...'); 
  R:=-1.34583E-1;
  SPACEBAR;
  write(chr(7)); 
  for I:=1 to NUM_LOOPS do begin S:=exp(R) end; 
  writeln;
  write(chr(7),'      end EXP evaluations timing...'); 
  writeln;
  writeln
end; {TEST40} 

procedure TEST41;
begin
  write('41--> hit SPACEBAR to start ',NUM_LOOPS,' ATAN evaluations timing...');
  SPACEBAR;
  write(chr(7)); 
  for I:=1 to NUM_LOOPS do begin R:=atan(I) end;
  writeln;
  write(chr(7),'      end ATAN evaluations timing...'); 
  writeln;
  writeln
end; {TEST41} 

procedure TEST42;
begin
  write('42--> hit SPACEBAR to start ',NUM_LOOPS,' LN evaluations timing...');
  SPACEBAR;
  write(chr(7)); 
  for I:=1 to NUM_LOOPS do begin R:=ln(I) end;
  writeln;
  write(chr(7),'      end LN evaluations timing...'); 
  writeln;
  writeln
end; {TEST42} 

procedure TEST43;
begin
  write('43--> hit SPACEBAR to start ',NUM_LOOPS,' LOG evaluations timing...'); 
  SPACEBAR;
  write(chr(7)); 
  for I:=1 to NUM_LOOPS do begin R:=log(I) end; 
  writeln;
  write(chr(7),'      end LOG evaluations timing...'); 
  writeln;
  writeln
end; {TEST43} 

procedure TEST44; 
begin
  J:=32;
  write('44--> hit SPACEBAR to start ',NUM_LOOPS,' PWROFTEN operations timing...'); 
  SPACEBAR;
  write(chr(7)); 
  for I:=1 to NUM_LOOPS do begin R:=PWROFTEN(J) end;
  writeln;
  write(chr(7),'      end PWROFTEN operations timing...'); 
  writeln;
  writeln
end; {TEST44} 

procedure TEST45;
begin
  R:=2.79234E4;
  write('45--> hit SPACEBAR to start ',NUM_LOOPS,' TRUNC operations timing...'); 
  SPACEBAR;
  write(chr(7)); 
  for I:=1 to NUM_LOOPS do begin J:=trunc(R) end; 
  writeln;
  write(chr(7),'      end TRUNC operations timing...'); 
  writeln;
  writeln
end; {TEST45} 

procedure TEST46;
begin
  R:=2.79234E4;
  write('46--> hit SPACEBAR to start ',NUM_LOOPS,' ROUND operations timing...');
  SPACEBAR;
  write(chr(7)); 
  for I:=1 to NUM_LOOPS do begin J:=ROUND(R) end; 
  writeln;
  write(chr(7),'      end ROUND operations timing...'); 
  writeln;
  writeln
end; {TEST46} 

begin  {MAIN PROGRAM}
  write(chr(26),chr(30));
  J:=100; K:=200; L:=300; R:=400; S:=500; T:=600;
  write('Enter number of loops per test:  ');
  readln(NUM_LOOPS);
  repeat
    PROMPT;
    writeln;
    write('Enter test (enter "0" for all, negative number to quit):  ');
    readln(TEST); 
    write(chr(26),chr(30));
    if (TEST>=0) then 
      case TEST of
         0:begin
             TEST1; TEST2; TEST3; TEST4; TEST5; TEST6; TEST7; TEST8; 
             TEST9; TEST10; TEST11; TEST12; TEST13; TEST14; TEST15;
             TEST16; TEST17; TEST18; TEST19; TEST20; TEST21; TEST22;
             TEST23; TEST24; TEST25; TEST26; TEST27; TEST28; TEST29; 
             TEST30; TEST31; TEST32; TEST33; TEST34; TEST35; TEST36;
             TEST37; TEST38; TEST39; TEST40; TEST41; TEST42; TEST43;
             TEST44; TEST45; TEST46;
           end; 
         1:TEST1; 2:TEST2; 3:TEST3; 4:TEST4; 5:TEST5; 6:TEST6; 7:TEST7; 
         8:TEST8; 9:TEST9; 10:TEST10; 11:TEST11; 12:TEST12; 13:TEST13; 
        14:TEST14; 15:TEST15; 16:TEST16; 17:TEST17; 18:TEST18; 19:TEST19;
        20:TEST20; 21:TEST21; 22:TEST22; 23:TEST23; 24:TEST24; 25:TEST25;
        26:TEST26; 27:TEST27; 28:TEST28; 29:TEST29; 30:TEST30; 31:TEST31;
        32:TEST32; 33:TEST33; 34:TEST34; 35:TEST35; 36:TEST36; 37:TEST37;
        38:TEST38; 39:TEST39; 40:TEST40; 41:TEST41; 42:TEST42; 43:TEST43;
        44:TEST44; 45:TEST45; 46:TEST46;
      end;
  until (TEST<0);
end.



========================================================================================
DOCUMENT :usus Folder:VOL10:btre.file.text
========================================================================================


{************************************************************************
*                                                                       *
*  filed as BTRE.FILE.TEXT                                              *
*                                                                       *
************************************************************************}

{$S+}
{$G+}
program BTREE_ADDRESS_FILES;

{

        program title:          B-TREE ADDRESS
        written by:             R. M. Wilson
                                HI-COUNTRY DATA SYSTEMS
                                P.O. Box 4095
                                Woodland Park, CO. 80863

        date written:           12 August 1981
        latest revision:        26-May-82

        program function:
        ----------------

            This program is designed to:

                Test a pascal implementation of B-trees using files.  The
                program is based on a standard B-TREE algorithm implemented
                with pointers found in ALGORITHMS + DATA STRUCTURES = PROGRAMS
                by Niklaus Wirth on pages 253-257.

program development notes:
-------------------------

26-May-82 Several very important bugs concerning the value of PERSON_AVAIL
          after the deletion of the last data element in the root node were
          corrected.




        remarks:
        -------

           This program was written while developing a program for a small
           business where retrival of customer information was an operation
           which had to be fast.  Further, ease of updating and modifing the
           various records was also a prime consideration.  This particular
           program was designed to serve as the test bed for the final program
           and as a ready reference of a file structure implementation of a B-
           tree.  It can easily be modified for many different business
           applications requiring fast data retrival.

           This program uses strings as the key rather than integers as does
           Wirth's program.  It should be of note that significant changes have
           been made in the main program to increase the program's usefulness,
           to reduce the number of "data entry" crashes, and to increase the
           "bells & whistles" that the user sees.

           Since the program is primarily designed as a demonstration of the B-
           tree implemented with files, the program output is directed towards
           that end.  The program prints out the unique keys in the B-tree and
           then, upon request, will print a list of all the keys (unique or
           duplicate) in either alphabetical or reverse alphabetical order.
           (Duplicate keys will be printed out in the order in which they were
           entered.) In order to convert the program into a real utility, some
           rather minor changes would have to be made. (Hints on how to do this
           are contained in the documen-tation.)

           The biggest problem in converting the original program from pointers
           to files was keeping track of which node/record number should be in
           the window after the completion of a call to a procedure in which the
           window was shifted by a "seek" command.

           The second biggest problem (26-May-82) was trying to find where the
           persistant little bug was that kept cropping up from time to time
           where data previously entered was lost.  The cause, hopefully, was
           rather sloppy control of the value of PERSON_AVAIL when the root node
           only contained one record, and that record was deleted either through
           an intentional deletion or by default when the record was modified in
           such a way that the key was changed.  
           
           The program has been extensively documented to help the user
           understand how the program functions.  Although quite a bit of time
           was spent documenting the program, a recursively implemented b-tree
           using a file structure can be a mess to trace. With that in mind,
           there is every possibility that the documen-tation may be incorrect
           in one or two spots in regards to exactly what each step is designed
           to accomplish.

           Although the documentation may be a bit tedious for those who are
           already familiar with using files in UCSD PASCAL, the repetative
           steps are documented in order to help the user who is not as
           proficient.

           Further, even though there is so much documentation as to make the
           page appear rather grey and hard to read instead of the crispness
           often associated with a PASCAL program, it was felt that it was
           better to over document rather than under document with the confusion
           that might result.

           In addition to the B-tree implementation, I have attempted to
           incorporate some features to enhance the usability of the program
           such as hopefully "bomb proof" data entry, all keys coverted to
           uppercase, facilities to change the location of a record if the key
           is changed due to a correction made to the person's first or last
           name, etc.  Most importantly, provisions for duplicate keys have been
           made, and "garbage collection" is performed to reuse emptied nodes.
           Procedures for inorder and post order traversal of the b-tree have
           been included as well.

           The method of handling collisions of duplicate keys is by the use of
           a linked list structure.  When an initial collision occurs, an empty
           node is fetched and the duplicate key stored in this node.  The
           duplicate node is linked to the original key via an integer pointer.
           If the duplicate node reaches capacity an additional empty node is
           fetched and linked into the chain, etc.  The use of a full node to
           store one duplicate key is very uneconomical in terms of disk space,
           but is far faster and easier to implement than a separate file of
           collision nodes with the same key, and avoids the problem of file
           management when a file grows to the point that it "collides" with
           another file on the disk.

           A more efficient use of the disk space could be obtained if through
           analysis or previous experience you can estimate how many collisions
           are likely to occur for a given data base and a file of PERSON
           (inaddition to the file of PERSON_NODE) is put on the disk when the
           program is initialized.  Using this techique would require extensive
           rewriting of the present program and, depending on the number of
           estimated collisions per unique key, could significantly and adversly
           affect the retrival time for a given duplicate key.

           The nodes of the B-tree are limited to a maximum size of four records
           per node.  This was done to make tracing and learning the B=tree
           easier.  The constant MAX_NODE_SIZE can be increased as you desire.
           (For example if MAX_NODE_SIZE=8 then there are a maximum of five disk
           accesses to find any one of 2000 records.) Obiviously the greater
           MAX_NODE_SIZE is the fewer disk accesses required for a given number
           of data.  
           
           It should be of note that the program as presented is not optimized
           for either memory usage or efficient operation.  The program
           developed for the business application implemented six separate B-
           trees.  In order to reduce the memory requirments case statements
           were used extensively along with a type declaration which kept track
           of the particular record structure.  The various procedures nested
           within SEARCH and DELETE were broken out and the parameter list for
           each was increased as required to ensure proper functioning.  Each of
           the major program functions was also set up as a segment procedure to
           optimize memory usage.

           The initialization routine puts 20 empty nodes on the disk. This
           number is controlled by MAX_PERS_NODES, and can be set to any size
           your disk drives will handle.  (Using a fixed size data file has the
           advantage that the file will not be blocked by other files on the
           disk as the amount of data in the file grows.)

           You should be note that the program is rather limited in its
           capacity.  A maximum of only 80 people can be stored when
           MAX_NODE_SIZE=4 and MAX_PERS_NODES=20.  Due to the nature of the B-
           tree structure, even though 20 nodes can in theory store 80 records
           this maximum is obtained only where there are not a lot of operations
           where the new record entered is put into an already full node.  When
           ever this happens, two new nodes are required.  By simple reasoning,
           you can see if every node in the tree is full and you try to insert a
           new node then one new node is required for each level of the tree up
           to the root node where two new nodes are required if it is full.

           In this tree of order 4 if the root node is full then it must have
           five children.  If each of those children are full and do not have
           any successor nodes then if you insert a new record, the tree is
           adjusted with a new root node and the old root node is broken into
           two sub nodes with two records each whose children have records as
           follows:

                        sub node "1" children 4,4,4

                        sub node "2" children 4,2,2

           As you can see (especially if you run the program!) the tree is now a
           3 level tree with only one more record but two more nodes.  If we
           continued to add new records into the nodes which are already full,
           we will quickly reach our maximum of 20 nodes and would not be any
           where close to 80 total records.  So it should be apparent that the
           maximum empty nodes required to safely start an insertion operation
           is equal to the depth of the tree plus one.

           It should be further be ovibious that the maximum depth of the tree
           is equal to N where N is the largest integer possible where
           exp(N*ln(MAX_NODE_SIZE))<=MAX_PERS_NODES, and then the minimum number
           of empty or unused nodes required to ensure a successful insertion is
           N+1.

           In order to enable the user to appreciate all of the disk accesses
           that must take place during insertions and deletions, a period is
           printed out for each "seek" that is executed.



IMPLEMENTATION NOTES
--------------------

        This program was written on a Western Digital MICROENGINE with a
        TeleVideo 920C terminal.  As such some minor changes may have to
        be made to convert to other computers.  Specifically, page(output)
        doesn't clear the CRT for me, so I am forced to use the CLEARSCREEN
        routine.  Further, my printer is hooked to the serial port which
        is addressed as "#8" or "REMOTE:", and you will have to change all
        of the REMOTE:'s to whatever suits your installation.

Changed by gws to be compatable with H-19.  REMOTE: also changed to printer:



COPYRIGHT
---------

        This program is furnished to the USUS group for unrestricted
        personal or non-profit use.  Use of this program for commercial
        purposes is authorized with the following restrictions:

          1--> Prior notification to and acknowledgement by the author

          2--> A message similar to the one below appears on the screen
               upon execution and remains there until a key is hit.


*************************************************************************
*                                                                       *
*                                                                       *
*                                                                       *
*                                                                       *
*                                                                       *
*                  Program derived from BTREE.ADDRESS                   *
*                              written by                               *
*                             R.M. Wilson                               *
*                        Hi-Country Data Systems                        *
*                            P.O. Box 4258                              *
*                        Woodland Park, CO 80863                        *
*                                                                       *
*                                                                       *
*                                                                       *
*                                                                       *
*                                                                       *
*                                                                       *
*                                                                       *
*                                                                       *
*                                                                       *
*************************************************************************




}




{l #5:btree.list.text}

{$I BTREE.DCLR.TEXT}

{$I BTREE.STD.TEXT}

{$I BTREE.INIT.TEXT}

{$I BTREE.GET.TEXT}

{$I BTRE.FIND1.TEXT}

{$I BTRE.FIND2.TEXT}

{$I BTREE.DEL1.TEXT}

{$I BTREE.DEL2.TEXT}

{$I BTREE.PRNT.TEXT}

{$I BTREE.DOIT.TEXT}


begin  {MAIN PROGRAM} 
  CLEARSCREEN;
  TITLE; 
  INIT;
  CLEARSCREEN;
  reset(CONTROLFILE,CONTROL);
    {open control file and leave it open for ready access}
  get(CONTROLFILE);             {get the control file data}
  FILE_LEN:=CONTROLFILE^;       {get the control file data}
  write('Output to printer?  (y/n)  ');     {chose output device}
  if YES then reset(OUTFILE,'printer:')  {output device is printer}
  else reset(OUTFILE,'CONSOLE:');                   {output device is CRT}
  repeat
    writeln;
    write('Enter or Delete a node?  (E/D)  {Hit <ESC> to quit}  ');
    read(keyboard,CH);
    writeln;
    if CH in ['e','E'] then
      if FILE_LEN.PERSON_UNUSED<FILE_LEN.PERSON_MIN then DATA_FULL
      else KEY_INSERT
    else if CH in ['d','D'] then KEY_DELETE;
    writeln;
  until ord(CH)=27;  {chr(27) = esacpe}
  close(CONTROLFILE,lock);
  CLEARSCREEN                   {clear screen}
end.



========================================================================================
DOCUMENT :usus Folder:VOL10:btre.find1.text
========================================================================================

{************************************************************************
*                                                                       *
*  filed as BTRE.FIND1.TEXT          revised 31-May-82                  *
*                                                                       *
************************************************************************}


procedure SEARCH(INPUTKEY:FNAME;
                      A:integer;
                      var V:PERSON;
                      var FOUND,WRONG:boolean);
{************************************************************************
*                                                                       *
*  Search the b-tree for the key INPUTKEY starting at the root record   *
*  number A.  If it is found then print out the tree.  Otherwise in-    *
*  sert a new record with the key INPUTKEY and then print out the       *
*  b-tree.  If an item emerges to be passed to a lower level, then      *
*  assign it to V.  (In this case the tree must grow vertically and     *
*  NEW_HEIGHT is set to true.)                                          *
*                                                                       *
************************************************************************}
{label 1;} {can't have unused labels in IV.0 ! }
var   U:PERSON;                 {used to transfer a person record to INSERT}
      NEW_NODE,Z:PERSON_NODE;   {temporary/new PERSON_NODE}
      TEMP_KEY:FNAME;           {temporary key}
      A1,J,K,R,L,Q:integer;     {loop control variables}
      NEXT_NODE:integer;        {pointer to location of next "empty" node}

procedure INSERT;
{************************************************************************
*                                                                       *
*  This procedure actually does the inserting including splitting the   *
*  node if an overflow condition occurs.                                *
*                                                                       *
************************************************************************}
var  I:integer; {loop control variable}
begin   {insert U to the right of RECNUM DATA[R]}
  with PERSONS^ do begin
    if NODESIZE<MAX_NODE_SIZE then begin
      SPLIT:=false;             {node is not full}
      NODESIZE:=NODESIZE+1;     {we are adding a person to the node}
      NEW_HEIGHT:=false;        {b-tree is not gowing vertically}
      if DUPLICATE then begin   {insert a duplicate key}
        DUPLICATE:=false;
        DATA[NODESIZE]:=U
      end  {if DUPLICATE}
      else begin
        for I:=NODESIZE downto R+2 do DATA[I]:=DATA[I-1];
                                  {make room for new person}
        DATA[R+1]:=U              {insert new person into node}
      end  {else begin}
    end  {if PERSONS^.NODESIZE<MAX_NODE_SIZE}
    else begin
{************************************************************************
*                                                                       *
*  The node is already full and it must be split and the emerging       *
*  person assigned to V.  In order to accomplish this, different nodes  *
*  will have to be found and brought into memory, so the boolean        *
*  variable SPLIT is set to true as a "reminder" to get the current     *
*  PERSON_NODE/record later for additional operations on or with it.    *
*                                                                       *
************************************************************************}
      SPLIT:=true;              {will require new node}
      NEXT_NODE:=FILE_LEN.PERSON_AVAIL;
        {FILE_LEN.PERSON_AVAIL always points to the next "empty"
         PERSON_NODE in the file.}
      if not DUPLICATE then begin       {enter a unique key}
        if R<=MIN_NODE_SIZE then begin {insert U in "new" left node}
          if R=MIN_NODE_SIZE then V:=U
            {new person is being inserted in the middle of the node to be split}
          else begin
           {move old persons around so "new" nodes will not be <MIN_NODE_SIZE}
            V:=DATA[MIN_NODE_SIZE];
            for I:=MIN_NODE_SIZE downto R+2 do DATA[I]:=DATA[I-1];
            DATA[R+1]:=U
          end; {else begin}
          for I:=1 to MIN_NODE_SIZE do {copy person data to the new node}
            NEW_NODE.DATA[I]:=PERSONS^.DATA[I+MIN_NODE_SIZE]
        end  {if R<=MIN_NODE_SIZE}
        else  begin  {insert U in right "new" node}
          R:=R-MIN_NODE_SIZE;
          V:=DATA[MIN_NODE_SIZE+1];
          for I:=1 to R-1 do {move old persons around so new nodes will not be
                              smaller than MIN_NODE_SIZE}
            NEW_NODE.DATA[I]:=PERSONS^.DATA[I+MIN_NODE_SIZE+1];
          NEW_NODE.DATA[R]:=U;    {insert new person}
          for I:=R+1 to MIN_NODE_SIZE do  {copy person data to the new node}
            NEW_NODE.DATA[I]:=PERSONS^.DATA[I+MIN_NODE_SIZE]
        end; {else begin}
        NODESIZE:=MIN_NODE_SIZE; {original node size reduced}
        NEW_NODE.NODESIZE:=MIN_NODE_SIZE;
        NEW_NODE.P0:=V.SUCC_NODE; {set correct pointer to <successor node}
        V.SUCC_NODE:=NEXT_NODE;   {set correct pointer to >successor node}
      end  {if not DUPLICATE}
      else begin {node is full of duplicate keys so must start filling a
                  new node and link the full node to it}
        NEW_HEIGHT:=false;      {prevent action in procedure SEARCH}
        DUPLICATE:=false;       {reset flag/control variable}
        P0:=NEXT_NODE;          {link to latest node in linked list}
        NEW_NODE.DATA[1]:=U;    {fill first slot of empty node}
        NEW_NODE.P0:=-1;        {no additional duplicate key nodes (yet!)}
        NEW_NODE.NODESIZE:=1    {set correct node size}
      end  {else begin}
    end; {else begin}
  end; {with PERSONS^}
{************************************************************************
*                                                                       *
*  Although it seems sensible that a simple "put(PERSONS)" would work   *
*  correctly all by itself, unless all four lines below are used, only  *
*  the very first item added to the original root node is saved.        *
*  A "get" statement advances the file pointer to the next record       *
*  location.                                                            *
*                                                                       *
*************************************************************************}
  Z:=PERSONS^;                  {assign node to temp while seeking}
  seek(PERSONS,A);              {set window on node/record number A}
  write('.');                   {show user something is happending}
  PERSONS^:=Z;                  {"dispose" of temp}
  put(PERSONS);                 {write PERSON_NODE to disk}
  if SPLIT then begin   {find place to put NEW_NODE}
    seek(PERSONS,NEXT_NODE);    {set window to "empty" node location}
    write('.');                 {show user something is happending}
    get(PERSONS);               {fill file buffer}
    FILE_LEN.PERSON_AVAIL:=PERSONS^.P0;
      {remove node from linked list of available nodes and reset pointer
       to new head of the list}
    FILE_LEN.PERSON_UNUSED:=FILE_LEN.PERSON_UNUSED-1;
      {correct number of empty or unused nodes}
    seek(PERSONS,NEXT_NODE);    {reset window to "empty" node location}
    write('.');                 {show user something is happending}
    PERSONS^:=NEW_NODE;         {assign NEW_NODE to "disk variable"}
    put(PERSONS);               {write NEW_NODE to disk}
  end; {if SPLIT}
end; {INSERT}

function PERSON_FOUND(U:PERSON;K:integer):boolean;
{************************************************************************
*                                                                       *
*  Check to see if the correct person found.                            *
*                                                                       *
************************************************************************}
var   TEMP_KEY:FNAME;   {hold key if data is changed}
begin
  if FOUND then begin
    PERSON_FOUND:=false;
    exit(PERSON_FOUND)
  end; {if FOUND}
  PRINT_PERSON(U);      {display record in question}
  writeln;
  writeln;
  write('IS THIS THE CORRECT PERSON?  (y/n)  ');
  if YES then begin
    FOUND:=true;        {global found the correct person}
    PERSON_FOUND:=true;
    NEW_HEIGHT:=false;  {B-tree not growing}
    DUPLICATE:=false;   {reset flag/control variable}
    LEAVE:=true;        {we've found it so set exit flag}
    WRONG:=false;       {the inputed and inverted key wasn't wrong}
    V:=U;               {pass record back to original call of SEARCH}
    writeln;
    writeln;
    write('Is the customer data correct?');     {verify data}
    if not YES then begin       {data incorrect}
      TEMP_KEY:=V.KEY;          {save for comparing}
      PERSON_CHANGE(V);         {change it}
      if TEMP_KEY<>V.KEY then begin
          {key has changed so node must be moved to correct location}
        CLEARSCREEN;            {clear CRT}
        PRINTAT(0,8,'You changed the key so...');
        PERSONPTR:=U;           {save old node for deletion comparison}
        CHANGED:=true;          {set flag for deletion}
        WRONG:=true             {set flag for reinsertion}
      end  {if TEMP_KEY<>V.KEY}
      else if U<>V then begin
        PERSONS^.DATA[K]:=V;    {put corrected data into node}
        Z:=PERSONS^;            {hold node while seeking}
        seek(PERSONS,A);        {reset file window to location of node A}
        write('.');             {show user something is happending}
        PERSONS^:=Z;            {put corrected node into file buffer}
        put(PERSONS)            {write correct node onto disk}
      end  {else if U<>V}
    end  {if not YES}
  end  {if YES}
  else PERSON_FOUND:=false      {did not find person}
end; {PERSON_FOUND}





========================================================================================
DOCUMENT :usus Folder:VOL10:btre.find2.text
========================================================================================

{************************************************************************
*                                                                       *
*  filed as BTRE.FIND2.TEXT          revised 31-May-82                  *
*                                                                       *
************************************************************************}


procedure START_NEW_PERSON;
label 1;
begin
  GET_NEW_PERSON(V);      {get the data}
1:if V.KEY<>INPUTKEY then begin
{************************************************************************
*                                                                       *
*  This "if..then" statement allows user to catch errors in the data    *
*  inputed in regards to the key which will be used to fetch the data.  *
*  User can put in a special key which could not easily be discovered.  *
*  (i.e. if normal key = BJONES and user inputed FSMITH)                *
*                                                                       *
************************************************************************}
    CLEARSCREEN;
    gotoxy(0,11);
    writeln('The computed key does not match the input key.');
    writeln;
    writeln;
    writeln;
    writeln('Do you want to verify the data you inputed?  (y/n)  ');
    if YES then begin
      PRINT_PERSON(V);
      writeln;
      writeln;
      writeln('Is the above correct?  (y/n)  ');
      if not YES then PERSON_CHANGE(V);
      goto 1
    end; {if YES}
    writeln('Do you want the input key or the computed key?  (I/C)  ');
    writeln;
    writeln;
    writeln('INPUTKEY = ':25,FAKE_KEY);   {user inputed key}
    TEMP_KEY:=V.KEY;                      {protect V.KEY}
    INVERT_KEY(TEMP_KEY,2);               {convert to "user format"}
    writeln;
    write('COMPUTED KEY = ':25,TEMP_KEY); {display results}
    CH:=READKEY(['C','I','c','i']);       {"bomb proofing"}
    if CH in ['C','c'] then begin
       {location for the insertion was based on INPUTKEY so get back
        to where the process can be started all over again using the
        computed key}
      CLEARSCREEN;
      PRINTAT(0,8,'You changed the key so...');
      LEAVE:=true;        {set exit flag}
      WRONG:=true;        {user inputed key was wrong}
      NEW_HEIGHT:=false;  {prevent strange things from happening}
      FOUND:=true         {we found a place to insert the incorrect key}
    end  {if CH in}
    else V.KEY:=INPUTKEY; {use the user key}
  end  {if V.KEY<>INPUTKEY}
end; {START_NEW_PERSON}

begin {SEARCH}
{We search key INPUTKEY in the record number "A"...NEW_HEIGHT=false}
  if A=-1 then begin {item with key INPUTKEY not in b-tree}
    NEW_HEIGHT:=true;   {at this point NEW_HEIGHT only means something is to be
                         added or inserted into the b-tree}
    if FOUND then exit(SEARCH); {found new location for changed node}
    CLEARSCREEN;                {clear CRT}
    gotoxy(0,8);                {position cursor}
    writeln('Person <',FAKE_KEY,'> address file not found.');
    writeln;
    write('Is the key correct?  (y/n)  ');
    if YES then begin
      WRONG:=false;             {the key was correct}
      writeln;
      writeln;
      write('Start a new address file?  (y/n)  ');
      if YES then START_NEW_PERSON
      else begin  {don't start a new address file}
        LEAVE:=true;            {set flag to return to calling procedure ASAP}
        NEW_HEIGHT:=false;      {B-tree is not growing}
        FOUND:=true             {we found a place to put the correct key}
      end  {else begin}
    end  {if YES}
    else begin          {user inputed key incorrectly}
      WRONG:=true;      {key is incorrect}
      NEW_HEIGHT:=false;  {prevent strange things from happening}
      FOUND:=false;     {flag to get new key}
      LEAVE:=true       {set flag to return to calling procedure ASAP}
    end  {else begin}
  end  {if A=-1}
  else begin    {we have not reached a "null" or terminal node yet}
    seek(PERSONS,A);            {set the file window to the record to search}
    write('.');                 {show user something is happending}
    get(PERSONS);               {load the file buffer}
    with PERSONS^ do begin
      if DUPLICATE then begin   {check duplicate nodes}
        for J:=1 to NODESIZE do if PERSON_FOUND(DATA[J],J)
          then exit(SEARCH);    {we found it!}
        SEARCH(INPUTKEY,P0,V,FOUND,WRONG);      {not found...continue search}
        if LEAVE then exit(SEARCH);
            {if LEAVE=true then either the key is incorrect or user
             decided not to make an entry}
        if NEW_HEIGHT then begin
{************************************************************************
*                                                                       *
*  In the original program each recursive call of "SEARCH" was coded    *
*  so that the "person record" passed was "U" and not "V".  When the    *
*  code to handle changed nodes was added, it was necessary to pass     *
*  that changed node back down to the original calling procedure and    *
*  back up to the search and insert routines.                           *
*                                                                       *
*  The simplist method of achieving this was to modify all of the       *
*  recursive calls of "SEARCH" to pass "V" rather than "U".  However,   *
*  the "INSERT" procedure uses "U" to insert the new record.  Rather    *
*  than rewriting "INSERT" and suffering through all of the "joys" of   *
*  debugging that would surely result, I elected to simply add the      *
*  "U:=V" which is found below and prior to every other call of         *
*  "INSERT".                                                            *
*                                                                       *
************************************************************************}
          U:=V;
          INSERT     {insert new duplicate key}
        end  {if NEW_HEIGHT}
      end  {if DUPLICATE}
      else begin        {continue search for key}
        L:=1;           {set left limit}
        R:=NODESIZE;    {set right limit}
        repeat   {binary search for INPUTKEY}
          K:=(L+R) div 2;
          if INPUTKEY<=DATA[K].KEY then R:=K-1;         {reset right limit}
          if INPUTKEY>=DATA[K].KEY then L:=K+1;         {reset left limit}
        until R<L;
        if L-R>1 then begin {We found a key that matches}
          if PERSON_FOUND(DATA[K],K) then exit(SEARCH) {We found it!!}
          else begin            {we didn't find it}
            DUPLICATE:=true;    {set flag to check for possible duplicates}
            SEARCH(INPUTKEY,DATA[K].DUPE,V,FOUND,WRONG);
              {initiate search for duplicate keys}
            if NEW_HEIGHT then begin    {must enter first duplicate key}
              seek(PERSONS,FILE_LEN.PERSON_AVAIL);
                {set file window to head of linked list of available nodes}
              write('.');       {show user something is happending}
              get(PERSONS);     {load file buffer}
              I:=P0;            {save link information}
              NODESIZE:=0;      {initialize node}
              P0:=-1;           {initialize node}
              R:=MAX_NODE_SIZE+1;       {prevent unwanted action in INSERT}
              A1:=A;            {save primary key location}
              A:=FILE_LEN.PERSON_AVAIL; {initialize for INSERT}
              U:=V;             {for INSERT to function properly}
              INSERT;           {insert it (finally!)}
              A:=A1;            {restore primary key location}
              seek(PERSONS,A);  {reset file window to primary key node}
              write('.');       {show user something is happending}
              get(PERSONS);     {load file buffer}
              DATA[K].DUPE:=FILE_LEN.PERSON_AVAIL;
                {store location of duplicate key}
              Z:=PERSONS^;      {hold buffer data while seeking}
              seek(PERSONS,A);  {reset file window to primary key node}
              write('.');       {show user something is happending}
              PERSONS^:=Z;      {load file buffer}
              put(PERSONS);     {write file buffer to disk}
              FILE_LEN.PERSON_AVAIL:=I; {reset link list pointer to head node}
              FILE_LEN.PERSON_UNUSED:=FILE_LEN.PERSON_UNUSED-1
                {correct number of empty or unused nodes}
            end  {if NEW_HEIGHT}
          end  {else begin}
        end  {if L-R>1}
        else begin  {item is not in this b-tree node}
          if R=0 then Q:=P0     {if R=0 then INPUTKEY<any KEY in this node}
          else Q:=DATA[R].SUCC_NODE;  {INPUTKEY>DATA[R].KEY}
          SEARCH(INPUTKEY,Q,V,FOUND,WRONG);
            {search the appropriate successor node}
          if LEAVE then exit(SEARCH);
            {if LEAVE=true then either the key is incorrect or user
             decided not to make an entry}
{************************************************************************
*                                                                       *
*  The conditional statement and the included "seek" and "get" are the  *
*  elusive keys which make the SEARCH and INSERT procecures work        *
*  correctly.  It is essential that the window be reset to the value    *
*  after the recursive call, before INSERT is called.                   *
*                                                                       *
************************************************************************}
   {if SPLIT then record/node number A is not in file buffer,
   and both INSERT and KEY_INSERT reference that record/node}
          if SPLIT then begin   {if SPLIT then file window was moved}
            seek(PERSONS,A);    {reset file window}
            write('.');         {show user something is happending}
            get(PERSONS);       {load file buffer}
          end; {if SPLIT}
          if NEW_HEIGHT then begin
            U:=V;               {for INSERT to function properly}
            INSERT     {insert new unique key}
          end  {if NEW_HEIGHT}
        end  {else begin}
      end  {with PERSONS^}
    end  {else begin}
  end  {else begin}
end; {SEARCH}






========================================================================================
DOCUMENT :usus Folder:VOL10:btree.data
========================================================================================

< binary file -- not listed >
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                           
========================================================================================
DOCUMENT :usus Folder:VOL10:btree.dclr.text
========================================================================================

{************************************************************************
*                                                                       *
*  filed as BTREE.DCLR.TEXT           revised 27 November 1981          *
*                                                                       *
************************************************************************}

{label 1;}

const MAX_NODE_SIZE=4;                  {order of the B-TREE}
      MIN_NODE_SIZE=2;                  {MAX_NODE_SIZE div 2}
      MAX_PERS_NODES=20;                {number of nodes in data file}
{************************************************************************
*                                                                       *
*  For a more useful program, change the above as follows...            *
*                                                                       *
*       MAX_NODE_SIZE=8;                                                *
*       MIN_NODE_SIZE=4;                                                *
*       MAX_PERS_NODE=400;                                              *
*                                                                       *
*  That will allow up to 3200 names and addresses to be stored.         *
*                                                                       *
************************************************************************}
      CONTROL='BTREE.DATA';             {name of file management data}
      PERSON_FILE='PERSON.DATA';        {name of data file}

type  LNAME=string[20];         {last name}
      FNAME=string[10];         {first name}
      ADRS=string[30];          {line of address}
      ZIP=string[10];           {zip code}
      FONE=string[13];          {area code and phone number}
      ST=string[3];             {state}
      SETOFCHAR=set of char;    {for function READKEY}
      SIZENODE=0..MAX_NODE_SIZE;

      PERSON=packed record      {person informaton}
        SUCC_NODE:integer;      {pointer to "child" node}
        DUPE:integer;           {pointer to node with duplicate key(s)}
        KEY:FNAME;              {search key}
        FIRST:FNAME;            {first name}
        LAST:LNAME;             {last name}
        STREET:ADRS;            {street/apartment address}
        CITY:ADRS;
        ZIPCODE:ZIP;
        STATE:ST;
        PHONE:FONE
      end;

      PERSON_NODE=packed record  {b-tree node of "many" persons}
        NODESIZE:SIZENODE;
        P0:integer;  {pointer to successor node}
        DATA:packed array[1..MAX_NODE_SIZE] of PERSON;
           {array of person records}
      end;

      CONTROLDATA=packed record {file management data}
        PERSON_AVAIL:integer;    {pointer to empty node}
        PERSON_ROOT:integer;     {pointer to root PERSON_NODE}
        PERSON_UNUSED:integer;   {how many nodes are unused}
        PERSON_MIN:integer;      {minimum required for insertion}
      end;

      PERSFILE=file of PERSON_NODE;      {person b-tree}
      CONTFILE=file of CONTROLDATA;      {file management data}

var   I,J,K,N:integer;          {loop variables}
      OUTFILE:interactive;      {to change output device from CRT to printer}
      FAKE_KEY:FNAME;           {what user thinks the key is}
      REAL_KEY:FNAME;           {the actual key}
      LEAVE:boolean;            {to control program exit from segments}
      DUPLICATE:boolean;        {indicates there is a duplicate key}
      CHANGED:boolean;          {indicates retrieved record modified}
      NEW_HEIGHT:boolean;       {indicates that tree must grow or shrink}
      SPLIT:boolean;            {indicates if node is split}
      CH,AN:char;               {used for primarily for option selection}
      FILE_LEN:CONTROLDATA;     {file management data}
      CONTROLFILE:CONTFILE;     {file management data}
      PERSONPTR:PERSON;         {dynamic pointer to a single person record}
      PERSONS:PERSFILE;         {person b-tree}






========================================================================================
DOCUMENT :usus Folder:VOL10:btree.del1.text
========================================================================================

{************************************************************************
*                                                                       *
*  filed as BTREE.DEL1.TEXT             revised 31-May-82               *
*                                                                       *
************************************************************************}


procedure DELETE(INPUTKEY:FNAME;
                      A:integer;
                      var FOUND,WRONG:boolean);
{************************************************************************
*                                                                       *
*  Search and delete INPUTKEY in the b-tree node/record number A.  If   *
*  the deletion cause an underflow (i.e. NODESIZE<MIN_NODE_SIZE) then   *
*  balance with adjacent page if possible, otherwise MERGE.             *
*                                                                       *
*       NEW_HEIGHT = NODESIZE<MIN_NODE_SIZE                             *
*                                                                       *
*************************************************************************}
var   U:PERSON;                         {not required?}
      NEW_NODE:PERSON_NODE;             {not required?}
      Z,TEMP:PERSON_NODE;               {hold node temporarily}
      M,A1,I,J,K,R,L,Q:integer;         {loop control variables}

procedure UNDERFLOW(C,A,S:integer);
{A=underflow node/record number and C=parent node/record number}
var   TOO_SMALL:PERSON_NODE;    {underflow node}
      PARENT:PERSON_NODE;       {parent of underflow node}
      ADJACENT_NODE:PERSON_NODE;{adjacent node}
      B,I,K:integer;            {loop control variables}
      ADJ_SIZE:integer;    {number of person in ADJACENT_NODE}
      PARENT_SIZE:integer;      {number of person in PARENT_NODE}

procedure UNDER1;
begin
  S:=S+1;                     {determine ADJACENT_NODE record number}
  B:=PARENT.DATA[S].SUCC_NODE;{determine ADJACENT_NODE record number}
  seek(PERSONS,B);    {set the file window on the adjacent node}
  write('.');         {show user something is happening}
  get(PERSONS);       {load the file buffer}
  ADJACENT_NODE:=PERSONS^;   {assign adjacent node to working variable}
  ADJ_SIZE:=ADJACENT_NODE.NODESIZE;    {assign to working variable}
  K:=(ADJ_SIZE-MIN_NODE_SIZE+1) div 2;
    {K=no. of items available on adjacent node}
  TOO_SMALL.DATA[MIN_NODE_SIZE]:=PARENT.DATA[S];
    {increase number of persons in TOO_SMALL}
  TOO_SMALL.DATA[MIN_NODE_SIZE].SUCC_NODE:=ADJACENT_NODE.P0;
    {set proper successor node for person added to TOO_SMALL}
  if K>0 then begin  {move K items from ADJACENT_NODE to TOO_SMALL}
    for I:=1 to K-1 do
      TOO_SMALL.DATA[I+MIN_NODE_SIZE]:=ADJACENT_NODE.DATA[I];
    PARENT.DATA[S]:=ADJACENT_NODE.DATA[K];
      {add "new" person to parent to replace deleted person}
    PARENT.DATA[S].SUCC_NODE:=B;
      {set "new" person successor node to correct record number}
    ADJACENT_NODE.P0:=ADJACENT_NODE.DATA[K].SUCC_NODE;
      {set correct lessor successor node to correct record number}
    ADJ_SIZE:=ADJ_SIZE-K;
      {adjust for persons transferred to TOO_SMALL}
    for I:=1 to ADJ_SIZE do {"close-up" gap left by transfer}
      ADJACENT_NODE.DATA[I]:=ADJACENT_NODE.DATA[I+K];
    ADJACENT_NODE.NODESIZE:=ADJ_SIZE;
      {adjust for persons transferred to TOO_SMALL}
    TOO_SMALL.NODESIZE:=MIN_NODE_SIZE-1+K;
      {adjust for persons transferred to TOO_SMALL}
    NEW_HEIGHT:=false;        {b-tree is not shrinking vertically}
    seek(PERSONS,B);          {set file window to ADJACENT_NODE}
    write('.');               {show user something is happening}
    PERSONS^:=ADJACENT_NODE;  {assign to "disk variable"}
    put(PERSONS)              {write revised node to disk}
  end  {if K>0}
  else begin  {merge nodes TOO_SMALL and ADJACENT_NODE}
    for I:=1 to MIN_NODE_SIZE do
     {transfer to TOO_SMALL until it is the maximum size}
      TOO_SMALL.DATA[I+MIN_NODE_SIZE]:=ADJACENT_NODE.DATA[I];
    for I:=S to PARENT_SIZE-1 do PARENT.DATA[I]:=PARENT.DATA[I+1];
      {"Krunch" PARENT_NODE}
    TOO_SMALL.NODESIZE:=MAX_NODE_SIZE;
      {adjust for transfer from ADJACENT_NODE}
    PARENT.NODESIZE:=PARENT_SIZE-1; {dispose(ADJACENT_NODE)}
    seek(PERSONS,B);            {set file window to node being deleted}
    write('.');                 {show user something is happening}
    ADJACENT.P0:=FILE_LEN.PERSON_AVAIL; {link node to available list}
    PERSONS^:=ADJACENT;         {load file buffer}
    put(PERSONS);               {write buffer to disk}
    FILE_LEN.PERSON_AVAIL:=B;   {reset pointer to head of linked list}
    FILE_LEN.PERSON_UNUSED:=FILE_LEN.PERSON_UNUSED+1;
      {correct number of empty or unused nodes}
    NEW_HEIGHT:=PARENT.NODESIZE<MIN_NODE_SIZE
      {if PARENT.NODESIZE<MIN_NODE_SIZE then b-tree is shrinking vertically}
  end; {else begin}
  seek(PERSONS,A);            {set file window to underflow node}
  write('.');                 {show user something is happening}
  PERSONS^:=TOO_SMALL;        {assign to "disk variable"}
  put(PERSONS)                {write revised underflow node to disk}
end; {UNDER1}

begin {UNDERFLOW}
  seek(PERSONS,C);      {set the file window on the parent node}
  write('.');           {show user something is happening}
  get(PERSONS);         {load the file buffer}
  PARENT:=PERSONS^;     {assign parent node to working variable}
  seek(PERSONS,A);      {set the file window on underflow node}
  write('.');           {show user something is happening}
  get(PERSONS);         {load the file buffer}
  TOO_SMALL:=PERSONS^;  {assign underflow node to working variable}
  PARENT_SIZE:=PARENT.NODESIZE;         {assign to working variable}
    {NEW_HEIGHT=true, TOO_SMALL.NODESIZE=MIN_NODE_SIZE-1}
  if S<PARENT_SIZE then UNDER1 {ADJACENT_NODE:=node to the right of TOO_SMALL}
  else begin                   {ADJACENT_NODE:=node to the left of TOO_SMALL}
    if S=1 then B:=PARENT.P0            {determine ADJACENT_NODE record #}
    else B:=PARENT.DATA[S-1].SUCC_NODE; {determine ADJACENT_NODE record #}
    seek(PERSONS,B);            {set the window on the adjacent node}
    write('.');                 {show user something is happening}
    get(PERSONS);               {load the file buffer}
    ADJACENT_NODE:=PERSONS^;    {assign adjacent node to a working variable}
    ADJ_SIZE:=ADJACENT_NODE.NODESIZE+1;     {assign to a working variable}
    K:=(ADJ_SIZE-MIN_NODE_SIZE) div 2;
      {K=no. of items available on adjacent node}
    if K>0 then begin  {move K items from node ADJACENT_NODE to TOO_SMALL}
      for I:=MIN_NODE_SIZE-1 downto 1 do  {"Krunch" TOO_SMALL}
        TOO_SMALL.DATA[I+K]:=TOO_SMALL.DATA[I];
      TOO_SMALL.DATA[K]:=PARENT.DATA[S];
        {add "new" person to replace deleted person}
      TOO_SMALL.DATA[K].SUCC_NODE:=TOO_SMALL.P0;
        {set correct successor node to correct record number}
      ADJ_SIZE:=ADJ_SIZE-K;
        {adjust for persons transferred to TOO_SMALL}
      for I:=K-1 downto 1 do  {transfer to K persons TOO_SMALL}
        TOO_SMALL.DATA[I]:=ADJACENT_NODE.DATA[I+ADJ_SIZE];
      TOO_SMALL.P0:=ADJACENT_NODE.DATA[ADJ_SIZE].SUCC_NODE;
        {set correct lessor successor node to correct record number}
      PARENT.DATA[S]:=ADJACENT_NODE.DATA[ADJ_SIZE];
        {transfer replacement person to PARENT}
      PARENT.DATA[S].SUCC_NODE:=A;
        {set correct successor node to correct record number}
      ADJACENT_NODE.NODESIZE:=ADJ_SIZE-1;
        {adjust for persons transferred to TOO_SMALL}
      TOO_SMALL.NODESIZE:=MIN_NODE_SIZE-1+K;
        {adjust for persons transferred to TOO_SMALL}
      NEW_HEIGHT:=false;        {b-tree is not shrinking vertically}
      seek(PERSONS,A);          {set file window to underflow node}
      write('.');               {show user something is happening}
      PERSONS^:=TOO_SMALL;      {assign to a "disk variable"}
      put(PERSONS)              {write revised underflow node to disk}
    end {if K>0}
    else begin  {merge nodes TOO_SMALL and ADJACENT_NODE}
      ADJACENT_NODE.DATA[ADJ_SIZE]:=PARENT.DATA[S];
        {transfer replacement person to adjacent node}
      ADJACENT_NODE.DATA[ADJ_SIZE].SUCC_NODE:=TOO_SMALL.P0;
        {set correct successor node to correct record number}
      for I:=1 to MIN_NODE_SIZE-1 do  {transfer persons to ADJACENT_NODE}
        ADJACENT_NODE.DATA[I+ADJ_SIZE]:=TOO_SMALL.DATA[I];
      ADJACENT_NODE.NODESIZE:=MAX_NODE_SIZE;
        {adjust for persons transferred from TOO_SMALL}
      PARENT.NODESIZE:=PARENT_SIZE-1; {dispose(TOO_SMALL)}
      seek(PERSONS,A);          {set file window to node begin deleted}
      write('.');               {show user something is happening}
      TOO_SMALL.P0:=FILE_LEN.PERSON_AVAIL; {link to list of available nodes}
      PERSONS^:=TOO_SMALL;      {load file buffer}
      put(PERSONS);             {write buffer to disk}
      FILE_LEN.PERSON_AVAIL:=A; {reset pointer to new head of linked list}
      FILE_LEN.PERSON_UNUSED:=FILE_LEN.PERSON_UNUSED+1;
        {correct number of empty or unused nodes}
      NEW_HEIGHT:=PARENT.NODESIZE<MIN_NODE_SIZE
        {if NODESIZE<MIN_NODE_SIZE then b-tree is shrinking vertically}
    end; {else begin}
    seek(PERSONS,B);            {set file window to adjacent node}
    write('.');                 {show user something is happening}
    PERSONS^:=ADJACENT_NODE;    {assign to a "disk variable"}
    put(PERSONS)                {write revised adjacent node to disk}
  end;
  seek(PERSONS,C);              {set file window to parent node}
  write('.');                   {show user something is happening}
  PERSONS^:=PARENT;             {assign to a "disk variable"}
  put(PERSONS)                  {write revised parent node to disk}
end; {UNDERFLOW}




========================================================================================
DOCUMENT :usus Folder:VOL10:btree.del2.text
========================================================================================

{************************************************************************
*                                                                       *
*  This is filed as BTREE.DEL2.TEXT         revised 31-May-82           *
*                                                                       *
************************************************************************}

procedure DEL(P:integer);
{************************************************************************
*                                                                       *
*  This procedure finds the terminal, successor node to node A in       *
*  DELETE.  Its recursive nature also ensures that the path from A      *
*  to that terminal node is kept in memory so that any merging or       *
*  transfer of a "person" from a successor node to a superior node      *
*  can be accomplished.                                                 *
*                                                                       *
************************************************************************}
var   Q:integer;  {global A,K}
      Z,W:PERSON_NODE;  {temporary nodes while seeking}
begin
  seek(PERSONS,P);              {set the file window to P node}
  write('.');                   {show user something is happening}
  get(PERSONS);                 {load file buffer}
  Q:=PERSONS^.DATA[PERSONS^.NODESIZE].SUCC_NODE;
  if Q<>-1 then begin           {P is not a terminal node}
    DEL(Q);                     {continue looking for terminal node}
    seek(PERSONS,P);            {reset the file window to P node}
    write('.');                 {show user something is happening}
    get(PERSONS);               {load file buffer}
    if NEW_HEIGHT then begin
      UNDERFLOW(P,Q,PERSONS^.NODESIZE);  {correct the underflow}
      seek(PERSONS,P);          {reset the file window to P node}
    write('.');                 {show user something is happening}
      get(PERSONS)              {load the file buffer}
    end  {if NEW_HEIGHT}
  end {if Q<>-1}
  else begin
    Z:=PERSONS^;                {hold while seeking}
    seek(PERSONS,A);            {set the file window to A node}
    write('.');                 {show user something is happening}
    get(PERSONS);               {load the file buffer}
    W:=PERSONS^;                {hold while seeking}
    Z.DATA[Z.NODESIZE].SUCC_NODE:=W.DATA[K].SUCC_NODE;
      {set correct successor node to correct record number}
    W.DATA[K]:=Z.DATA[Z.NODESIZE];
      {transfer person}
    Z.NODESIZE:=Z.NODESIZE-1;
      {adjust for deletion}
    if DUPLICATE then NEW_HEIGHT:=Z.NODESIZE<1  {not required?}
      {if Z.NODESIZE<1 then b-tree is shrinking horizontally}
    else NEW_HEIGHT:=Z.NODESIZE<MIN_NODE_SIZE;
      {if Z.NODESIZE<MIN_NODE_SIZE then b-tree is shrinking vertically}
    seek(PERSONS,A);            {set the file window to A node}
    write('.');                 {show user something is happening}
    PERSONS^:=W;                {assign to a "disk variable"}
    put(PERSONS);               {write revised A node to disk}
    seek(PERSONS,P);            {set the file window to P node}
    write('.');                 {show user something is happening}
    PERSONS^:=Z;                {assign to a "disk variable"}
    put(PERSONS)                {write revised P node to disk}
  end {else begin}
end; {DEL}

function PERSON_FOUND(U:PERSON;K:integer):boolean;
{************************************************************************
*                                                                       *
*  This procedure displays a record with the correct key and ask if     *
*  the record/person is the correct one.  If so then it asks if the     *
*  record/person should be deleted.                                     *
*                                                                       *
************************************************************************}
begin
  if FOUND then begin
    if U=PERSONPTR then PERSON_FOUND:=true
    else PERSON_FOUND:=false;
    exit(PERSON_FOUND)
  end; {if FOUND}
  PRINT_PERSON(U);      {display record in question}
  writeln;
  writeln;
  write('IS THIS THE CORRECT PERSON?  (y/n)  ');
  if YES then begin
    NEW_HEIGHT:=false;  {make sure nothing strange happens if flag set
                         accidently}
    DUPLICATE:=false;   {reset flag/control variable}
    WRONG:=false;       {key was correct}
    writeln;
    writeln;
    write('Delete this record?  ');
    if YES then PERSON_FOUND:=true      {set deletion flag}
    else PERSON_FOUND:=false            {don't delete it}
  end  {if YES}
  else PERSON_FOUND:=false              {wrong person}
end; {PERSON_FOUND}

procedure KRUNCH(B:integer;     {pointer to location of node in file buffer}
                 J:integer      {pointer to slot in node last transfered});
{************************************************************************
*                                                                       *
*  This procedure maintains the linked list structure of the nodes      *
*  which contain duplicate keys.  When ever a duplicate key is deleted, *
*  the lisk is krunched to reduce disk storage requirements.   For      *
*  the rationale of using this structure, see introductory notes.       *
*                                                                       *
************************************************************************}
var   I,M:integer;              {loop control and node location variables}
      Y,W:PERSON_NODE;          {hold nodes while seeking}
begin
  with PERSONS^ do begin
    NODESIZE:=NODESIZE-1;       {set NODESIZE  to correct value}
    if NODESIZE>0 then begin    {we must krunch node}
      for I:=J to NODESIZE do DATA[I]:=DATA[I+1];       {krunch node}
      if P0>-1 then begin       {there are additional duplicate nodes}
        W:=PERSONS^;            {hold while seeking}
        seek(PERSONS,P0);       {set file window to next duplicate node}
        write('.');             {show user something is happening}
        get(PERSONS);           {load file buffer}
        M:=1;                   {initialize to slot to transfer from}
        I:=W.NODESIZE+1;        {initialize to slot to transfer into}
        repeat
          W.DATA[I]:=DATA[M];   {transfer}
          I:=I+1;               {increment}
          M:=M+1;               {increment}
        until (I>MAX_NODE_SIZE) or (M>NODESIZE);
          {I should >MAX_NODE_SIZE at the same time as M>NODESIZE.
           This allows for successful krunching of two records
           which some how require the transfer of more than one data slot}
        W.NODESIZE:=I-1;        {set to correct value}
        Y:=PERSONS^;            {hold while seeking}
        seek(PERSONS,B);        {reset file window to location of "W" node}
        write('.');             {show user something is happening}
        I:=W.P0;                {save location of "Y" node}
        if Y.NODESIZE=1 then begin      {"Y" node must be deleted}
          W.P0:=-1;             {set flag to indicate no more duplicate nodes}
          DUPLICATE:=false      {reset flag/control variable}
        end;  {if Y.NODESIZE}
        PERSONS^:=W;            {load file buffer}
        put(PERSONS);           {write buffer to disk}
        PERSONS^:=Y;            {load file buffer}
        KRUNCH(I,M-1);          {continue KRUNCH process}
        NEW_HEIGHT:=false       {prevent action upon return to DELETE}
      end  {if P0>-1}
      else begin        {there are no additional duplicate nodes}
        W:=PERSONS^;            {hold whild seeking}
        seek(PERSONS,B);        {reset file window to "W" node}
        write('.');             {show user something is happening}
        PERSONS^:=W;            {load file buffer}
        put(PERSONS);           {write buffer to disk}
      end  {else begin}
    end  {if NODESIZE>0}
    else begin          {delete node number B}
      LEAVE:=true;
      NEW_HEIGHT:=true;         {set flag for action in DELETE}
      Y:=PERSONS^;              {save buffer while seeking}
      Y.P0:=FILE_LEN.PERSON_AVAIL;
        {link node number B into available node list}
      FILE_LEN.PERSON_AVAIL:=B; {reset pointer to new head node}
      FILE_LEN.PERSON_UNUSED:=FILE_LEN.PERSON_UNUSED+1;
        {correct total of empty or unused nodes}
      seek(PERSONS,B);          {reset file window to node number B}
      write('.');               {show user something is happening}
      PERSONS^:=Y;              {load file buffer}
      put(PERSONS);             {write file buffer to disk}
    end  {else begin}
  end  {with PERSONS^}
end; {KRUNCH}

begin  {DELETE}
{We search for key INPUTKEY in the record number "A"...NEW_HEIGHT=false}
  if A=-1 then begin {person is not in b-tree}
    NEW_HEIGHT:=false;  {nothing to delete so b-tree can not shrink}
    CLEARSCREEN;
    gotoxy(0,8);
    writeln(OUTFILE,'Person <',FAKE_KEY,'> not found.');
    writeln;
    write('Is the key correct?  (y/n)  ');
    if not YES then WRONG:=true;        {set flag to get new key}
    LEAVE:=true                         {set flag to exit delete}
  end  {if A=-1}
  else begin
    seek(PERSONS,A);            {set the file window to the record to search}
    write('.');                 {show user something is happening}
    get(PERSONS);               {load the file buffer}
    with PERSONS^ do begin
      if DUPLICATE then begin   {search duplicate node for match}
        for J:=1 to NODESIZE do if PERSON_FOUND(DATA[J],J) then begin
          KRUNCH(A,J);          {delete person}
          if LEAVE then exit(DELETE);
            {exit to prevent last four lines of DELETE from executing}
        end; {if PERSON_FOUND};
        DELETE(INPUTKEY,P0,FOUND,WRONG); {continue searching duplicate nodes}
        if LEAVE then exit(DELETE)
          {prevent the last four lines from executing}
      end  {if DUPLICATE}
      else begin
        L:=1;                   {set left pointer for binary search}
        R:=NODESIZE;            {set right pointer for binary search}
        repeat   {binary array search}
          K:=(L+R) div 2;       {compute mid point}
          if INPUTKEY<=DATA[K].KEY then R:=K-1; {set right limit}
          if INPUTKEY>=DATA[K].KEY then L:=K+1; {set left limit}
        until L>R;
        {next 2 lines determine which node to search next to find either
         INPUTKEY or the successor terminal node to the node where INPUTKEY
         was found}
        if R=0 then Q:=P0
        else Q:=DATA[R].SUCC_NODE;
        if L-R>1 then begin {we found a candidate for deletion}
          if PERSON_FOUND(DATA[K],K) then begin {delete it!!}
            if DATA[K].DUPE=-1 then begin       {there are no duplicate keys}
              if Q=-1 then begin {A is a terminal node}
                NODESIZE:=NODESIZE-1;   {correct nodesize}
                NEW_HEIGHT:=NODESIZE<MIN_NODE_SIZE;
                  {determine if underflow contition exists}
                for I:=K to NODESIZE do DATA[I]:=DATA[I+1];
                  {delete by krunching node}
              end {if Q=-1}
              else begin
                DEL(Q);       {find A's terminal, successor node}
                seek(PERSONS,A);      {reset the file window to the A node}
                write('.');           {show user something is happening}
                get(PERSONS);         {load the file buffer}
                if NEW_HEIGHT then begin        {underflow condition exists}
                  UNDERFLOW(A,Q,R);             {correct it}
                  seek(PERSONS,A);    {reset the file window to the A node}
                  write('.');         {show user something is happening}
                  get(PERSONS)        {load the file buffer}
                end  {if NEW_HEIGHT}
              end {else begin}
            end  {if DATA[K].DUPE=-1}
            else begin                  {duplicate nodes exist}
              Z:=PERSONS^;              {hold while seeking}
              M:=DATA[K].DUPE;          {save duplicate node location}
              seek(PERSONS,M);          {set file window to duplicate node}
              write('.');               {show user something is happening}
              get(PERSONS);             {load file buffer}
              Z.DATA[K]:=DATA[1];
                {replace original key with duplicate}
              if NODESIZE>1 then Z.DATA[K].DUPE:=M
                {more duplicates exist so set pointer to correct value}
              else Z.DATA[K].DUPE:=-1;
                {no other duplicates exist so set pointer to nul or nil}
              KRUNCH(M,1); {KRUNCH the duplicate node}
              seek(PERSONS,A);          {reset file window to node number "A"}
              write('.');               {show user something is happening}
              PERSONS^:=Z;              {load file buffer}
              put(PERSONS);             {write file buffer to disk}
              if LEAVE then exit(DELETE);
                {prevent last four lines from executing}
            end  {else begin}
          end  {if PERSON_FOUND}
          else begin    {not found}
            if DATA[K].DUPE>-1 then begin       {duplicate keys exist}
              DUPLICATE:=true;
                {set flag to initiate search for duplicate keys}
              DELETE(INPUTKEY,DATA[K].DUPE,FOUND,WRONG);
                {search for duplicate keys}
              if NEW_HEIGHT then begin   {set node "A" duplicate link to nil}
                seek(PERSONS,A);      {reset file window to node "A"}
                write('.');           {show user something is happening}
                get(PERSONS);         {load file buffer}
                DATA[K].DUPE:=-1;     {set duplicate link to nul or nil}
                Z:=PERSONS^;          {hold while seeking}
                seek(PERSONS,A);      {reset file window to node "A"}
                write('.');           {show user something is happening}
                put(PERSONS);         {write file buffer to disk}
                NEW_HEIGHT:=false     {reset flag}
              end; {if NEW_HEIGHT}
              if LEAVE then exit(DELETE)
{************************************************************************
*                                                                       *
*  If LEAVE=true then either the deletion was successful and the exit   *
*  is to prevent the last four lines of this procedure from executing,  *
*  or the user decided not to delete the record, or the key the user    *
*  inputed was incorrect.                                               *
*                                                                       *
************************************************************************}
            end  {if DATA[K].DUPE>-1}
          end  {else begin}
        end {if L-R>1}
        else begin        {haven't found INPUTKEY so must keep searching}
          DELETE(INPUTKEY,Q,FOUND,WRONG);
          if LEAVE then exit(DELETE);
          seek(PERSONS,A);        {reset the file window to the A node}
          write('.');             {show user something is happening}
          get(PERSONS);           {load the file buffer}
          if NEW_HEIGHT then begin  {underflow condition exists}
            UNDERFLOW(A,Q,R);     {correct it}
            seek(PERSONS,A);      {reset the file window to the A node}
            write('.');           {show user something is happening}
            get(PERSONS)          {load the file buffer}
          end  {if NEW_HEIGHT}
        end {else begin}
      end  {else begin}
    end; {with PERSONS^ do}
    TEMP:=PERSONS^;             {hold while seeking}
    seek(PERSONS,A);            {reset the file window to the A node}
    write('.');                 {show user something is happening}
    PERSONS^:=TEMP;             {assign to a "disk variable"}
    put(PERSONS)                {write revised A node to the disk}
  end  {else begin}
end; {DELETE}






========================================================================================
DOCUMENT :usus Folder:VOL10:btree.doit.text
========================================================================================

{************************************************************************
*                                                                       *
*  filed as BTREE.DOIT.TEXT              revised 31-May-82              *
*                                                                       *
************************************************************************}



procedure KEY_INSERT;
{************************************************************************
*                                                                       *
*  This procedure controls the retrival or correction of existing       *
*  records and/or the addition of new records.                          *
*                                                                       *
************************************************************************}
label 1;
var   INPUTKEY:string;          {search key}
      FOUND,WRONG:boolean;      {insertion control variables}
      U:PERSON;                 {for adding new root}
      I,J,Q:integer;            {loop control variables}
      OLDPERS,NEWPERS:PERSON_NODE;
        {OLDPERS for deleteing old root due to changed key}
        {NEWPERS for adding new root due to insertion}
begin
  REAL_KEY:='          ';       {initialize}
  reset(PERSONS,PERSON_FILE);   {open data file}
1:SPLIT:=false;                 {initialize}
  (*writeln(OUTFILE,'ROOT = ',FILE_LEN.PERSON_ROOT);
  writeln(OUTFILE,'AVAIL = ',FILE_LEN.PERSON_AVAIL);*)
  CHANGED:=false;               {initialize}
  DUPLICATE:=false;             {initialize}
  WRONG:=false;                 {initialize}
  FOUND:=false;                 {initialize}
  LEAVE:=false;                 {initialize}
  repeat
    write('Enter KEY to find/insert:  ');
    readln(INPUTKEY);             {get search key}
  until GOOD_STRING(INPUTKEY);
    {prevent meaningless keys}
  J:=length(INPUTKEY);
  if J>10 then J:=10;
  REAL_KEY:=copy(INPUTKEY,1,J);
  UPPERCASE(REAL_KEY);          {convert to uppercase}
  FAKE_KEY:=REAL_KEY;           {save INPUTKEY for display purposes}
  INVERT_KEY(REAL_KEY,1);       {convert to correct format}
  (*writeln(OUTFILE,'SEARCH KEY ',INPUTKEY);      {display user key}
  writeln(OUTFILE,'REAL SEARCH KEY ',REAL_KEY); {display real key}*)
  write('Searching for <',FAKE_KEY,'>');
  SEARCH(REAL_KEY,FILE_LEN.PERSON_ROOT,U,FOUND,WRONG);
     {find/insert search key}
  if WRONG then begin  {inputed key incorrect or key changed in SEARCH}
    if FOUND then begin         {key changed in SEARCH}
      SPLIT:=false;                     {re-initialize}
      DUPLICATE:=false;                 {re-initialize}
      LEAVE:=false;                     {re-initialize}
      WRONG:=false;                     {re-initialize}
      U.SUCC_NODE:=-1;                  {initialize}
      U.DUPE:=-1;                       {initialize}
      (*writeln('Person "U" equals...');
      writeln;
      writeln;
      PRINT_PERSON(U);
      writeln;
      writeln;
      writeln('U.KEY = "',U.KEY,'"');
      writeln(OUTFILE,'ROOT = ',FILE_LEN.PERSON_ROOT);
      write(OUTFILE,'AVAIL = ',FILE_LEN.PERSON_AVAIL);
      readln; *)
      writeln;
      writeln;
      write('Inserting record into new location');
      SEARCH(U.KEY,FILE_LEN.PERSON_ROOT,U,FOUND,WRONG);
      if NEW_HEIGHT then begin      {insert new base node}
        Q:=FILE_LEN.PERSON_ROOT;    {pointer to old root node}
        with NEWPERS do begin       {initialize new root node}
          NODESIZE:=1;              {any new root node only has one person}
          P0:=Q;                    {initialize lessor successor pointer}
          DATA[1]:=U;               {add person to new root node}
        end; {with NEWPERS}
        seek(PERSONS,FILE_LEN.PERSON_AVAIL);
          {set file window to next "empty" node locaton}
        write('.');                 {show user something is happening}
        get(PERSONS);               {load file buffer}
        J:=PERSONS^.P0;             {save location of next node in linked list}
        seek(PERSONS,FILE_LEN.PERSON_AVAIL);
          {set file window to first available empty node}
        write('.');                 {show user something is happening}
        PERSONS^:=NEWPERS;          {assign to a "disk variable"}
        put(PERSONS);               {write new root node to disk}
        FILE_LEN.PERSON_ROOT:=FILE_LEN.PERSON_AVAIL;
          {update root node pointer}
        FILE_LEN.PERSON_AVAIL:=J;
          {reset pointer to new head node of linked list}
        FILE_LEN.PERSON_UNUSED:=FILE_LEN.PERSON_UNUSED-1;
          {correct number of empty or unused nodes}
      end; {if NEW_HEIGHT}
      if CHANGED then begin
        SPLIT:=false;                     {re-initialize}
        DUPLICATE:=false;                 {re-initialize}
        LEAVE:=false;                     {re-initialize}
        WRONG:=false;                     {re-initialize}
        writeln;
        writeln;
        write('Deleting record from previous location');
        FOUND:=true;
        DELETE(PERSONPTR.KEY,FILE_LEN.PERSON_ROOT,FOUND,WRONG);
        if NEW_HEIGHT then begin      {root node size was reduced}
          seek(PERSONS,FILE_LEN.PERSON_ROOT); {set file window to root node}
          write('.');                 {show user something is happening}
          get(PERSONS);                        {load file buffer}
          J:=FILE_LEN.PERSON_ROOT;    {save location of root node}
          if PERSONS^.NODESIZE=0 then begin   {must reset root pointer}
            FILE_LEN.PERSON_ROOT:=PERSONS^.P0;
              {if PERSONS^.NODESIZE=0 then the root node is empty so reset
               the root to the old root lessor successor}
            PERSONS^.P0:=FILE_LEN.PERSON_AVAIL;
              {link old root node to the linked list of available nodes}
            FILE_LEN.PERSON_AVAIL:=J;
              {reset pointer to linked list of available nodes}
            FILE_LEN.PERSON_UNUSED:=FILE_LEN.PERSON_UNUSED+1;
              {correct number of empty or unused nodes}
          end; {if PERSONS^.NODESIZE=0}
          OLDPERS:=PERSONS^;          {hold while seeking}
          seek(PERSONS,J);            {set file window to old root node}
          write('.');                 {show user something is happening}
          PERSONS^:=OLDPERS;          {load file buffer}
          NEW_HEIGHT:=false;          {prevent unwanted action}
          put(PERSONS)                {write file buffer to disk}
        end  {if NEW_HEIGHT}
      end  {if CHANGED}
    end  {if FOUND}
    else begin
      writeln;
      writeln;
      goto 1
    end  {else begin}
  end; {if WRONG}
  if NEW_HEIGHT then begin      {insert new base node}
    Q:=FILE_LEN.PERSON_ROOT;    {pointer to old root node}
    with NEWPERS do begin       {initialize new root node}
      NODESIZE:=1;              {any new root node only has one person}
      P0:=Q;                    {initialize lessor successor pointer}
      DATA[1]:=U;               {add person to new root node}
    end; {with NEWPERS}
    seek(PERSONS,FILE_LEN.PERSON_AVAIL);
      {set file window to next "empty" node locaton}
    write('.');                 {show user something is happening}
    get(PERSONS);               {load file buffer}
    J:=PERSONS^.P0;             {save location of next node in linked list}
    seek(PERSONS,FILE_LEN.PERSON_AVAIL);
      {set file window to first available empty node}
    write('.');                 {show user something is happening}
    PERSONS^:=NEWPERS;          {assign to a "disk variable"}
    put(PERSONS);               {write new root node to disk}
    FILE_LEN.PERSON_ROOT:=FILE_LEN.PERSON_AVAIL;
      {update root node pointer}
    FILE_LEN.PERSON_AVAIL:=J;   {reset pointer to new head node of linked list}
    FILE_LEN.PERSON_UNUSED:=FILE_LEN.PERSON_UNUSED-1;
      {correct number of empty or unused nodes}
  end; {if NEW_HEIGHT}
{************************************************************************
*                                                                       *
*  The five lines which follow save the revised control data to the     *
*  disk.  This is done after each operation where an insertion or       *
*  deletion might have taken place.  The reason is is done here rather  *
*  than upon program exit is to limit the damage which might be done    *
*  if there is a power or other failure prior to exiting the program.   *
*                                                                       *
************************************************************************}
  close(PERSONS,lock);          {ensure entire file is in directory}
  seek(CONTROLFILE,0);          {reset file window to node 0}
  write('.');                   {show user something is happening}
  CONTROLFILE^:=FILE_LEN;       {load CONTROLFILE buffer}
  put(CONTROLFILE);             {write CONTROLFILE buffer to disk}
  writeln;
  writeln;
  write('Print out or traverse B-tree?  (y/n)  ');
  if YES then PRINT_IT
end; {KEY_INSERT}

procedure KEY_DELETE;
{************************************************************************
*                                                                       *
*  This procedure controls the deletion of existing records.            *
*                                                                       *
************************************************************************}
label 1;
var   INPUTKEY:string;          {search key}
      U:PERSON;                 {not required?}
      FOUND,WRONG:boolean;      {insertion control variables}
      OLDPERS:PERSON_NODE;
      I,J,Q:integer;            {loop control variables}
begin
  REAL_KEY:='          ';       {initialize}
  reset(PERSONS,PERSON_FILE);   {open data file}
1:SPLIT:=false;                 {initialize}
  (*writeln(OUTFILE,'ROOT = ',FILE_LEN.PERSON_ROOT);
  writeln(OUTFILE,'AVAIL = ',FILE_LEN.PERSON_AVAIL);*)
  CHANGED:=false;               {initialize}
  DUPLICATE:=false;             {initialize}
  WRONG:=false;                 {initialize}
  FOUND:=false;                 {initialize}
  LEAVE:=false;                 {initialize}
  repeat
    write('Enter KEY to delete:  ');
    readln(INPUTKEY);             {get search key}
  until GOOD_STRING(INPUTKEY);
    {prevent meaningless keys}
  J:=length(INPUTKEY);
  if J>10 then J:=10;
  REAL_KEY:=copy(INPUTKEY,1,J);
  UPPERCASE(INPUTKEY);          {convert to uppercase}
  FAKE_KEY:=INPUTKEY;           {save INPUTKEY for display purposes}
  REAL_KEY:=INPUTKEY;           {initialize}
  INVERT_KEY(REAL_KEY,1);       {convert key to correct format}
  (*writeln(OUTFILE,'DELETE KEY ',INPUTKEY);      {display user key}
  writeln(OUTFILE,'REAL DELETE KEY ',REAL_KEY); {display real key}*)
  write('Deleteing record <',FAKE_KEY,'>');
  DELETE(REAL_KEY,FILE_LEN.PERSON_ROOT,FOUND,WRONG);   {delete search key}
  if WRONG then goto 1;
  if NEW_HEIGHT then begin      {root node size was reduced}
    seek(PERSONS,FILE_LEN.PERSON_ROOT); {set file window to root node}
    write('.');                 {show user something is happening}
    get(PERSONS);                        {load file buffer}
    J:=FILE_LEN.PERSON_ROOT;    {save location of root node}
    if PERSONS^.NODESIZE=0 then begin   {must reset root pointer}
      FILE_LEN.PERSON_ROOT:=PERSONS^.P0;
        {if PERSONS^.NODESIZE=0 then the root node is empty so reset
         the root to the old root lessor successor}
      PERSONS^.P0:=FILE_LEN.PERSON_AVAIL;
        {link old root node to the linked list of available nodes}
      FILE_LEN.PERSON_AVAIL:=J;
        {reset pointer to linked list of available nodes}
      FILE_LEN.PERSON_UNUSED:=FILE_LEN.PERSON_UNUSED+1;
        {correct number of empty or unused nodes}
    end; {if PERSONS^.NODESIZE=0}
    OLDPERS:=PERSONS^;          {hold while seeking}
    seek(PERSONS,J);            {set file window to old root node}
    write('.');                 {show user something is happening}
    PERSONS^:=OLDPERS;          {load file buffer}
    put(PERSONS)                {write file buffer to disk}
  end; {if NEW_HEIGHT}
  close(PERSONS,lock);          {make sure entire file is in directory}
{************************************************************************
*                                                                       *
*  The five lines which follow save the revised control data to the     *
*  disk.  This is done after each operation where an insertion or       *
*  deletion might have taken place.  The reason is is done here rather  *
*  than upon program exit is to limit the damage which might be done    *
*  if there is a power or other failure prior to exiting the program.   *
*                                                                       *
************************************************************************}
  close(PERSONS,lock);          {ensure entire file is in directory}
  seek(CONTROLFILE,0);          {reset file window to node 0}
  write('.');                   {show user something is happening}
  CONTROLFILE^:=FILE_LEN;       {load CONTROLFILE buffer}
  put(CONTROLFILE);             {write CONTROLFILE buffer to disk}
  writeln;
  writeln;
  write('Print out or traverse B-tree?  (y/n)  ');
  if YES then PRINT_IT
end; {KEY_DELETE}




procedure DATA_FULL;
begin
  CLEARSCREEN;
  gotoxy(0,11);
  writeln('There is no more space to insert data!!!!!');
  gotoxy(16,23);
  write('hit SPACEBAR to continue <--');
  CH:=READKEY([' '])
end; {DATA_FULL}

procedure TITLE;
var   S:string;
      I,J:integer;
begin 
  S:='ADDRESS BOOK'; 
  PRINTAT(37-length(S) div 2,2,S); 
  S:='written by';
  PRINTAT(37-length(S) div 2,3,S); 
  S:='R. M. Wilson';
  PRINTAT(37-length(S) div 2,4,S); 
  S:='Copyright by';
  PRINTAT(37-length(S) div 2,13,S);
  S:='HI-COUNTRY DATA SYSTEMS';
  PRINTAT(37-length(S) div 2,15,S); 
  S:='P.O. Box 4258';
  PRINTAT(37-length(S) div 2,16,S); 
  S:='Woodland Park, CO 80863-4258';
  PRINTAT(37-length(S) div 2,17,S); 
  S:='November 27, 1981';
  PRINTAT(37-length(S) div 2,18,S); 
  S:='Hit "SPACEBAR" to continue <--'; 
  PRINTAT(37-length(S) div 2,23,S); 
  CH:=READKEY([' ']);
  CLEARSCREEN 
end; {TITLE}


========================================================================================
DOCUMENT :usus Folder:VOL10:btree.get.text
========================================================================================

{************************************************************************
*                                                                       *
*  filed as BTREE.GET.TEXT                  revised 27 November 1981    *
*                                                                       *
************************************************************************}


{L *GET.TEXT}

procedure UPPERCASE(var KEY:FNAME);  {maps key to all uppercase}
{************************************************************************
*                                                                       *
*  This procedure makes sure regardless of what the user types in the   *
*  search for the key will be done for upper case "keys" only.          *
*                                                                       *
************************************************************************}
begin
  for I:=1 to length(KEY) do
    if (ord(KEY[I])>=97) and (ord(KEY[I])<=122) then {chr(97)=a & chr(122)=z}
      KEY[I]:=chr(ord(KEY[I])-32)
end;  {UPPERCASE}

procedure PRINT_PERSON(U:PERSON);
{************************************************************************
*                                                                       *
*  This procedure displays the record being entered or retrieved and    *
*  asks if the data is correct.  If it is then nothing out of the       *
*  ordinary happens, however if a correction is made then the revised   *
*  record is written to the disk.                                       *
*                                                                       *
************************************************************************}
begin
  CLEARSCREEN;
  with U do begin
    (*writeln('KEY  -->',KEY,'<--');     {KEY is the actual key}*)
    writeln;
    writeln('1--> First name:        ',FIRST);
    writeln('2--> Last name:         ',LAST);
{************************************************************************
*                                                                       *
*  In order to make this a usable program for names and addresses,      *
*  must remove the (**) from around the lines below.                    *
*                                                                       *
************************************************************************}
    (*writeln('3--> Street address:    ',STREET);
    writeln('4--> City:              ',CITY);
    writeln('5--> State:             ',STATE);
    writeln('6--> ZIP code:          ',ZIPCODE);
    writeln('7--> Telephone number:  ',PHONE); *)
    writeln;
  end  {with CUSTMERS^.DATA[K]}
end; {PRINTRECORD}

function GOOD_STRING(S:string):boolean;
begin
  if S<>'' then begin                           {S is not null string}
    if (S[1]<'!') or (S[1]>'~') then begin      {S[1] not human readable}
      writeln;
      writeln('error in entry...please re-enter   ');
      writeln;
      GOOD_STRING:=false
    end  {if S[1]=' '}
    else GOOD_STRING:=true
  end  {if S<>''}
  else begin                                    {S is null string}
    writeln;
    writeln('error in entry...please re-enter   ');
    writeln;
    GOOD_STRING:=false
  end  {else begin}
end; {GOOD_STRING}

procedure INVERT_KEY(var V:FNAME;K:integer);
{************************************************************************
*                                                                       *
*  This procedure takes the user inputed key and converts it to the     *
*  actual key.  This conversion is made to simplify displaying          *
*  "sounds like" records if the desired record is not found.            *
*                                                                       *
************************************************************************}
var   TEMP_KEY:FNAME;           {temporary key used while converting}
begin
  TEMP_KEY:='          ';
  J:=length(V);
  if J>10 then J:=10;
  case K of
    1:begin     {convert original user input}
        TEMP_KEY[J]:=V[1];
        for I:=1 to J-1 do TEMP_KEY[I]:=V[I+1];
      end;
    2:begin     {convert computed key to compare with user input}
        J:=1;
        while (J<=9) and (V[J]=' ') do begin
          V[1]:=V[J+1];
          J:=J+1;
        end; {while}
        for I:=2 to 11-J do V[I]:=V[I+J-1];
        J:=1;
        while (J<=9) and (V[J]<>' ') do J:=J+1;
        if J=9 then
          if V[10]<>' ' then J:=10;
        for I:=2 to J do TEMP_KEY[I]:=V[I-1];
        TEMP_KEY[1]:=V[J]
      end
  end; {case K}
  V:=TEMP_KEY;
end; {INVERT_KEY}

procedure COMPUTE_KEY(var V:PERSON);
{************************************************************************
*                                                                       *
*  This procedure computes the actual key from the FIRST and LAST       *
*  names which the user inputs.   It also computes a "FAKE_KEY"         *
*  which it displays to the user.                                       *
*                                                                       *
*  NOTE:                                                                *
*  ----                                                                 *
*                                                                       *
*       The real key/fake key concept was developed because it is       *
*       more natural for a user to type in the first initial and        *
*       last name rather than the last name and first initial, but      *
*       it is easier to write code to find "sounds like" or             *
*       similar spellings if the key is last name and first initial.    *
*                                                                       *
*       first name = BOB                last name = WILSON              *
*                                                                       *
*       user/fake key = BWILSON         actual key = WILSONB            *
*                                                                       *
************************************************************************}
var   FAKE_KEY:FNAME;           {for user edification only}
begin
  with V do begin
    KEY:='          ';          {initialize}
    FAKE_KEY:='          ';     {initialize}
    J:=length(LAST);
    if J>=10 then J:=9;
      {Since KEY:string[10] and one letter of the key must be the first
       initial, the maximum number of characters that can be mapped is 9.}
    for I:=1 to J do begin
      KEY[I]:=LAST[I];          {real key has last name before FIRST[1]}
      FAKE_KEY[I+1]:=LAST[I]    {fake key has last name after FIRST[1]}
    end; {for I}
    FAKE_KEY[1]:=FIRST[1];
    KEY[J+1]:=FIRST[1];
    UPPERCASE(FAKE_KEY);        {make all keys upper case because abc<>ABC}
    UPPERCASE(KEY);             {make all keys upper case because abc<>ABC}
    (*writeln('REAL KEY  -->',KEY,'<--');         {display results}
    writeln('USER KEY  -->',FAKE_KEY,'<--');    {display results} *)
  end  {with V}
end; {COMPUTE_KEY}

procedure GET_FIRST(var FIRST:FNAME);
var   INPUTKEY:string;
      J:integer;
begin
  repeat
    write('Enter first name:  ');
    readln(INPUTKEY);
  until GOOD_STRING(INPUTKEY);
    {prevent meaningless keys}
  J:=length(INPUTKEY);
  if J>10 then J:=10;
  FIRST:=copy(INPUTKEY,1,J);
end; {GET_FIRST}

procedure GET_LAST(var LAST:LNAME);
var   INPUTKEY:string;
      J:integer;
begin
  repeat
     write('Enter last name:   ');
     readln(INPUTKEY)
  until GOOD_STRING(INPUTKEY);
    {prevent meaningless keys}
  J:=length(INPUTKEY);
  if J>20 then J:=20;
  LAST:=copy(INPUTKEY,1,J);
end; {GET_LAST}

procedure PERSON_CHANGE(var U:PERSON);
{************************************************************************
*                                                                       *
*  This procedure allows user to change new data records before they    *
*  are written to the disk, and change old data records as required.    *
*                                                                       *
************************************************************************}
var   FIELD_NUM:integer;        {which field to change}
begin
  with U do begin
    repeat              {until the data is correct}
      repeat            {until (FIELD_NUM>0) and (FIELD_NUM<=7)}
        writeln;
        writeln;
        write('Enter field number in error:  ');
        readln(FIELD_NUM)
{************************************************************************
*                                                                       *
*  A simple "read(FIELD_NUM)" causes strange and not so wonderful       *
*  things to happen.  For some reason the system uses a "read" here     *
*  correctly, but the next read statement executed by the program       *
*  executes without any user input and uses the same data entered here  *
*  where "read(keyboard,CH)" is used.                                   *
*                                                                       *
************************************************************************}
      until (FIELD_NUM>0) and (FIELD_NUM<=7);
        {this is "bomb proofing"...must be changed if the number of
         fields are changed}
      writeln;
      case FIELD_NUM of
        1:begin
            GET_FIRST(FIRST);
            COMPUTE_KEY(U)      {we might have changed the key}
          end;
        2:begin
            GET_LAST(LAST);
            COMPUTE_KEY(U)      {we might have changed the key}
          end;
{************************************************************************
*                                                                       *
*  In order to make this a usable program for names and addresses,      *
*  must remove the (**) from around the lines below.                    *
*                                                                       *
************************************************************************}
        (*3:begin
            repeat
              write('Enter street address:  ');
              readln(STREET)
            until GOOD_STRING(STREET);          {prevent meaningless data}
          end;
        4:begin
            repeat
              write('Enter city:  ');
              readln(CITY)
            until GOOD_STRING(CITY);            {prevent meaningless data}
          end;
        5:begin
            repeat
              write('Enter state:  ');
              readln(STATE)
            until GOOD_STRING(STATE);           {prevent meaningless data}
          end;
        6:begin
            repeat
              write('Enter zip:  ');
              readln(ZIPCODE)
            until GOOD_STRING(ZIPCODE);         {prevent meaningless data}
          end;
        7:begin
            repeat
              write('Enter telephone number:  ');
              readln(PHONE)
            until GOOD_STRING(PHONE);           {prevent meaningless data}
          end;*)
      end; {case FIELD_NUM}
      PRINT_PERSON(U);          {print modified/corrected record}
      writeln;
      writeln;
      write('Is the customer data correct?');
    until YES
  end  {with U}
end; {PERSON_CHANGE}

procedure GET_NEW_PERSON(var V:PERSON);
{************************************************************************
*                                                                       *
*  This procedure initializes and gets a new record.  It then calls     *
*  other procedures to display and verify the data.                     *
*                                                                       *
************************************************************************}
var   INPUTKEY:string;
begin
  CLEARSCREEN;                  {clear CRT}
  with V do begin
    SUCCNODE:=-1;               {there are no successor nodes (yet!)}
    DUPE:=-1;                   {there are no duplicate keys (yet!)}
    KEY:='          ';          {initialize}
    writeln;
    GET_FIRST(FIRST);
    GET_LAST(LAST);
    COMPUTE_KEY(V);             {compute real key based on FIRST and LAST}
{************************************************************************
*                                                                       *
*  In order to make this a usable program for names and addresses,      *
*  must remove the (**) from around the lines below.                    *
*                                                                       *
************************************************************************}
    (*repeat
      write('Enter street address:  ');
      readln(STREET);
    until GOOD_STRING(STREET);          {prevent meaningless data}
    repeat
      write('Enter city:  ');
      readln(CITY);
    until GOOD_STRING(CITY);            {prevent meaningless data}
    repeat
      write('Enter state: ');
      readln(STATE);
    until GOOD_STRING(STATE);           {prevent meaningless data}
    repeat
      write('Enter ZIP code:  ');
      readln(ZIPCODE);
    until GOOD_STRING(ZIPCODE);         {prevent meaningless data}
    repeat
      write('Enter telephone number:  ');
      readln(PHONE);
    until GOOD_STRING(PHONE);           {prevent meaningless data} *)
  end; {with V}
  PRINT_PERSON(V);                      {display data entered}
  writeln;
  writeln;
  write('Is the above correct?  ');     {verify data}
  if not YES then PERSON_CHANGE(V)      {change it if not correct}
end; {GET_NEW_PERSON}
{L-}



========================================================================================
DOCUMENT :usus Folder:VOL10:btree.init.text
========================================================================================

{************************************************************************
*                                                                       *
*  filed as BTREE.INIT.TEXT            revised 27 November 1981         *
*                                                                       *
************************************************************************}

procedure INIT;
{************************************************************************
*                                                                       *
*  This procedure checks the disk in the "prefix" drive and reads the   *
*  data files if they exist.  If they don't it initializes and creates  *
*  new data files.                                                      *
*                                                                       *
************************************************************************}
var   GOOD_FILE:boolean;
begin
  CLEARSCREEN;                  {clear screen}
  gotoxy(0,11);                 {position cursor}
  write('Initializing data files');
  {$I-} { prohibit I/O runtime error if file is not on disk }
  reset(CONTROLFILE,CONTROL);   {open old control data file}
  if ioresult=0 then GOOD_FILE:=true            {file exists}
  else GOOD_FILE:=false;                        {no file on disk}
  write('.');                   {let user know somthing is happening}
  close(CONTROLFILE);
  write('.');                   {let user know somthing is happening}
  {$I+} { enable I/O runtime errors }
  if not GOOD_FILE then begin
    N:=0;                         {initialize}
    repeat
      N:=N+1
    until exp(N*ln(MAX_NODE_SIZE))>MAX_PERS_NODES;
    rewrite(CONTROLFILE,CONTROL); {open new control data file}
    write('.');                   {let user know somthing is happening}
    with CONTROLFILE^ do begin    {initialize control data file}
      PERSON_AVAIL:=0;   {no person nodes in newly created files}
      PERSON_ROOT:=-1;   {indicates no record in PERSONS}
      PERSON_UNUSED:=MAX_PERS_NODES;    {how many nodes are unused}
      PERSON_MIN:=N               {minimum empty nodes for insertion}
    end; {with CONTROLFILE^}
    put(CONTROLFILE);             {write initialized control data file to disk}
    write('.');                   {let user know somthing is happening}
    close(CONTROLFILE,lock);      {write control data file name in directory}
    write('.');                   {let user know somthing is happening}
  end; {if not GOOD_FILE begin}
  {$I-} { prohibit I/O runtime error if file is not on disk }
  reset(PERSONS,PERSON_FILE);   {open old person data file}
  if ioresult=0 then GOOD_FILE:=true            {file exists}
  else GOOD_FILE:=false;                        {no file on disk}
  write('.');                   {let user know somthing is happening}
  close(PERSONS);
  write('.');                   {let user know somthing is happening}
  {$I+} { enable I/O runtime errors }
  if not GOOD_FILE then begin
    rewrite(PERSONS,PERSON_FILE); {open new person data file}
    write('.');                   {let user know somthing is happening}
    with PERSONS^ do begin        {initialize first PERSON_NODE}
      NODESIZE:=0;                {no person entered yet}
      P0:=-1;     {indicates there is no "lessor" successor node}
      for I:=1 to MAXNODESIZE do begin    {initialize each node slot}
        with DATA[I] do begin             {initialize each node slot}
          SUCCNODE:=-1;   {indicates there is no "lessor" successor node}
          DUPE:=-1;       {indicates there is no duplicate key}
          KEY:='';        {not really required...done for "double protection"}
          FIRST:='';      {not really required...done for "double protection"}
          LAST:='';       {not really required...done for "double protection"}
          STREET:='';   {not really required...done for "double protection"}
          CITY:='';       {not really required...done for "double protection"}
          ZIPCODE:='';    {not really required...done for "double protection"}
          STATE:='';      {not really required...done for "double protection"}
          PHONE:='';      {not really required...done for "double protection"}
        end; {with DATA[I]}
      end; {for I}
      for J:=1 to MAX_PERS_NODES-1 do begin
        P0:=J;            {points to next available empty node}
        put(PERSONS);
        write('.');               {let user know somthing is happening}
      end; {for J}
      P0:=-1;                     {flag to indicate no more nodes available}
    end; {with PERSONS^}
    put(PERSONS);                {write final initialized PERSON_NODE to disk}
    write('.')                   {let user know somthing is happening}
  end; {if not GOOD_FILE begin}
  close(PERSONS,lock);          {write PERSFILE name in directory}
  CLEARSCREEN                   {clear screen}
end; {INIT}
{l-}



========================================================================================
DOCUMENT :usus Folder:VOL10:btree.prnt.text
========================================================================================

{************************************************************************
*                                                                       *
*  filed as BTREE.PRNT.TEXT               revised 31-May-82             *
*                                                                       *
************************************************************************}




{************************************************************************
*                                                                       *
*  The three procedures which follow print the B-tree as a B-tree and   *
*  traverse the tree both inorder and postorder.  For a useful program, *
*  these procedures must be deleted and new data output procedures      *
*  written.  Since personal taste and intended use play such signif-    *
*  cant role in determining what is a suitable format, no attempt has   *
*  been made to suggest alternatives.                                   *
*                                                                       *
************************************************************************}



procedure PRINTTREE(N,BTREE_LEVEL:integer);
var I:integer;          {loop control variable}
    PERSONS:PERSFILE;
begin
  if not(N<0) then begin        {if N<0 then node is "null" node}
    write(OUTFILE,N:4);
    reset(PERSONS,PERSON_FILE);   {open the data file for display}
    seek(PERSONS,N);            {set file window to node N}
    get(PERSONS);               {load file buffer}
    for I:=1 to BTREE_LEVEL do write(OUTFILE,'    ');
      {provides horizontal indication of different levels}
    for I:=1 to PERSONS^.NODESIZE do write(OUTFILE,PERSONS^.DATA[I].KEY:12);
      {print out persons in node}
    writeln(OUTFILE);
    PRINTTREE(PERSONS^.P0,BTREE_LEVEL+1);  {print out lessor successor node}
    for I:=1 to PERSONS^.NODESIZE do       {print out other successor nodes}
      PRINTTREE(PERSONS^.DATA[I].SUCC_NODE,BTREE_LEVEL+1);
  end; {if not(N<0)}
  close(PERSONS)                {close the file}
end; {PRINTTREE}

procedure INORDER(NODENUM:integer);
{************************************************************************
*                                                                       *
*  This procedure traverses a btree in order and prints out the data    *
*  in the correct order.  For this program, it will print out the data  *
*  in alphabetical order of the keys.  Duplicate keys will be printed   *
*  in whatever order they are in linked list.  It should be noted that  *
*  for ASCII characters alphebetical order implies that "0" comes       *
*  before "9" which comes before "a" which, in turn, comes before "A".  *
*                                                                       *
************************************************************************}
var  SLOT:integer;              {which data element being visited}
begin
  if NODENUM>0 then exit(INORDER);
    {no such record exists...  prevents useless search when
     FILE_LEN.PERSON_ROOT=-1}
  SLOT:=0;                      {initialize slot}
  seek(PERSONS,NODENUM);        {set file window to node NODENUM}
  get(PERSONS);                 {load file buffer}
  {if PERSONS^.NODESIZE<1 then exit(INORDER);}   {node is empty}
  if DUPLICATE then begin       {print out duplicate nodes}
    for SLOT:=1 to PERSONS^.NODESIZE do begin
      write(OUTFILE,NODENUM:4,'    ');
      writeln(OUTFILE,PERSONS^.DATA[SLOT].KEY,'  ',PERSONS^.DATA[SLOT].FIRST)
    end; {for SLOT}
    if PERSONS^.P0>=0 then INORDER(PERSONS^.P0);
      {more duplicate keys exists so print them out}
    DUPLICATE:=false;           {reset flag/control variable}
  end  {if DUPLICATE}
  else begin
    if PERSONS^.P0>=0 then begin
      {if P0>=0 then there is a key with a value less than DATA[1].KEY}
      INORDER(PERSONS^.P0);       {see if there are more "lessor" keys}
      seek(PERSONS,NODENUM);      {reset the file windown to node NODENUM}
      get(PERSONS)                {load file buffer}
    end; {if PERSONS^.P0>=0}
{************************************************************************
*                                                                       *
*  The for..do loop which follows prints DATA[SLOT] of node number      *
*  NODENUM, and checks to see if there are some data greater than the   *
*  datum   DATA[SLOT] in a successor node.  If there are, the successor *
*  node is checked.  Finally the file window is reset in order to       *
*  repeat the entire process for each datum in the node NODENUM.        *
*                                                                       *
************************************************************************}
    for SLOT:=1 to PERSONS^.NODESIZE do begin
      write(OUTFILE,NODENUM:4,'    ');
      writeln(OUTFILE,PERSONS^.DATA[SLOT].KEY,'  ',PERSONS^.DATA[SLOT].FIRST);
         {print data}
      if PERSONS^.DATA[SLOT].DUPE>=0 then begin {a duplicate key exists}
        DUPLICATE:=true;        {set flag to print out duplicate keys}
        INORDER(PERSONS^.DATA[SLOT].DUPE);      {print them out}
        seek(PERSONS,NODENUM);  {reset file window to node "NODENUM"}
        get(PERSONS)            {load file buffer}
      end; {if PERSONS^.DATA[SLOT].DUPE>=0}
      if PERSONS^.DATA[SLOT].SUCC_NODE>=0 then begin
          {keys with a value > DATA[SLOT].KEY exist in a successor node}
        INORDER(PERSONS^.DATA[SLOT].SUCC_NODE);   {check successor node}
        seek(PERSONS,NODENUM);    {reset file window to node NODENUM}
        get(PERSONS)              {load file buffer}
      end  {if PERSONS^.DATA[SLOT].SUCC_NODE>=0}
    end; {for SLOT}
  end  {else begin}
end; {INORDER}

procedure POSTORDER(NODENUM:integer);
{************************************************************************
*                                                                       *
*  This procedure traverses a btree in postorder and prints out the     *
*  data in inverse order.  For this program, it will print out the data *
*  in reverse alphabetical order of the keys.  Duplicate keys will be   *
*  printed out in whatever order they are in in the linked list.  It    *
*  should be noted that for ASCII characters alphabetical order implies *
*  that "0" comes before "9" which comes before "a" which, in turn,     *
*  comes before "A".                                                    *
*                                                                       *
************************************************************************}
var  SLOT:integer;              {loop control variable}
begin
  if NODENUM>0 then exit(POSTORDER);
    {no such record exists...  prevents useless search when
     FILE_LEN.PERSON_ROOT=-1}
  SLOT:=0;                      {initialize SLOT}
  seek(PERSONS,NODENUM);        {set file window to node NODENUM}
  get(PERSONS);                 {load file buffer}
  {if PERSONS^.NODESIZE<1 then exit(POSTORDER);} {node is empty}
  if DUPLICATE then begin       {print out duplicate nodes}
    for SLOT:=1 to PERSONS^.NODESIZE do begin
      write(OUTFILE,NODENUM:4,'    ');
      writeln(OUTFILE,PERSONS^.DATA[SLOT].KEY,'  ',PERSONS^.DATA[SLOT].FIRST)
    end; {for SLOT}
    if PERSONS^.P0>=0 then INORDER(PERSONS^.P0);
      {more duplicate keys exists so print them out}
    DUPLICATE:=false;           {reset flag/control variable}
  end  {if DUPLICATE}
  else begin
    if PERSONS^.DATA[PERSONS^.NODESIZE].SUCC_NODE>=0 then begin
      {there are data greater than PERSONS^.DATA[PERSONS^.NODESIZE].KEY}
      POSTORDER(PERSONS^.DATA[PERSONS^.NODESIZE].SUCC_NODE);  {check them}
      seek(PERSONS,NODENUM);      {reset file window to node NODENUM}
      get(PERSONS)                {load file buffer}
    end; {if PERSONS^.DATA[PERSONS^.NODESIZE].SUCC_NODE>=0}
{************************************************************************
*                                                                       *
*  The for..do loop which follows prints DATA[SLOT] of node number      *
*  NODENUM, and checks to see if there are some data lessor than the    *
*  datum   DATA[SLOT] in a successor node.  If there are, the successor *
*  node is checked.  Finally the file window is reset in order to       *
*  repeat the entire process for each datum in the node NODENUM.        *
*                                                                       *
************************************************************************}
    for SLOT:=PERSONS^.NODESIZE downto 1 do begin
      write(OUTFILE,NODENUM:4,'    ');
      writeln(OUTFILE,PERSONS^.DATA[SLOT].KEY,'  ',PERSONS^.DATA[SLOT].FIRST);
         {print datum}
      if PERSONS^.DATA[SLOT].DUPE>=0 then begin {a duplicate key exists}
        DUPLICATE:=true;        {set flag to print out duplicate keys}
        INORDER(PERSONS^.DATA[SLOT].DUPE);      {print them out}
        seek(PERSONS,NODENUM);  {reset file window to node "NODENUM"}
        get(PERSONS)            {load file buffer}
      end; {if PERSONS^.DATA[SLOT].DUPE>=0}
      if SLOT>1 then begin
          {if SLOT=1 then runtime error results because DATA[SLOT-1]
           would be DATA[0] which doesn't exist}
        if PERSONS^.DATA[SLOT-1].SUCC_NODE>=0 then begin
            {there is lessor data}
          POSTORDER(PERSONS^.DATA[SLOT-1].SUCC_NODE);     {check it}
          seek(PERSONS,NODENUM);  {reset file window to node NODENUM}
          get(PERSONS)            {load file buffer}
        end  {if PERSONS^.DATA[SLOT-1].SUCC_NODE>=0}
      end  {if SLOT>1}
{************************************************************************
*                                                                       *
*  The next line checks to see if there is any lessor data than         *
*  the datum in DATA[1] in a successor node, and if so it checks that   *
*  successor node.                                                      *
*                                                                       *
************************************************************************}
      else if PERSONS^.P0>=0 then POSTORDER(PERSONS^.P0);
    end  {for SLOT}
  end  {else begin}
end; {POSTORDER}

procedure PRINT_IT;
{************************************************************************
*                                                                       *
*  Print out the btree and inorder and postorder traversals.            *
*                                                                       *
************************************************************************}
begin
  CLEARSCREEN;
  gotoxy(0,4);
  write('Print out B-tree?  (y/n)  ');
  if YES then begin
    writeln(OUTFILE);
    writeln(OUTFILE);
    writeln(OUTFILE,'--> PERSON B-TREE');
    writeln(OUTFILE);
    writeln(OUTFILE);
    writeln(OUTFILE,' Node');
    writeln(OUTFILE);
    PRINTTREE(FILE_LEN.PERSON_ROOT,1);   {print the b-tree}
    writeln(OUTFILE);
    writeln(OUTFILE);
  end; {if YES}
  writeln;
  writeln;
  write('Traverse b-tree inorder?  (y/n)  ');
  if YES then begin {do it}
    reset(PERSONS,PERSON_FILE); {open data file}
    writeln(OUTFILE);
    writeln(OUTFILE);
    writeln(OUTFILE,'--> INORDER TRAVERSAL');
    writeln(OUTFILE);
    writeln(OUTFILE);
    writeln(OUTFILE,' Node');
    writeln(OUTFILE);
    INORDER(FILE_LEN.PERSON_ROOT);     {traverse tree}
    close(PERSONS,lock);        {close the data file}
  end; {if CH in}
  writeln;
  writeln;
  write('Traverse b-tree in postorder?  (y/n)  ');
  if YES then begin {do it}
    reset(PERSONS,PERSON_FILE); {open data file}
    writeln(OUTFILE);
    writeln(OUTFILE);
    writeln(OUTFILE,'--> POSTORDER TRAVERSAL');
    writeln(OUTFILE);
    writeln(OUTFILE);
    writeln(OUTFILE,' Node');
    writeln(OUTFILE);
    POSTORDER(FILE_LEN.PERSON_ROOT);   {traverse tree}
    close(PERSONS,lock);        {close the data file}
    writeln(OUTFILE);
    writeln(OUTFILE);
  end  {if CH in}
end; {PRINT_IT}






========================================================================================
DOCUMENT :usus Folder:VOL10:btree.std.text
========================================================================================

{************************************************************************
*                                                                       *
*  filed as BTREE.STD.TEXT             revised 19 November 1981         *
*                                                                       *
************************************************************************}


function READKEY(OKSET:SETOFCHAR):char;
{************************************************************************
*                                                                       *
*  This procedure looks at each keypress and determines if the key      *
*  pressed is valid, i.e. the "set of char which are valid may be       *
*  varied with each call of this procedure.  If the key pressed is      *
*  not in the valid or 'OKSET', then the bell sounds.  If the key       *
*  pressed is valid the computer accepts the input and the program      *
*  continues to run.                                                    *
*                                                                       *
************************************************************************}
var   CH:char;
      GOOD:boolean;
begin
  repeat
    read(keyboard,CH);
    if eoln(KEYBOARD) then CH:=chr(13);
    GOOD:=CH in OKSET;
    if not GOOD then write(chr(7))
  until GOOD;
  READKEY:=CH
end;  {READKEY}

function YES:boolean;
begin
  YES:=READKEY(['Y','N','y','n']) in ['y','Y']
end; {YES}

procedure PRINTAT(X,Y:integer;S:string);
{************************************************************************
*                                                                       *
*  This procedure writes a string at a designated location on the CRT   *
*                                                                       *
************************************************************************}
begin
  gotoxy(X,Y);
  write(S)
end; {PRINTAT}

procedure CLEARSCREEN;
{************************************************************************
*                                                                       *
*  This procedure is for the TeleVideo only.  The TeleVideo and/or the  *
*  MICROENGINE will not clear the screen with the standard              *
*                         "page(output)".                               *
*   Note: changed by gws to be compatable with H-19                     *
************************************************************************}
begin
  gotoxy ( 0, 0 );
  write(chr(27),chr(69));   {H-19 specific}
end; {CLEARSCREEN}





========================================================================================
DOCUMENT :usus Folder:VOL10:catalog.1.text
========================================================================================

(* included from catalog *)

procedure SORT;  {sorts the directory file in alphebetical order}
var   I:RECNUM;
      BUF:CATALOG_RECORD;       {holds record during exchange}
FLAG:boolean;             {FALSE if an exchange made during pass}
begin
  writeln('sorting ',DREC,' records   ');
  repeat
    FLAG:=true;
    for I:=DREC downto 2 do
      if (DCAT[I].FILE_NAME<DCAT[I-1].FILE_NAME) then begin
        {exchange routine}
        BUF:=DCAT[I];
        DCAT[I]:=DCAT[I-1];
        DCAT[I-1]:=BUF;
        FLAG:=false;
      end;{if}
    write('.');
  until FLAG;
  writeln;
  writeln('sorting complete  ');
end;{SORT}

procedure GETDIR;  {reads directory of update volume and puts it in DCAT}
var   DIRX:DIRECTORY;
      UNITNUM,I:integer;
      CHBUF:char;
      VOL:VOL_ID;
      SPS:string[16];
      BLOCKS_USED:0..{988}maxint; {allow for big disk - gws }
begin
  BLOCKS_USED:=10;  {assumes duplicate directories}
  DREC:=0;
  CLEARSCREEN;
  {MEM('GETDIR');}
  repeat 
    write('Enter unit number for required directory:   ');
    readln(UNITNUM);
    writeln
  until UNITNUM in [4..5, 9..12];
  unitread(UNITNUM,DIRX[0],2048,2);
  if IORESULT<>0 then begin
    writeln('Unit not on line  ');
    LEAVE:=true;
    exit(UPDATE);
  end;{if IORESULT<>0}
  VOL:=DIRX[0].DIR_VOL_NAME;
  SPS:=copy(BLANKS,1,7-length(VOL));  {put VOL in consistent format}
  VOL:=concat(VOL,SPS);
  for I:=1 to DIRX[0].NUM_OF_FILES do begin
    with DIRX[I] do begin
      if length(DIR_FILE_NAME)>0 then begin
        DREC:=DREC+1;
        with DCAT[DREC] do begin
          VOL_NAME:=VOL;
          FILE_NAME:=DIR_FILE_NAME;
          SPS:=copy(BLANKS,1,15-length(FILE_NAME));
          FILE_NAME:=concat(FILE_NAME,SPS);
          FILE_KIND:=DIR_FILE_KIND;
          FILE_DATE:=DIR_FILE_DATE;
          FILE_SIZE:=LAST_BLOCK-FIRST_BLOCK;
          BLOCKS_USED:=BLOCKS_USED+FILE_SIZE;
        end {with DCAT[DREC]}
      end {IF length}
    end {with DIRX[I]}
  end;{for I}
  {next we create entry with name FREE.SPACE containing the unused space 
   on the volume}
  DREC:=DREC+1;
  with DCAT[DREC] do begin
    VOL_NAME:=VOL;
    FILE_NAME:='FREE.SPACE';
    SPS:=copy(BLANKS,1,15-length(FILE_NAME)); 
    FILE_NAME:=concat(FILE_NAME,SPS);
    FILE_KIND:=INFO;
    FILE_DATE:=DIRX[0].LAST_BOOT; 
    FILE_SIZE:=DIRX[0].TOTAL_BLOCKS-BLOCKS_USED;
  end {with DCAT[DREC]}
end;{GETDIR}

procedure SETDEX;
{if first occurance of file name with DEX as first letter then
 put record number in DEXRAY and increment DEX}
begin
  if (NCAT[NREC].FILE_NAME[1]>=DEX)
  {have we reached or exceeded the next index?}
  then begin 
    if (NCAT[NREC].FILE_NAME[1]>DEX) then 
    {fill DEXRAY to the next valid index}
      repeat
        DEXRAY[DEX]:=0;
        if DEX='Z' then exit(SETDEX);
        DEX:=succ(DEX); 
      until (NCAT[NREC].FILE_NAME[1]=DEX);
      DEXRAY[DEX]:=NTOTREC+NREC;
      if DEX='Z' then exit(SETDEX);
      DEX:=succ(DEX);
  end {if NCAT[NREC].FILE_NAME>=DEX}
end;{SETDEX}

procedure MERGE;  {merges DCAT with OCAT to form NCAT}
var   X,Y,Z:1..33;
      CONTINUE:boolean;
      OO,O,D:RECNUM;
begin
  DEX:='A';  {set first match char for index at 'A'} 
  O:=OREC; 
  OREC:=1;
  D:=1;
  {REMOV is true if folume is to be deleted}
  if (NOT REMOV) then VOL:=DCAT[1].VOL_NAME;
  {DREC+1 is 1 more than the number of files in DCAT}
  while (D<DREC+1) do begin
    with DCAT[D] do begin
      if (FILE_NAME<OCAT[OREC].FILE_NAME) then X:=10
      else if (FILE_NAME=OCAT[OREC].FILE_NAME) then X:=20
           else X:=30;
      if (VOL_NAME<OCAT[OREC].VOL_NAME) then Y:=1
      else if (VOL_NAME=OCAT[OREC].VOL_NAME) then Y:=2
           else Y:=3;
      Z:=X+Y;
      if ((OREC=0) or (OREC>O)) then Z:=11;
      
      case Z of 
      
        11,12,13,21:begin  {add record to NCAT from DCAT} 
                      NREC:=NREC+1;
                      NCAT[NREC]:=DCAT[D];
                      D:=D+1;  {increment D}
                      write('add ',NCAT[NREC].FILE_NAME:18);
                      writeln(NCAT[NREC].VOL_NAME:10)
                    end;
        
        22         :begin  {add record to NCAT from DCAT}
                      NREC:=NREC+1;
                      NCAT[NREC]:=DCAT[D];
                      OREC:=OREC+1;  {increment OREC}
                      D:=D+1;  {increment D}
                    end;
                    
        23,31,33   :begin  {add record to NCAT from OCAT}
                      NREC:=NREC+1;
                      NCAT[NREC]:=OCAT[OREC];
                      OREC:=OREC+1;  {increment OREC}
                    end;
                    
        32         :begin  {DO NOT add record to NCAT}
                      write('DELETE ',OCAT[OREC].FILE_NAME:18);
                      writeln(OCAT[OREC].VOL_NAME:10);
                      OREC:=OREC+1;  {increment OREC}
                    end;
      end;{case Z}
      SETDEX;   {check pointer index}
    end;{with ?}
    if NREC=NLREC then WRITECAT;  {NLREC is the max array size}
    if ((OREC>OLREC) and (not OFILEEND)) then begin
    {if you are out of OCAT then get some more}
      READ_OLD_CAT;
      O:=OREC;
      OREC:=1;
    end;{if ((OREC>OLREC) and (not OFILEEND))}
  end;{while}    {DCAT is empty}
  repeat  {gets whats left of OCAT}
    CONTINUE:=false;
    if OREC<=O then for OO:=OREC to O do
      if OCAT[OO].VOL_NAME<>VOL then begin
        NREC:=NREC+1;
        NCAT[NREC]:=OCAT[OO];
        if NREC=NLREC then WRITECAT;
        SETDEX;
      end {if OCAT[OO].VOL_NAME<>VOL} 
      else begin
        write('DELETE ',OCAT[OO].FILE_NAME:18);
        writeln(OCAT[OO].VOL_NAME:10)
      end;{else begin}
    if not OFILEEND then begin {if you are out of OCAT get some more} 
      READ_OLD_CAT;
      O:=OREC;
      OREC:=1;
      CONTINUE:=true;
    end;{if not OFILEEND}
  until not CONTINUE;
  {writeln('DEX=',DEX);
  writeln('CH=',CH);}
  if DEX<'Z' then for CH:=DEX to 'Z' do begin 
                    {writeln('DEX=',DEX); 
                    writeln('CH=',CH);}
                    DEXRAY[CH]:=DEXRAY[PRED(DEX)];
                  end;{for CH}
  DONE:=true; 
  WRITECAT;
  WRITEDEX;
end;{MERGE}

begin  {update}
  rewrite(P,'CONSOLE:');
  CLEARSCREEN;
  write('Searching for old CATALOG...'); 
  if LOOKUP(OFILENAME) then begin 
    writeln;
    reset(OCATFILE,OFILENAME); 
    close(OCATFILE,purge);
  end;{if} 
  RENAME;
  if not REMOV then begin
    GETDIR;
    SORT;
    CLEARSCREEN;
    for RN:=1 to DREC do begin 
      PRINT_RECORD(DCAT[RN]);
      if (RN mod 20=0) then begin
        CLEARSCREEN
      end {if} 
    end {for RN}
  end;{if}
  writeln;
  write('Searching for old CATALOG...');
  if LOOKUP(OFILENAME) then begin 
    writeln;
    reset(OCATFILE,OFILENAME); 
    READ_OLD_CAT;
  end {if}
  else OREC:=0;
  rewrite(NCATFILE,NFILENAME);
  NREC:=0;
  MERGE;
  close(OCATFILE);
  close(P);
  writeln;
  writeln;
  writeln('BACKCAT contains ',OTOTREC,' records');
  writeln('MASTCAT contains ',NTOTREC,' records');
  writeln;
  writeln;
  close(NCATFILE,lock);
  SPACEBAR;
end;{UPDATE}

procedure SEARCH;
var   HARDCOPY,STOP,FOUND:boolean; 
      TAR1,TAR2:char;
      I,START:integer; 
      WILDCARD:0..16;
      CAT:CATALOG_RECORD;
      TARGET,SPS:string;
      
procedure LONGSEARCH;  {used when alphebetical pointers can't be used}
var   N:RECNUM;
begin
  delete(TARGET,1,1);
  writeln(TARGET);
  repeat
    READ_NEW_CAT;
    for N:=1 to NREC do if pos(TARGET,NCAT[N].FILE_NAME)<>0 then 
                          PRINT_RECORD(NCAT[N]);
  until NFILEEND;
  close(NCATFILE);
  SPACEBAR;
  close(P);
  exit(SEARCH)
end;{LONGSEARCH}

procedure SEARCH_FOR_VOLUME;
var   BLKS,SPS:string[7];
      N:RECNUM; 
begin
  BLKS:='       ';
  delete(TARGET,pos(':',TARGET),1);
  SPS:=copy(BLKS,1,7-length(TARGET));
  TARGET:=concat(TARGET,SPS);
  writeln(TARGET);
  repeat
    READ_NEW_CAT;
    for N:=1 to NREC do
      if (NCAT[N].VOL_NAME=TARGET) then PRINT_RECORD(NCAT[N]);
  until NFILEEND;
  close(NCATFILE);
  SPACEBAR;
  close(P);
  exit(SEARCH)
end;{SEARCH_FOR_VOLUME}

begin  {SEARCH}
  HARDCOPY:=false;
  STOP:=false; 
  FOUND:=false;
  repeat
    write('Enter name of file to be found:  ');
    readln(TARGET);
    if (length(TARGET)>16) then writeln('NAME TOO LONG...'); 
  until (length(TARGET)<=16); 
  make_upper ( target );
  gotoxy(0,12);
  write(chr(8),chr(27),chr(108));
  write('Select desired option...',chr(27),chr(109));
  writeln;
  writeln;
  writeln('1--> output to CRT');
  writeln;
  write('2--> output to PRINTER  ');
  CH:=READKEY(['1','2']);
  CLEARSCREEN; 
  if CH='1' then rewrite(P,'CONSOLE:')
  else begin
      rewrite(P,'printer:');
      CLEARSCREEN;
      PRINTAT(0,12,'Sending search results to PRINTER...  ');
      for I:=1 to 5 do writeln(P);
      HARDCOPY:=true;
  end;{else}
  reset(NCATFILE,NFILENAME);
  if pos(':',TARGET)<>0 then SEARCH_FOR_VOLUME; 
  WILDCARD:=pos('=',TARGET);
  if WILDCARD=1 then LONGSEARCH;
  if WILDCARD>1 then TARGET:=copy(TARGET,1,WILDCARD-1);
  TAR1:=TARGET[1];      {TAR1 used to get pointer from DEXRAY}
     {TAR2 used to end search} 
  if (length(TARGET)>1) and (WILDCARD <> 2) then TAR2:=TARGET[2] 
  else TAR2:='z';
  if TAR2<'A' then START:=0
  else if TAR1>'Z' then START:=DEXRAY['Z']
       else START:=DEXRAY[TAR1];
  seek(NCATFILE,START);
  get(NCATFILE);
  repeat
    CAT:=NCATFILE^;
    if ((WILDCARD=0) and (pos(TARGET,CAT.FILE_NAME)=1)) then begin 
      PRINT_RECORD(CAT);
      FOUND:=true;
    end;{if}
    if ((WILDCARD>1) and (pos(TARGET,CAT.FILE_NAME)>=1)) then begin 
      PRINT_RECORD(CAT);
      FOUND:=true;
    end;{if}
if ((CAT.FILE_NAME[1]>TAR1) or (CAT.FILE_NAME[2]>TAR2)) then STOP:=true;
    get(NCATFILE);
  until (STOP or eof(NCATFILE));
  if not FOUND then writeln('File ',TARGET,' not found...  ');
  close(NCATFILE); 
  close(P);
  if not HARDCOPY then SPACEBAR; 
end;{SEARCH}

procedure CLEARSCREEN;  {for Heath H19}
begin
  gotoxy ( 0, 0 );
  write(chr(27),chr(69));
end;

function READKEY;
var CH:CHAR; 
    GOOD:BOOLEAN;
begin
  repeat
    read(KEYBOARD,CH); 
    if eoln(KEYBOARD) then CH:=chr(13);
    GOOD:=CH in OKSET;
    if not GOOD then write(chr(7))
      else if CH in [' '..'}'] then write(CH); 
  until GOOD;
  READKEY:=CH;
end;{READKEY}

procedure PRINTAT;
begin
  gotoxy(X,Y);
  write(S);
end;{PRINTAT}

function YES; 
begin
  YES:=READKEY(['Y','y','N','n']) in ['Y','y'];
end;{YES}

procedure SPACEBAR;  { a technique to hold data/display on CRT }
var CH:CHAR;
begin
  gotoxy(22,23); 
  write('Hit "SPACE-BAR" to continue   <---');
  CH:=READKEY([' ']);
end;{SPACEBAR}

procedure QUIT;  {exit program}
begin
  CLEARSCREEN;
  exit(program);
end;{QUIT}

function LOOKUP;  {returns TRUE if filename present -- FALSE if not} 
var   IOR:0..15;
begin
  {$I-}
  reset(CATFILE,FN);
  IOR:=IORESULT;
  CLOSE(CATFILE);
  {$I+}
  if IOR=0 then LOOKUP:=true
  else begin
    LOOKUP:=false;
    if IOR<>10 then writeln('IORESULT for ',FN,' is ',IOR) 
  end {else begin} 
end;{LOOKUP}

procedure MEM;
begin 
  writeln('MEMORY AVAILABLE AT PROCEDURE ',PN,' = ',MEMAVAIL);
end;{MEM}

procedure READDEX; 
{*********************************************************************** 
*                                                                       *
*  This procedure reads the file of pointers to the first occurrence    *
*  of each letter in the alphabet.                                      * 
*                                                                       * 
************************************************************************}
var   DEXFILE:file of INDEXARRAY;
begin
  reset(DEXFILE,PFILENAME);
  DEXRAY:=DEXFILE^;
  get(DEXFILE);
  close(DEXFILE)
end;{READDEX} 

procedure ENTER_VOL_NAME;
var   SPS:VOL_ID;
begin
  VOL:='       ';
  repeat
    CLEARSCREEN;
    PRINTAT(0,12,'Enter name of volume to be removed -->  ');
    readln(VOL);
  until (length(VOL)<=8);
  make_upper ( vol );
  if (pos(':',VOL)<>0) then delete(VOL,pos(':',VOL),1);
  SPS:=copy(BLANKS,1,7-length(VOL));
  VOL:=concat(VOL,SPS);
  writeln(VOL,':');
  DREC:=0
end;{ENTER_VOL_NAME}


========================================================================================
DOCUMENT :usus Folder:VOL10:catalog.2.text
========================================================================================

(* included from catalog *)

procedure PRINT_DATE;  {prints date to console or printer} 
begin
  with REC do begin
    write(P,DAY:3,'-');
    case MONTH of
      1:write(P,'Jan'); 
      2:write(P,'Feb');
      3:write(P,'Mar'); 
      4:write(P,'Apr'); 
      5:write(P,'May'); 
      6:write(P,'Jun'); 
      7:write(P,'Jul'); 
      8:write(P,'Aug'); 
      9:write(P,'Sep'); 
      10:write(P,'Oct'); 
      11:write(P,'Nov'); 
      12:write(P,'Dec'); 
    end;{case MONTH} 
    write(P,'-',YEAR:2,' ':3);
  end {with}
end;{PRINT_DATE}

procedure PRINT_KIND;{prints file to console or printer} 
begin
  case FILE_KIND of
    XDISK:write(P,'Bad block'); 
    CODE:write(P,'Code file');
    TEXT:write(P,'Text file');
    INFO:write(P,'Info file');
    DATA:write(P,'Data file');
    GRAF:write(P,'Graf file');
    FOTO:write(P,'Foto file'); 
  end {case FILE_KIND}
end;{PRINT_KIND}

procedure PRINT_RECORD;
{prints record to console or printer} 
begin
  with CAT1 do begin
    write(P,FILE_NAME,'  ':18-length(FILE_NAME)); 
    write(P,VOL_NAME,'  ',8-length(VOL_NAME));
    write(P,FILE_SIZE:4);
    PRINT_DATE(FILE_DATE);
    PRINT_KIND(FILE_KIND);
    writeln(P)
  end {with CAT1}
end;{PRINT_RECORD}

procedure READ_NEW_CAT;  {reads NREC or to "eof" from NCATFILE}
var   I:RECNUM;
begin
  I:=1;
  NREC:=0;
  get(NCATFILE);
  while (not eof(NCATFILE)) do begin 
    NCAT[I]:=NCATFILE^;
    if ((NCAT[I].VOL_NAME='       ')) then begin
      NREC:=I-1;
      NTOTREC:=NTOTREC+NREC;
      NFILEEND:=true;
      exit(READ_NEW_CAT);
    end;{if NCAT[I].VOL_NAME=}
    if I=NLREC then begin
      NREC:=I;
      NTOTREC:=NTOTREC+I;
      exit(READ_NEW_CAT);
    end;{if I=NLREC}
    I:=I+1;
    get(NCATFILE);
  end;{while (not eof(NCATFILE))}
  NREC:=I-1;
  NTOTREC:=NTOTREC+NREC;
  NFILEEND:=true
end;{READ_NEW_CAT}

procedure READ_OLD_CAT;  {reads OREC record or to eof from OCATFILE}
var   I:RECNUM;
begin
  I:=1;
  OREC:=0;
  get(OCATFILE);
  while (not eof (OCATFILE)) do begin 
    OCAT[I]:=OCATFILE^; 
    if ((OCAT[I].VOL_NAME='       ')) then begin
      OREC:=I-1;
      OTOTREC:=OTOTREC+OREC;
      OFILEEND:=true;
      exit(READ_OLD_CAT);
    end;{if OCAT[I].VOL_NAME=}
    if I=OLREC then begin
      OREC:=I;
      OTOTREC:=OTOTREC+I;
      exit(READ_OLD_CAT);
    end;{if I=OLREC}
    I:=I+1;
    get(OCATFILE);
  end;{while (not eof(OCATFILE))}
  OREC:=I-1;
  OTOTREC:=OTOTREC+OREC;
  OFILEEND:=true
end;{READ_OLD_CAT}

procedure WRITECAT;  {writes NREC records to NCATFILE} 
var   I:RECNUM;
begin
  if NTOTREC=0 then with NCAT[0] do begin
    VOL_NAME:='       ';
    FILE_NAME:='               ';
    FILE_KIND:=UNTYPED;
    FILE_DATE.MONTH:=0;
    FILE_DATE.DAY:=0;
    FILE_DATE.YEAR:=0;
    FILE_SIZE:=0; 
    NCATFILE^:=NCAT[0];
    PUT(NCATFILE);
  end;{if NTOTREC=0}
  writeln;
  write('Writing CATALOG to disk');
  for I:=1 to NREC do begin 
    NCATFILE^:=NCAT[I];
    PUT(NCATFILE);
    write('.');
  end;{for I}
  writeln;
  NTOTREC:=NTOTREC+NREC;
  NREC:=0;
if DONE then close(NCATFILE,LOCK)
end;{WRITECAT}

procedure TITLE;   
var   S:string;
      I,J:integer;
begin 
  S:='UCSD PASCAL CATALOG';  
  PRINTAT(37-length(S) div 2,0,S); 
  S:='written by';
  PRINTAT(37-length(S) div 2,1,S); 
  S:='E. J. Heyman';
  PRINTAT(37-length(S) div 2,2,S); 
  S:='Centerville, DL'; 
  PRINTAT(37-length(S) div 2,3,S);   
  S:='first published in';
  PRINTAT(37-length(S) div 2,9,S);   
  S:='BYTE Magazine May 1981'; 
  PRINTAT(37-length(S) div 2,10,S); 
  S:='and extensively modified by'; 
  PRINTAT(37-length(S) div 2,11,S); 
  S:='R. M. Wilson'; 
  PRINTAT(37-length(S) div 2,12,S); 
  S:='HI-COUNTRY DATA SYSTEMS';  
  PRINTAT(37-length(S) div 2,13,S);  
  S:='P.O. Box 4258';  
  PRINTAT(37-length(S) div 2,14,S);    
  S:='Woodland Park, CO 80863-4258'; 
  PRINTAT(37-length(S) div 2,15,S);    
  S:='May 7, 1981';  
  PRINTAT(37-length(S) div 2,16,S);    
end; {TITLE} 


========================================================================================
DOCUMENT :usus Folder:VOL10:catalog.text
========================================================================================

(*$L-#6:*)
{************************************************************************
*                                                                       *
*  This program is filed as CATALOG.TEXT                                *
*                                                                       * 
************************************************************************}



{  

        program title:          CATALOG
        written by:             R. M. Wilson 
        date written:           7 May 1981
        written for:            HI-COUNTRY DATA SYSTEMS
                                        and
                                WESTERN SOFTWARE DEVELOPMENT
        
        program function:       To provide a central catalog for the many
                                files on the various disks.
        
        remarks:                This is an extensively modified version of  
                                the program by Edward Heyman, 300 Center Hill
                                Rd., Centerville, DL. 19807, published in the 
                                May 1981 issue of "BYTE" magazine. There were
                                MANY serious bugs in the original program.
                                These have been corrected and the program
                                works very well!!!!!
                                
                                Well, almost very well.  Some more things
                                have been fixed, such as allowing lower case
                                input and some kludges to get it to work 
                                under IV.0 on my LSI-11.   I also changed
                                a value in the main record to allow disks
                                with more that 988 blocks.  - gws
        

            This program is furnished to the USUS group for unrestricted 
            personal use.  Use of this program for commercial purposes  
            is strictly prohibited.  
     
     Obligitory message from BYTE  (message added by gws)
     
     From CATALOG by Edward Heyman appearing in the May 1981 issue of Byte
     magazine.  Copyright 1981 Byte Publications, Inc.  Used with the 
     permission of Byte Publications, Inc.  

     Note that if you had used CATALOG as it appeared in BYTE, your database
     is still valid at, at least mine worked. gws}   

program CATALOG;

procedure dummy;
{this kludge is necessary under IV.0 to allow the system to allocate
 the global data.  It will not affect the operation under II.0.  gws}

const BLANKS='                  ';
      MAXREC=300 {400};       {may have to reduce for different computer}
      MAXREC_1=301 {401};     {may have to reduce for different computer}
      {I had to reduce these because of a STACK OVERFLOW! - gws}
      NFILENAME='#5:MASTCAT.DATA';
      OFILENAME='#5:BACKCAT.DATA';
      PFILENAME='#5:CAT.POINT.DATA';
      
type  DATE_RECORD=packed record
                    MONTH:0..12;
                    DAY:0..31;
                    YEAR:0..100
                  end;
      SETOFCHAR=set of char;  {for function READKEY}
      ACTIVITY=string[26];
      DIR_SIZE=0..77;
      VOL_ID=string[7];
      FILE_ID=string[15];
      FILE_TYPE=(UNTYPED,XDISK,CODE,TEXT,INFO,DATA,GRAF,FOTO,SECUREDIR);
      DIR_RECORD=record
                   FIRST_BLOCK:integer;
                   LAST_BLOCK:integer;
                   case DIR_FILE_KIND:FILE_TYPE of
                     SECUREDIR,UNTYPED:(DIR_VOL_NAME:VOL_ID;
                                        ZERO_BLOCK,
                                        NUM_OF_FILES,
                                        TOTAL_BLOCKS:integer;
                                        LAST_BOOT:DATE_RECORD);
                     XDISK,CODE,TEXT,INFO,DATA,GRAF,FOTO:
                                       (DIR_FILE_NAME:FILE_ID;
                                        LASTBYTE:1..512;
                                        DIR_FILE_DATE:DATE_RECORD)
                 end;
                 
      CATALOG_RECORD=packed record
                       VOL_NAME:VOL_ID;
                       FILE_NAME:FILE_ID;
                       FILE_KIND:FILE_TYPE;
                       FILE_DATE:DATE_RECORD;
                       FILE_SIZE:0..{988}maxint; {allow for big disk - gws}
                     end;
                     
      DIRECTORY=array[DIR_SIZE] of DIR_RECORD;
      CATARRAY=array[0..MAXREC] of CATALOG_RECORD;
      FILEN=string[20];
      RECNUM=0..MAXREC_1;
      INDEX='A'..'Z';
      INDEX_ARRAY=array[INDEX] of integer;
      
var   NREC,NLREC,OREC,OLREC,DREC,DLREC:RECNUM;
      NTOTREC,OTOTREC:0..2047;
      LEAVE,REMOV,NFILEEND,OFILEEND,DONE:boolean;
      CH:char;
      DEX:INDEX;
      DEXRAY:INDEXARRAY;
      P:file of char;  {used to swithch from console to printer} 
      VOL:VOL_ID;
      BOOT_VOL,TEST:string; 
      CATFILE,OCATFILE,NCATFILE:file of CATALOG_RECORD; 
      NCAT,OCAT:CATARRAY;
      
procedure CLEARSCREEN;forward; 
procedure make_upper ( var strg : string ); forward;
function READKEY(OKSET:SETOFCHAR):CHAR;forward;
procedure PRINTAT(X,Y:INTEGER;S:STRING);forward;
function YES:BOOLEAN;forward;
procedure SPACEBAR;forward;
procedure MEM(PN:string);forward;
procedure QUIT;forward;
procedure WRITECAT;forward;
procedure READ_OLD_CAT;forward;
procedure READ_NEW_CAT;forward; 
procedure PRINT_RECORD(CAT1:CATALOG_RECORD);forward;
procedure PRINT_KIND(FILE_KIND:FILE_TYPE);forward;
procedure PRINT_DATE(REC:DATE_RECORD);forward;
procedure ENTER_VOL_NAME;forward;
procedure READDEX;forward; 
function LOOKUP(FN:FILEN):boolean;forward; 

procedure INITIALIZE;
var   I:RECNUM;
      DEXFILE:file of INDEXARRAY;
begin
  MEM('INITIALIZE');
  if (not LOOKUP(NFILENAME)) then begin
    writeln(chr(7),'There is no file named ',NFILENAME,' on this disk'); 
    write('Do you want to create a ',NFILENAME,'?  ');
    if not YES then begin
      LEAVE:=true;
      exit(INITIALIZE)
    end;{if not YES}
    writeln;
    writeln('Filling array[0]'); 
    with NCAT[0] do begin 
      VOL_NAME:='       ';
      FILE_NAME:='               ';
      FILE_KIND:=UNTYPED;
      FILE_DATE.MONTH:=0;
      FILE_DATE.DAY:=0;
      FILE_DATE.YEAR:=0;
      FILE_SIZE:=0;
    end;{with NCAT[0]}
    for I:=1 to MAXREC do NCAT[I]:=NCAT[0];
    writeln('Array is filled  ');
    rewrite(CATFILE,NFILENAME);
    for I:=0 to MAXREC do begin
      CATFILE^:=NCAT[I];
      PUT(CATFILE)
end;{for I}
    CLOSE(CATFILE,LOCK)
  end {if (not LOOKUP(NFILENAME))}
  else writeln('The file ',NFILENAME,' already exists on this volume  ');
  writeln;
  if not LOOKUP(PFILENAME) then begin
    writeln(chr(7),'There is no file named ',PFILENAME,' on this disk  '); 
    writeln('Do you want to create a ',PFILENAME,'?  ');
    if not YES then begin
      LEAVE:=true;
      exit(INITIALIZE)
    end;{if not YES}
for DEX:='A' to 'Z' do DEXRAY[DEX]:=0; 
    rewrite(DEXFILE,PFILENAME);
    DEXFILE^:=DEXRAY;
    PUT(DEXFILE);
    CLOSE(DEXFILE,LOCK);
    writeln(PFILENAME,' written to disk')
  end {if not LOOKUP(PFILENAME)}
  else writeln('File ',PFILENAME,' exists  ');
  SPACEBAR;
end;{INITIALIZE}

procedure make_upper (*var strg : string*); {upper case conversion  - gws}
var qq : integer;
begin
  if length ( strg ) > 0 then  
     for qq := 1 to length ( strg ) do
        if strg [ qq ] in [ 'a' .. 'z' ] then
           strg [ qq ] := chr ( ord ( strg [ qq ] ) - 32 );
end;

procedure DISPLAY;  {writes the entire MASTCAT.DAT file to the console} 
var   I:RECNUM;
      HARDCOPY:boolean;
begin
  HARDCOPY:=false;
  CLEARSCREEN;
  write('Searching for CATALOG...'); 
  if (LOOKUP(NFILENAME)) then begin 
    writeln;
    gotoxy(0,12);
    write(chr(8),chr(27),chr(108));
    write('Select desired option...',chr(27),chr(109));
    writeln;
    writeln;
    writeln('1--> output to CRT');
    writeln;
    write('2--> output to PRINTER  ');
    CH:=READKEY(['1','2']);
    CLEARSCREEN; 
    if CH='1' then rewrite(P,'CONSOLE:')
    else begin
      rewrite(P,'printer:');
      PRINTAT(0,12,'Sending entire CATALOG to PRINTER...  '); 
      for I:=1 to 5 do writeln(P); 
      HARDCOPY:=true 
    end;{else} 
    NREC:=0; 
    reset(NCATFILE,NFILENAME); 
    repeat
      READ_NEW_CAT;
      for I:=1 to NREC do begin
        PRINT_RECORD(NCAT[I]);
        if (I mod 20=0) and not HARDCOPY then begin 
          SPACEBAR;
          CLEARSCREEN
        end {if} 
      end;{for I}
    until NFILEEND; 
    close(NCATFILE);
  end {if (LOOKUP(NFILENAME))}
  else writeln(NFILENAME,' not present');
  writeln;
  if HARDCOPY then writeln(P,'MASTCAT contains ',NTOTREC,' records')
  else writeln('MASTCAT contains ',NTOTREC,' records'); 
  close(P); 
  if not HARDCOPY then SPACEBAR; 
end;{DISPLAY}

procedure BACKUP;
{compares file names & reports files without backups} 
var   HARDCOPY,PASS,UNBACK:boolean; 
      CH:char;
      I,C,N:RECNUM; 
begin
  PASS:=false;
  UNBACK:=false;
  HARDCOPY:=false;
  CLEARSCREEN;
  write('Searching for CATALOG...');
  if (LOOKUP(NFILENAME)) then begin
    gotoxy(0,12);
    write(chr(8),chr(27),chr(108));
    write('Select desired option...',chr(27),chr(109));
    writeln;
    writeln;
    writeln('1--> output to CRT');
    writeln;
    write('2--> output to PRINTER  ');
    CH:=READKEY(['1','2']);
    CLEARSCREEN; 
    if CH='1' then rewrite(P,'CONSOLE:') 
    else begin
      rewrite(P,'printer:');
      PRINTAT(0,12,'Sending backup data to PRINTER...  '); 
      for I:=1 to 5 do writeln(P); 
      writeln(P,'The following files are not backed up...');
      writeln(P);
      HARDCOPY:=true
    end;{else} 
    C:=0; 
    if not HARDCOPY then writeln('The following files are not backed up...');
    reset(NCATFILE,NFILENAME); 
    repeat
      READ_NEW_CAT; 
      if (PASS and UNBACK) then 
        if (NCAT[0].FILE_NAME<>NCAT[1].FILE_NAME) then begin
          PRINT_RECORD(NCAT[0]);
          C:=C+1;
          if (C mod 20=0) and not HARDCOPY then begin 
            SPACEBAR;
            CLEARSCREEN
          end {if} 
      end;{if (NCAT[0].FILE_NAME<>NCAT[1].FILE_NAME)}
      for N:=1 to NREC-1 do 
        if ((NCAT[N].FILE_NAME<>NCAT[N-1].FILE_NAME) and
          (NCAT[N].FILE_NAME<>NCAT[N+1].FILE_NAME)) then begin
            PRINT_RECORD(NCAT[N]);
            C:=C+1; 
            if (C mod 20=0) and not HARDCOPY then begin 
              SPACEBAR;
              CLEARSCREEN
            end {if} 
        end;{if((NCAT[N]>FILE}
      PASS:=true;
      if not NFILEEND and (NCAT[NREC].FILE_NAME<>NCAT[NREC-1].FILE_NAME) 
        then UNBACK:=true
        else UNBACK:=false;
      NCAT[0]:=NCAT[NREC]; 
      if NFILEEND then begin 
        if NCAT[NREC].FILE_NAME<>NCAT[NREC-1].FILE_NAME then begin
          PRINT_RECORD(NCAT[NREC]); 
          C:=C+1;
          if (C mod 20=0) and not HARDCOPY then begin 
            SPACEBAR;
            CLEARSCREEN
          end {if} 
        end {if}
      end;{if NFILEEND}
    until NFILEEND;
    close(NCATFILE);
  end {if (LOOKUP(NFILENAME))}
  else writeln('CATALOG not present  '); 
  close(P);
  if not HARDCOPY then SPACEBAR; 
end;{BACKUP}

procedure UPDATE;
var   DCAT:array[DIR_SIZE] of CATALOG_RECORD;
      RN:RECNUM;
      
procedure RENAME;  {changes name of MASTCAT.DATA to BACKCAT.DATA}
var   I:integer;
      SPS:string[16];
      VOL,AVOL:VOL_ID;
      DIR:DIRECTORY;
begin
  unitread(5,DIR[0],2048,2);
  VOL:=DIR[0].DIR_VOL_NAME;
  SPS:=COPY(BLANKS,1,7-length(VOL));
  AVOL:=concat(VOL,SPS);
for I:=1 to DIR[0].NUM_OF_FILES do 
    with DIR[I] do begin
      if (DIR_FILE_NAME='MASTCAT.DATA') then DIR_FILE_NAME:='BACKCAT.DATA';
    end;{with DIR[I]}
  unitwrite(5,DIR[0],2048,2);
end;{RENAME}
    
procedure WRITEDEX;
{writes a file of pointers to the first occurrence of each letter in the 
 alphabet}
var   DEXFILE:file of INDEXARRAY;
begin
  rewrite(DEXFILE,PFILENAME);
  DEXFILE^:=DEXRAY;
  put(DEXFILE);
  close(DEXFILE,LOCK);
end;{WRITEDEX}

(*$I catalog.1.text*)
(*$I catalog.2.text*)

begin  {dummy} {MAIN PROGRAM}  
  CLEARSCREEN;
  TITLE;
  SPACEBAR;
  CLEARSCREEN;
  MEM('MAIN');
  LEAVE:=false;
  if ((not LOOKUP(NFILENAME)) or (not LOOKUP(PFILENAME))) then begin
    PRINTAT(0,11,'Insert disk with CATALOG files on it into drive #5:  ');
    SPACEBAR;
    CLEARSCREEN;
    if ((not LOOKUP(NFILENAME)) or (not LOOKUP(PFILENAME))) then INITIALIZE; 
  end;{if}
  if LEAVE then exit(program); 
  writeln;
  CLEARSCREEN;
  DLREC:=MAXREC; 
  OLREC:=MAXREC; 
  NLREC:=MAXREC;
  READDEX;  {load the pointer array} 
  repeat
    REMOV:=false;
    NFILEEND:=false;
    OFILEEND:=false;
    DONE:=false;
    NREC:=0; 
    OREC:=0; 
    DREC:=0; 
    NTOTREC:=0;
    OTOTREC:=0;
    VOL:='       ';
    CLEARSCREEN; 
    {MEM('MAIN');}
    write('Catalog: S)earch D)isplay B)ackup U)pdate R)emove Q)uit  '); 
    CH:=READKEY(['S','D','B','U','R','Q','s','d','b','u','r','q']);
    CLEARSCREEN; 
    case CH of 
      'U','u':UPDATE;
      
      'S','s':SEARCH;
      
      'D','d':DISPLAY;
      
      'R','r':begin 
                REMOV:=true;
                ENTER_VOL_NAME; 
                UPDATE 
              end;
      
      'B','b':BACKUP;
      
      'Q','q':begin
                CLEARSCREEN;
                PRINTAT(0,12,
                    'Ensure that the "boot disk" is in the correct drive.');
                PRINTAT(0,14,'If it is not, the system will CRASH!!!');
                SPACEBAR;
                QUIT
              end;
      
    end;{case CH}
  if LEAVE then exit(program);
  until false
end;

begin
   dummy
end.



========================================================================================
DOCUMENT :usus Folder:VOL10:kruskal.1.text
========================================================================================

(* included from kruskal.text*)

procedure UNION(I,J:integer);
(************************************************************************ 
*                                                                       * 
*                                                                       * 
*  This procedure takes two disjointed sets and joins them.  procedure  *   
*  FIND must be used to find the parent nodes for the disjoined sets.   *
*  Each parent or root node "parent value" has a negative number which  * 
*  represents the number of elements in that set.                       *
*                                                                       * 
*  For example if we have an element J calling FIND(J) will return      * 
*  the value of the root node (i.e. which node in the array is the root *
*  node for the set in J is contained).  The array "PARENT" is used to  *
*  indicate which elements are in which sets.  If I,J,K,L,M are all     * 
*  elements in "X" such that X={I,J,K,L,M,...} then PARENT(I),          *
*  PARENT(J), PARENT(K), etc will all have the same value X.  PARENT(X) * 
*  will have a negative number which indicates the number of set        *
*  elements.                                                            *
*                                                                       * 
*  In "procedure KRUSKAL" the array "PARENT" is initialized so that     *
*  each slot = -1.  (That way each node is in its own set of size 1.)   *
*  The first line in "UNION" determines what the size of the new set    *
*  will be.                                                             * 
*                                                                       *
*  Next the smaller set is determined so that the union may be pre-     * 
*  formed more efficiently  (shade of a greedy algorithm!!).            *
*                                                                       * 
*  Then the smaller set is joined to the larger set by setting the      * 
*  value of the root node of the smaller set to the location of the     *
*  root node of the larger set.                                         *
*                                                                       * 
*  Last the value of the larger root node is set to the negative value  *
*  equal to the number of elements in the new set.                      * 
*                                                                       * 
*  It should be noted that another way of doing this which would allow  *
*  for more efficient determinations of the inclusion of an element in  *
*  a given set would be to set the value of "PARENT" of each set member *
*  to the location of the root node.                                    *
*                                                                       *
*                                                                       *
************************************************************************)
var  X:integer; 
begin
  X:=PARENT[I] + PARENT[J];
  if TRACEOPTION then begin
    if HARDCOPY or BOTH then begin
      writeln(PRINTER);
      writeln(PRINTER,'UNION(',I,',',J,')'); 
      writeln(PRINTER,'PARENT[',I,']=',PARENT[I]);
      writeln(PRINTER,'PARENT[',J,']=',PARENT[J]);
      writeln(PRINTER,'X=',X);
      end;{if HARDCOPY or BOTH}
    if CRT or BOTH then begin
      writeln;
      writeln('UNION(',I,',',J,')');
      writeln('PARENT[',I,']=',PARENT[I]); 
      writeln('PARENT[',J,']=',PARENT[J]);
      writeln('X=',X);
    end;{if CRT or BOTH}
  end;{if TRACEOPTION} 
  if PARENT[I]>PARENT[J] then begin 
    PARENT[I]:=J;
    PARENT[J]:=X
  end 
  else begin
    PARENT[J]:=I;
    PARENT[I]:=X; 
  end;
  if TRACEOPTION then begin
    if HARDCOPY or BOTH then begin
      writeln(PRINTER,'PARENT[',I,']=',PARENT[I]); 
      writeln(PRINTER,'PARENT[',J,']=',PARENT[J]);
      writeln(PRINTER,'X=',X);
    end;{if HARDCOPY or BOTH}
    if CRT or BOTH then begin
      writeln('PARENT[',I,']=',PARENT[I]); 
      writeln('PARENT[',J,']=',PARENT[J]);
      writeln('X=',X);
      SPACEBAR;
      writeln;
    end;{if CRT or BOTH} 
  end;{if TRACEOPTION} 
end;{UNION} 

procedure FIND(I:integer;var L:integer); 
{************************************************************************ 
*                                                                       * 
*  This procedure uses the technique of "collasping" the tree to the    *
*  root node.  In plain english since the value of all roots nodes is   *
*  <0, it examines the value of each parent until it finds a negative   * 
*  value and thus the root node of the element in question has been     * 
*  found.                                                               *
*                                                                       * 
*  The most important part of the procedure is the first while loop.    *
*  A quick examination will reveal the loop repeats until PARENT(J)<0   *
*  at which time the loop is terminated an "J" is the value of the      * 
*  location of the root node of the set/element.                        *
*                                                                       *
*  The second while loop sets the value of PARENT(<element>) to the     * 
*  location of the set root for all elements in the set above element   *
*  "J" to the location of the root node.  (see comments for "UNION")    *
*                                                                       * 
************************************************************************}
var J,K,TEMP:integer; 
begin
  if TRACEOPTION and (HARDCOPY or BOTH) then write(PRINTER,'FIND(',I,')='); 
  if TRACEOPTION and (CRT or BOTH) then write('FIND(',I,')=');
  J:=I;
  while PARENT[J]>0 do J:=PARENT[J];
  K:=I;
  while K<>J do begin
    TEMP:=PARENT[K];
    PARENT[K]:=J;
    K:=TEMP;
  end;{while}
  L:=J;
  if TRACEOPTION then begin
    if HARDCOPY or BOTH then writeln(PRINTER,L); 
    if CRT or BOTH then writeln(L);
  end;{if TRACEOPTION}
end;{FIND} 

procedure ADJUST(I,ARRAYSIZE:integer);
{************************************************************************
*                                                                       * 
*  This along with HEAPIFY produces a low to high HEAP                  *
*                                                                       * 
************************************************************************}
label 1;
var  J:integer;
     ITEM:PRICE; 
begin 
  J:=2*I;
  if TRACEOPTION then begin
    if HARDCOPY or BOTH then begin
      writeln(PRINTER,'ADJUST(',I,',',ARRAYSIZE,')'); 
      writeln(PRINTER,'J=',J,'   ARRAYSIZE=',ARRAYSIZE); 
    end;{if HARDCOPY or BOTH}
    if CRT or BOTH then begin
      writeln('ADJUST(',I,',',ARRAYSIZE,')');
      writeln('J=',J,'   ARRAYSIZE=',ARRAYSIZE); 
      {SPACEBAR;}
      writeln;
    end;{if CRT or BOTH} 
  end;{if TRACEOPTION} 
  ITEM:=COST[I]; 
  while (J<=ARRAYSIZE) do begin
    if (J<ARRAYSIZE) and (COST[J].HOWMUCH>COST[J+1].HOWMUCH) then J:=J+1;
    if ITEM.HOWMUCH >=COST[J].HOWMUCH then begin
      COST[J div 2]:=COST[J];
      J:=J*2;
    end {if}
    else goto 1 
  end;{while} 
1:COST[J div 2]:=ITEM;
end;{ADJUST}

procedure HEAPIFY(ARRAYSIZE:integer);
var  I:integer;
begin
  if HARDCOPY or BOTH then begin
    writeln(PRINTER);
    writeln(PRINTER,'HEAPIFY(',ARRAYSIZE,')');
    writeln(PRINTER);
  end;
  if CRT or BOTH then begin
    writeln;
    writeln('HEAPIFY(',ARRAYSIZE,')'); 
    SPACEBAR;
    writeln;
  end; 
  for I:=((ARRAYSIZE*ARRAYSIZE) div 2) downto 1 do
    ADJUST(I,ARRAYSIZE*ARRAYSIZE);
end;{HEAPIFY}

procedure PRINTHEAP; 
var  I:integer;
begin
  I:=1;
  while COST[I].EDGE[1]<>0 do begin
    if HARDCOPY or BOTH then begin
      writeln(PRINTER,'COST[',I,'].HOWMUCH=',COST[I].HOWMUCH); 
    end;{if HARDCOPY or BOTH}
    if CRT or BOTH then begin
      writeln('COST[',I,'].HOWMUCH=',COST[I].HOWMUCH);
    end;{if CRT or BOTH}
    I:=I+1;
  end;{while}
  if CRT or BOTH then begin
    SPACEBAR;
    writeln;
  end;{if CRT or BOTH}
  if HARDCOPY or BOTH then begin 
    writeln(PRINTER);
  end;{if HARDCOPY or BOTH}
end;{PRINTHEAP}

procedure KRUSKAL(var COST:A1;ARRAYSIZE:integer;var T:A2;var MINCOST:integer); 
var  I,J,K,L,R,U,V:integer; 
     NODE:PRICE;{this is used rather than COST[I] to ensure it is not
                   inadvertently changed}
begin 
  if TRACEOPTION then PRINTHEAP;
  HEAPIFY(ARRAYSIZE);
  if TRACEOPTION then PRINTHEAP;
  CLEARSCREEN;
  if DETAIL then EXAMINE;
  for I:=1 to ARRAYSIZE do PARENT[I]:=-1;
  I:=0;
  MINCOST:=0;
  L:=ARRAYSIZE*ARRAYSIZE;
  for R:=L downto 2 do begin
    while (I<ARRAYSIZE-1) and (L<>0) do begin 
{************************************************************************
*                                                                       * 
*  The next three lines remove the edge with the smallest cost, replace *
*  it with one of infinite value (i.e. one which does not exist), and   * 
*  then forms a new "low-high" heap with the lowest cost on top.        *
*                                                                       *
************************************************************************}
      NODE:=COST[1]; 
      COST[1]:=COST[L];
      if TRACEOPTION then begin
        CLEARSCREEN;
        with NODE do begin 
          if HARDCOPY or BOTH then begin
            writeln(PRINTER);
            writeln(PRINTER,'...NODE...');
            writeln(PRINTER,'EDGE[1] = ',EDGE[1]); 
            writeln(PRINTER,'EDGE[2] = ',EDGE[2]);
            writeln(PRINTER,'HOWMUCH = ',HOWMUCH);
          end;{if HARDCOPY or BOTH}
          if CRT or BOTH then begin
            writeln;
            writeln('...NODE...');
            writeln('EDGE[1] = ',EDGE[1]);
            writeln('EDGE[2] = ',EDGE[2]); 
            writeln('HOWMUCH = ',HOWMUCH);
            SPACEBAR; 
            writeln;
          end;{if CRT or BOTH}
        end;{with NODE} 
        PRINTHEAP; 
      end;{if TRACEOPTION}
      ADJUST(1,L);
      if DETAIL then EXAMINE;
      if TRACEOPTION then PRINTHEAP; 
      with NODE do begin 
        {we determine the node ends of the edge}
        U:=EDGE[1]; 
        V:=EDGE[2];
        {we find the root nodes for each end node}
        FIND(U,J);
        FIND(V,K); 
        if J<>K then begin
        {if J=K then edge is already included in the solution set}
          I:=I+1; {increments the solution set to the next array slot}
          {we assign the edge to the solution set}
          T[I,1]:=U; 
          T[I,2]:=V;
          {we compute the cost for the solution to this point}
          MINCOST:=MINCOST+HOWMUCH; 
          if TRACEOPTION then begin
            if HARDCOPY or BOTH then begin
              writeln(PRINTER,'J=',J,'  K=',K,'  I=',I); 
              writeln(PRINTER,'T[',I,',1]=',T[I,1]);
              writeln(PRINTER,'T[',I,',2]=',T[I,2]);
              writeln(PRINTER,'MINCOST=',MINCOST);
            end;{if HARDCOPY or BOTH}
            if CRT or BOTH then begin
              writeln('J=',J,'  K=',K,'  I=',I);
              writeln('T[',I,',1]=',T[I,1]);
              writeln('T[',I,',2]=',T[I,2]);
              writeln('MINCOST=',MINCOST);
            end;{if CRT or BOTH}
          end;{if TRACEOPTION}
          {we join the nodes into a set}
          UNION(J,K); 
        end;{if J<>K}
      end;{with NODE} 
    end;{while} 
  end;{for R}
  if I<>ARRAYSIZE-1 then begin 
    CLEARSCREEN;
    PRINTAT(0,12,'NO SPANNING TREE'); 
    SPACEBAR;
    QUIT;
  end;{if I<>n-1}
end;{KRUSKAL} 

procedure INITIALIZE;
var  I:integer;
begin
  for I:=1 to 2500 do begin
    COST[I].PATH:=false;
    COST[I].EDGE[1]:=0;
  end;
end;{INITIALIZE} 

procedure TRACE;
var  CH:char;
begin
  CRT:=false;
  HARDCOPY:=false;
  BOTH:=false;
  CLEARSCREEN; 
  PRINTAT(0,12,'Do you want to trace the program?  ');
  if YES then begin
    TRACEOPTION:=true;
    PRINTAT(0,14,'Trace program on Printer, CRT or Both?  (P/C/B)  ');
    CH:=READKEY(['C','B','P','c','b','p']);
    case CH of
      'c','C':CRT:=true; 
      'b','B':BOTH:=true;
      'p','P':HARDCOPY:=true;
    end;{case}
    PRINTAT(0,16,'Trace program in detail?  (Y/N)'  );
    if YES then DETAIL:=true
    else DETAIL:=false;
  end {if YES} 
  else TRACEOPTION:=false; 
end;{TRACE}

procedure TITLE; 
var   S:string;
      I,J:integer;
begin 
  S:='MINIMUM SPAN KRUSKAL'; 
  PRINTAT(37-length(S) div 2,2,S); 
  S:='written by';
  PRINTAT(37-length(S) div 2,3,S); 
  S:='R. M. Wilson';
  PRINTAT(37-length(S) div 2,4,S); 
  S:='Copyright by';
  PRINTAT(37-length(S) div 2,13,S);
  S:='HI-COUNTRY DATA SYSTEMS';
  PRINTAT(37-length(S) div 2,15,S); 
  S:='P.O. Box 4258';
  PRINTAT(37-length(S) div 2,16,S); 
  S:='Woodland Park, CO 80863-4258';
  PRINTAT(37-length(S) div 2,17,S); 
  S:='March 1981'; 
  PRINTAT(37-length(S) div 2,18,S); 
end; {TITLE} 



========================================================================================
DOCUMENT :usus Folder:VOL10:kruskal.text
========================================================================================

{************************************************************************
*                                                                       *
*  This program is filed as KRUSKAL.TEXT                                *
*                                                                       * 
************************************************************************}



{ 

        program title:          Minimum Span Kruskal
        written by:             R. M. Wilson
                                HI-COUNTRY DATA SYSTEMS
        
        date written:           March 1981
        latest revision:        March 1981
        
        written for:            CS440 -- Design and Analysis of Algorithms
                                University of Colorado at Colorado Springs
                                Spring semester 1981
        
        
        program function:      
        ----------------
        
            This program is designed to determine the minimum spanning
            tree by the Kruskal algorithm.
                
        
        remarks:               
        -------
        
            This program is furnished to the USUS group for unrestricted
            personal or non-profit use.  Use of this program for commercial 
            purposes is authorized with the following restrictions:
    
              1--> Prior notification to and acknowledgement by the author
    
              2--> A message similar to the one below appears on the screen
                   upon execution and remains there until a key is hit.


*************************************************************************
*                                                                       *
*                                                                       *
*                                                                       *
*                                                                       *
*                                                                       *
*                      Program derived from KRUSKAL                     * 
*                              written by                               *
*                             R.M. Wilson                               *
*                        Hi-Country Data Systems                        *
*                            P.O. Box 4258                              *
*                        Woodland Park, CO 80863                        *
*                                                                       *
*                                                                       *
*                                                                       *
*                                                                       *
*                                                                       *
*                                                                       *
*                                                                       *
*                                                                       *
*                                                                       * 
*************************************************************************

}
{$G+} 
program MIN_SPAN_TREE_KRUSKAL; 

label 1;

const MAXNODE=50; 

type PRICE=record
             EDGE:packed array[1..2] of integer; 
             HOWMUCH:integer; 
             PATH:boolean;
           end;
{************************************************************************
*                                                                       *
*  I elected to use a record structure because I felt it would be       *
*  easier to keep track of the various variables relating to each node  *
*                                                                       * 
************************************************************************}
     A1=packed array[1..2500] of PRICE; {array[1..(MAXNODE*MAXNODE)} 
     A2=packed array[1..49,1..2] of integer; 
     A3=packed array[1..MAXNODE] of integer;
     SETOFCHAR=set of char;
     
var  COST:A1; 
     T:A2;
     ARRAYSIZE,MINCOST,I,J,K:integer;
     PARENT:A3;
     TRACEOPTION:boolean;
     HARDCOPY:boolean; 
     BOTH:boolean;
     CRT:boolean;
     PRINTER:interactive;
     DETAIL:boolean;
     CH:char;

     
procedure CLEARSCREEN;  {for Heath H-19}
begin 
  gotoxy ( 0, 0 );
  write(chr(27),chr(69));
end;

function READKEY(OKSET:SETOFCHAR):CHAR; 
{************************************************************************ 
*                                                                       * 
*  This procedure look at each keypress and determines if the key       * 
*  pressed is valid, i.e. the "set" of char which are valid may be      *
*  varied with each call of this procedure.  If the key pressed is      * 
*  not in the valid or 'OKSET', then the bell sounds.  If the key       *
*  pressed is valid the computer accepts the input and the program      * 
*  continues to run.                                                    * 
*                                                                       *
************************************************************************}
var CH:CHAR; 
    GOOD:boolean;
begin
  repeat
    read(KEYBOARD,CH); 
    if eoln(KEYBOARD) then CH:=chr(13);
    GOOD:=CH in OKSET;
    if not GOOD then write(chr(7))
  until GOOD;
  READKEY:=CH;
end;{READKEY}

procedure PRINTAT(X,Y:integer;S:string); 
{************************************************************************ 
*                                                                       *
*  This procedure writes a string at a designated location on the CRT   *
*                                                                       *
************************************************************************}
begin
  gotoxy(X,Y);
  write(S);
end;{PRINTAT}

function YES:boolean;
begin
  YES:=READKEY(['Y','y','N','n']) in ['Y','y'];
end;{YES}

procedure SPACEBAR;  { a technique to hold data/display on CRT }
var CH:CHAR;
begin
  gotoxy(22,23); 
  write('Hit "SPACE-BAR" to continue   <---');
  CH:=READKEY([' ']);
end;{SPACEBAR}

procedure QUIT;  {exit program} 
begin
  CLEARSCREEN;
  exit(program);
end;{QUIT}

procedure EXAMINE; 
begin
  CLEARSCREEN;
  I:=1;
  while COST[I].EDGE[1]<>0 do begin
    if HARDCOPY or BOTH then begin
      writeln(PRINTER); 
      writeln(PRINTER,'COST[',I,'].EDGE[1] = ',COST[I].EDGE[1]);
      writeln(PRINTER,'COST[',I,'].EDGE[2] = ',COST[I].EDGE[2]);
      writeln(PRINTER,'COST[',I,'].HOWMUCH = ',COST[I].HOWMUCH);
    end;{if HARDCOPY or BOTH}
    if CRT or BOTH then begin 
      writeln;
      writeln('COST[',I,'].EDGE[1] = ',COST[I].EDGE[1]); 
      writeln('COST[',I,'].EDGE[2] = ',COST[I].EDGE[2]);
      writeln('COST[',I,'].HOWMUCH = ',COST[I].HOWMUCH);
      SPACEBAR;
      writeln;
    end;{if CRT or BOTH} 
    I:=I+1; 
    if HARDCOPY or BOTH then begin
      writeln(PRINTER); 
    end;{if HARDCOPY or BOTH}
    if CRT or BOTH then writeln;
  end;{while}
end;{EXAMINE}

procedure INPUTCOST;
var  ROW,COL:integer;
begin
  CLEARSCREEN;
  PRINTAT(0,10,'Enter number of vertices in graph:  '); 
  readln(ARRAYSIZE);
  if (ARRAYSIZE<=0) or (ARRAYSIZE>MAXNODE) then QUIT;
                                       {prevents program blowup with out of 
                                        range data entry...does not prevent
                                        blowup if non numeric entry attempted} 
  I:=1; 
  for ROW:=1 to ARRAYSIZE do begin
    for COL:=ROW to ARRAYSIZE do begin
      if ROW<>COL then begin
        with COST[I] do begin
          EDGE[1]:=ROW;
          EDGE[2]:=COL;
          CLEARSCREEN;
          gotoxy(0,10); write('Is there a path from ',ROW,' to ',COL,' ?  ');
          if YES then begin
            PRINTAT(0,12,'(if "y" hit accidently, enter 32767)');
            gotoxy(0,14);
            write('Enter cost of path from ',ROW,' to ',COL,'--->  '); 
            readln(HOWMUCH);
            PATH:=true;
          end {if YES}
          else HOWMUCH:=32767;
        end;{with}
{************************************************************************
*                                                                       * 
*  The technique of echoing the duplicate edge in a non directed graph  *
*  immediately rather than waiting was used in the following 'with'     * 
*  statement because it works better with the record structure.         *
*                                                                       *
************************************************************************}
          with COST[I+1] do begin 
            EDGE[1]:=COL;
            EDGE[2]:=ROW;
            HOWMUCH:=COST[I].HOWMUCH;
            PATH:=true;
          end;{with}
          I:=I +2;
      end;{if ROW<>COL} 
    end;{for COL}
  end;{for ROW}
  for ROW:=1 to ARRAYSIZE do begin
    with COST[I] do begin 
      EDGE[1]:=ROW;
      EDGE[2]:=ROW;
      HOWMUCH:=32767;
      I:=I+1;
    end;{with}
  end;{for ROW}
  if DETAIL then EXAMINE;
end;{INPUTCOST} 

(*$I kruskal.1.text*)

begin  {MAIN PROGRAM}
  CLEARSCREEN;
  TITLE;
  SPACEBAR;
  CLEARSCREEN;
  rewrite(PRINTER,'printer:');
1:INITIALIZE; 
  TRACE;
  INPUTCOST;
  writeln;
  KRUSKAL(COST,ARRAYSIZE,T,MINCOST); 
  writeln;
  writeln('The minimum cost for a spanning tree is ',MINCOST); 
  writeln;
  writeln('The spanning tree is');
  writeln('--------------------');
  K:=1;
  for I:=1 to ARRAYSIZE-1 do begin
    write('[',T[I,K],',',T[I,K+1],']');
    writeln;
  end;{for I}
  SPACEBAR;
  CLEARSCREEN;
  PRINTAT(0,12,'Compute another minimum spanning tree?  ');
  if YES then begin
    CLEARSCREEN;
    goto 1
  end {if YES}
  else QUIT
end.{MIN_SPAN_TREE_KRUSKAL}




========================================================================================
DOCUMENT :usus Folder:VOL10:new.bfs.text
========================================================================================

{************************************************************************
*                                                                       *
*  This program is filed as NEW.BFS.TEXT                                *
*                                                                       * 
************************************************************************}



{

        program title:          New Breadth First Search
        written by:             R. M. Wilson
                                HI-COUNTRY DATA SYSTEMS
        
        date written:           April 2, 1981
        latest revision:        April 7, 1981
        
        written for:            CS440 -- Algorithm Analysis and Design
                                University of Colorado at Colorado Springs
                                Spring semester 1981
        
        
        program function:      
        ----------------
        
            This program is designed to test an improved breadth first
            search algorithm.
                
                
        
        remarks:             
        -------
        
            This is based on a program by Dr. Richard S. Wiener from an
            algorithm by Horowitz & Sahni in their book "Fundementals 
            of Computer Algorithms."
        
            This program is furnished to the USUS group for unrestricted 
            personal or non-profit use.  Use of this program for commercial
            purposes is authorized with the following restrictions:
    
              1--> Prior notification to and acknowledgement by the author
    
              2--> A message similar to the one below appears on the screen
                   upon execution and remains there until a key is hit.


*************************************************************************
*                                                                       *
*                                                                       *
*                                                                       *
*                                                                       *
*                                                                       *
*                     Program derived from BREADTHFS6                   *
*                              written by                               * 
*                             R.M. Wilson                               *
*                        Hi-Country Data Systems                        *
*                            P.O. Box 4258                              *
*                        Woodland Park, CO 80863                        *
*                                                                       *
*                                                                       *
*                                                                       *
*                                                                       *
*                                                                       *
*                                                                       *
*                                                                       *
*                                                                       *
*                                                                       * 
*************************************************************************

} 





{$g+}
program NEW_BREADTH_FIRST_SEARCH;

label 1; 

const MAX=512; 

type RARRAY=array[1..MAX] of integer; 
     SETOFINTEGER=set of 1..MAX; 
     SETOFCHAR=set of char;  {for function READKEY} 
     ACTIVITY=string[26];

var  G:packed array[1..MAX,1..MAX] of boolean;
     VISITED:packed array[1..MAX] of boolean; 
          {VISITED keeps track of the nodes visited}
     QUEUE:RARRAY; 
          {QUEUE keeps track of the queue of "unexpolored nodes"}
     FIRST,NEXT,N:integer;
     ALLNODES,CONNECTED:SETOFINTEGER; 
     

procedure CLEARSCREEN;  {for TeleVideo 920C}
begin 
  write(chr(26),chr(30));
end;

function READKEY(OKSET:SETOFCHAR):CHAR; 
{************************************************************************ 
*                                                                       * 
*  This procedure look at each keypress and determines if the key       * 
*  pressed is valid, i.e. the "set" of char which are valid may be      *
*  varied with each call of this procedure.  If the key pressed is      * 
*  not in the valid or 'OKSET', then the bell sounds.  If the key       *
*  pressed is valid the computer accepts the input and the program      * 
*  continues to run.                                                    * 
*                                                                       *
************************************************************************}
var CH:CHAR; 
    GOOD:boolean;
begin
  repeat
    read(KEYBOARD,CH); 
    if eoln(KEYBOARD) then CH:=chr(13);
    GOOD:=CH in OKSET;
    if not GOOD then write(chr(7))
  until GOOD;
  READKEY:=CH;
end;{READKEY}

procedure PRINTAT(X,Y:integer;S:string); 
{************************************************************************ 
*                                                                       *
*  This procedure writes a string at a designated location on the CRT   *
*                                                                       *
************************************************************************}
begin
  gotoxy(X,Y);
  write(S);
end;{PRINTAT}

function YES:boolean;
begin
  YES:=READKEY(['Y','y','N','n']) in ['Y','y'];
end;{YES}

procedure SPACEBAR;  { a technique to hold data/display on CRT }
var CH:CHAR;
begin
  gotoxy(22,23); 
  write('Hit "SPACE-BAR" to continue   <---');
  CH:=READKEY([' ']);
end;{SPACEBAR}

procedure QUIT;  {exit program} 
begin
  CLEARSCREEN;
  exit(program);
end;{QUIT}

procedure INITIALIZE;
var  I:integer;
begin
  FIRST:=0;{points to the first element in the queue}
  NEXT:=1;{points to the next element in the queue}
  for I:= 1 to MAX do begin
    VISITED[I]:=false;
    QUEUE[I]:=0;
  end;
end;{INITIALIZE}

(*procedure GRAPHINPUT;
{************************************************************************ 
*                                                                       * 
*  Test the worst case                                                  *
*                                                                       * 
************************************************************************}
var  ROW,COL:integer;
     AN:char;
begin
  CLEAR;
  PRINTAT(0,12,'How many nodes in the graph?  '); 
  readln(N);
  writeln;
  CLEAR;
  for ROW:=1 to N do 
    for COL:=1 to N do
      G[ROW,COL]:=false; 
  {the three lines that follow make up the worst case} 
  for COL:=1 to N-1 do G[1,COL]:=true; 
  for ROW:=2 to N-1 do G[ROW,N]:=true;
  G[N,1]:=true;
end;{INPUTGRAPH}*)

procedure GRAPHINPUT;
var  ROW,COL:integer;
     AN:char;
begin
  PRINTAT(0,12,'How many nodes in the graph?  ');
  readln(N);
  writeln;
  CLEARSCREEN;
  for ROW:=1 to N do 
    for COL:=1 to N do
      if ROW<>COL then begin
        gotoxy(0,12);
        write('Is there a path from node ',ROW,' to ',COL,'? (Y,N)'); 
        if YES then begin
          writeln;
          G[ROW,COL]:=true; 
        end {if YES}
        else G[ROW,COL]:=false; 
        writeln;
        CLEARSCREEN;
      end;{if ROW<>COL}
  for ROW:=1 to N do G[ROW,ROW]:=false;
end;{INPUTGRAPH}

procedure ADD_TO_QUEUE(I:integer;var QUEUE:RARRAY);
begin
  if FIRST=0 then first:=1;
  QUEUE[NEXT]:=I;
  NEXT:=NEXT+1;
end;{ADDTOQUEUE}

procedure DELETE_FROM_QUEUE(var I:integer;var QUEUE:RARRAY);
begin
  if FIRST=0 then begin
    FIRST:=1;
    exit(DELETE_FROM_QUEUE);
  end;{if FIRST}
  I:=QUEUE[FIRST];
  FIRST:=FIRST+1;
end;{DELETE_FROM_QUEUE}

procedure TEST(J:integer;var BAD:boolean);
var  I:integer; 
begin 
  I:=0; 
  repeat
    I:=I+1;
    if VISITED[I]=false then BAD:=true; 
  until (BAD) or (I=N);
  if BAD then begin
    CLEARSCREEN;
    gotoxy(0,12); 
    write('Graph is NOT connected from node ',J);
    SPACEBAR;
    QUIT
  end {if BAD} 
  else CONNECTED:=CONNECTED+[J]
end;{TEST} 

procedure BFS;
label 1,2;
var  I,J,T:integer;
     BAD:boolean;
     ROUTE:SETOFINTEGER;
begin 
  BAD:=false;{graph is connected}
  for J:=1 to N do begin
    if ALLNODES=CONNECTED then goto 2
    else if not (J in CONNECTED) then begin 
      INITIALIZE; 
      ROUTE:=[];
      T:=J; 
      VISITED[T]:=TRUE; 
      repeat 
        ROUTE:=ROUTE+[T];
        for I:=1 to N do begin
          if (I<>T) and (G[T,I]<>false) and (VISITED[I]=false) then begin
            ADD_TO_QUEUE(I,QUEUE); 
            VISITED[I]:=TRUE; 
            if I in CONNECTED then begin
              CONNECTED:=CONNECTED+ROUTE;
              ROUTE:=[];
              goto 1; 
            end;{if I in}
          end;{if} 
        end;{for I}
        if NEXT-FIRST=0 then TEST(J,BAD);
        DELETE_FROM_QUEUE(T,QUEUE); 
      until BAD or (NEXT-FIRST=-1);
    end;{if not (J in CONNECTED)}
1:end;{for J}
2:writeln; 
  writeln(chr(7),'End BFS...'); 
  writeln;
  if not BAD then write('Graph is connected');
end;{BFS} 

procedure TITLE; 
var   S:string;
      I,J:integer;
begin 
  S:='BREADTH FIRST SEARCH'; 
  PRINTAT(37-length(S) div 2,2,S); 
  S:='written by';
  PRINTAT(37-length(S) div 2,3,S); 
  S:='R. M. Wilson';
  PRINTAT(37-length(S) div 2,4,S); 
  S:='Copyright by';
  PRINTAT(37-length(S) div 2,13,S);
  S:='HI-COUNTRY DATA SYSTEMS';
  PRINTAT(37-length(S) div 2,15,S); 
  S:='P.O. Box 4258';
  PRINTAT(37-length(S) div 2,16,S); 
  S:='Woodland Park, CO 80863-4258';
  PRINTAT(37-length(S) div 2,17,S); 
  S:='April 7, 1981';
  PRINTAT(37-length(S) div 2,18,S); 
end; {TITLE} 

begin  {MAIN PROGRAM} 
  CLEARSCREEN;
  TITLE;
  SPACEBAR;
1:CLEARSCREEN;
  CONNECTED:=[];
  GRAPHINPUT;
  CLEARSCREEN; 
  SPACEBAR;
  gotoxy(0,10);
  write('Beginning BFS...',chr(7)); 
  BFS;
  SPACEBAR;
  CLEARSCREEN;
  PRINTAT(0,12,'Test another graph?  ');
  if YES then goto 1;
  QUIT;
end.


========================================================================================
DOCUMENT :usus Folder:VOL10:person.data
========================================================================================

< binary file -- not listed >

========================================================================================
DOCUMENT :usus Folder:VOL10:vol10.doc.text
========================================================================================

                                 USUS Volume 10
                This disk contains the submissions of Bob Wilson
                                        
BTRE.FILE.TEXT    30   This file contains the main program and the 
                        documentation for the B-tree program.  
BTREE.STD.TEXT     8      an include file
BTREE.DCLR.TEXT   10 
BTREE.INIT.TEXT   12 
BTREE.GET.TEXT    28 
BTRE.FIND1.TEXT   22 
BTRE.FIND2.TEXT   22 
BTREE.DEL1.TEXT   22 
BTREE.DEL2.TEXT   32 
BTREE.PRNT.TEXT   26 
BTREE.DOIT.TEXT   30      the last include file
BENCHMARK.TEXT    28   Jon Bondy's benchmark with some added goodies
BENCHMARK1.TEXT   18      an include file 
NEW.BFS.TEXT      22   This is interesting, but I don't know what it is!
KRUSKAL.TEXT      22      ditto
KRUSKAL.1.TEXT    28        an include file
CATALOG.TEXT      26   This is an improved version of the disk archiver which
                             was published in the May '81 Byte
CATALOG.2.TEXT    10      an include file
CATALOG.1.TEXT    24        ditto
VOL10.DOC.TEXT    10   You're reading it
20/20 files<listed/in-dir>, 436 blocks used, 58 unused, 58 in largest

__________________________________________________________________________

Please transfer the text below to a disk label if you copy this volume.

    USUS Volume 10 -***- USUS Software Library
                         
   For not-for-profit use by USUS members only.
  May be used and distributed only according to 
      stated policy and the author's wishes.



This volume was assembled by George Schreyer from material collected by
the Library committee.

__________________________________________________________________________

Notes on the programs on this disk

                                     BTREE

     The Btree program on this disk in an example of a btree implementation. 
It is also a demo address list database although the demo is trivial.  There
was a program called ADDRESS on the first release of this disk, but it has
been omitted when I discovered that it was just an early version of BTREE.

                                   BENCHMARK

     This is Jon Bondy's benchmark with some added functions.  This benchmark 
is particularly interesting because it shows you quite graphically which p-
system constructs take the most time.  One that isn't here is long integer 
operations which can run VERY slowly.  A 36 digit long integer divide can run 
as slow as 4 per second on an LSI-11.  Also some of the results of string 
operations are highly dependant on the data being processed, so beware.  POS 
runs particularly slowly when there are several occurances of part of the
first operand in the second operand such as:

     pos ( 'ab', 'aaaaaaaaaaaaaaaaaaaaab' );

                              KRUSKAL and NEW.BFS

     I'll be damned if I know what these are, they solve some algorithm which 
is way over my head.

                                    CATALOG

     This is a handy disk archiver program which first appeared in the May '81 
issue of Byte.  It is published here with the permission of both the author 
and Byte Publications.  Bob Wilson reworked it as the original was reputed to 
have several serious bugs.  I have worked over Bob's version as I couldn't get 
it to work on my hard disk and it had some other additional problems.  If you 
have used the original, your database will still work, but a database which 
you generate with this version may generate value range errors if used with 
the original version.


========================================================================================
DOCUMENT :usus Folder:VOL11:bjack.1.text
========================================================================================

          WRITE('HOUSE LIMIT IS $200.. BET PLEASE ? ');
          READLN(BET);
        UNTIL (0<BET) AND (BET<201);
      END
     ELSE
      BEGIN
         WRITE('                  STILL BET  $',BET,'? (y/n)');
         READ(C);
         IF C='N' THEN BET:=0;
      END
   UNTIL ((0<BET) AND (BET<201)) 
  END;
  (*$I+*)
END; {PLAYERIN}

PROCEDURE SHOHOLE;
 VAR CN:INTEGER;
 BEGIN
  GOTOXY(XHOLE,YHOLE);
  CN:=YHOLE-YHAND0;
  WRITE(CN:3,')',HOLRANK:6,' OF ',HOLSUIT);
  IF NOT SHUFFLED_SINCE_HOLCARD THEN 
     BEGIN
       HOLCARD:=TRUE;
       {TENCOUNT;}
     END;
 END; {SHOHOLE}
 
 PROCEDURE CHKPAIR;
  BEGIN
   Q:=Q+1;
   IF (FSTCARD=RANK) AND (Q=3) THEN PAIR:=TRUE;
   IF (Q=1) THEN
    BEGIN
    FSTCARD:=RANK;
    FIRSTCARD:=CARD;
    END;
   IF Q=3 THEN
    BEGIN
     THIRDCARD:=CARD;
    END;
  END;
   
PROCEDURE DEAL;
 BEGIN
  REPEAT
    IF CARDSLEFT=0 THEN SHUFFLE;
    CARD:=DECK[CARDSLEFT];
    IF CARD_NOT_IN_DECK[CARD] THEN COUNTERFIX;
    CARDSLEFT:=CARDSLEFT-1;
  UNTIL CARD_NOT_IN_DECK[CARD]=FALSE;
  CARD_ON_TABLE[CARD]:=TRUE;
  RANSUIT(CARD);
  CHKPAIR;
  NAMECARD;
  IF PERSON=PLAYER THEN HANDSIZE[1]:=HANDSIZE[1]+1;
    IF PERSON=DEALER THEN HANDSIZE[2]:=HANDSIZE[2]+1;
  IF SPLITHAND THEN HANDSIZE[3]:=HANDSIZE[3]+1;
 END; {DEAL}

PROCEDURE DEAL2;
 VAR
   C:INTEGER;
 BEGIN
  FOR C:=1 TO 2 DO
   BEGIN
    FOR PERSON:=PLAYER TO DEALER DO
     BEGIN
      DEAL;
      SCORE;
      IF (C=2) AND JUST_SHUFFLED THEN
        SHUFFLED_SINCE_HOLCARD:=TRUE;
      IF (PERSON=DEALER) AND (C=1) THEN NOSHOW
      ELSE 
        BEGIN
          SHOWHAND;
          {TENCOUNT;}
        END;
      IF (C=2) AND (PERSON=DEALER) AND (RANK=1) THEN ACEUP:=TRUE
     END; {PERSON}
  END; {FOR}
 END; {DEAL2}
 
PROCEDURE TEST21;
 BEGIN
  IF (HANDVAL[1]=21) OR (HANDVAL[2]=21) THEN
   BEGIN
    BJACK:=TRUE;
    SHOHOLE;
    IF HANDVAL[1]=HANDVAL[2] THEN
     BEGIN
      PUSH:=TRUE;
      CLEAR_LINE(XOVER,YOVER);
      WRITE('* * DOUBLE BLACKJACK !!! - PUSH -');
      SQUAWK;
    END {PUSH}
   ELSE IF HANDVAL[1]=21 THEN
    BEGIN
     WIN:=TRUE;
     BET:=BET+BET DIV 2;
     CLEAR_LINE(XOVER,YOVER);
     WRITE('* * * BLACKJACK !! - PAY 1.5 TIMES BET ');
     SQUAWK;
    END {PLAYERS BLACKJACK}
   ELSE
    BEGIN
     CLEAR_LINE(XOVER,YOVER);
     WRITE('* * DEALER HAS A BLACKJACK !!');
     SQUAWK;
    END;
   END; {BJACK:=TRUE}
  END; {TEST21 - NO BLACKJACK}
  
PROCEDURE DEALPLAYER;
 BEGIN
  IF SPLITHAND THEN I:=3 ELSE I:=1;
  PERSON:=PLAYER;
  REPEAT
   DOWHAT;
    IF (REPLY='Q') THEN EXIT(PROGRAM);
    IF (REPLY='H') OR (REPLY='D') THEN
     BEGIN
      DEAL;
      SHOWHAND;
      {TENCOUNT;}
      SCORE;
     END
   UNTIL BUST OR (REPLY<>'H') OR (REPLY='D');
  IF BUST THEN
   BEGIN
    CLEAR_LINE(XOVER,YOVER);
    IF SPLIT THEN
     BEGIN
      YOVER:=YOVER+1;
     END;
    WRITE('YOU BUSTED WITH ',HANDVAL[I]:3);
   END {IF BUST}
  ELSE BUST:=FALSE;
  IF REPLY='D' THEN
     BEGIN
        IF SPLIT THEN
          BEGIN
            IF SPLITHAND THEN DBLDOWN3:=TRUE;
            IF NOT SPLITHAND THEN DBLDOWN:=TRUE;
          END
        ELSE DBLDOWN:=TRUE;
     END;
  IF (REPLY='S') THEN SPLIT:=TRUE;
 END; {DEALPLAYER}
  
PROCEDURE DEALHOUSE;
 BEGIN
  PERSON:=DEALER;
  SHOHOLE;
WHILE (HANDVAL[2]<17) OR ((HANDVAL[2]=17) AND (NUMACES[2]>0)) DO
   BEGIN
    DEAL;
    SHOWHAND;
    {TENCOUNT;}
    SCORE;
   END; {WHILE}
  HSCORE;
 END; {DEALHOUSE}
 
PROCEDURE EVALUATE;
 VAR HV:INTEGER;
 BEGIN
  IF SPLITHAND THEN I:=3 ELSE I:=1;
  IF BUST THEN BEGIN
    IF SPLITHAND AND BUSTSECOND THEN WIN:=FALSE;
    IF SPLIT AND ((NOT SPLITHAND) AND BUSTFIRST) THEN WIN:=FALSE
    ELSE WIN:=TRUE;
   CLEAR_LINE(XOVER,YOVER);
   WRITE('THE HOUSE BUSTED WITH ',HANDVAL[2]:3);
  END
  ELSE IF HANDVAL[I]=HANDVAL[2] THEN PUSH:=TRUE
  ELSE IF HANDVAL[I]>HANDVAL[2] THEN 
    BEGIN
     IF SPLIT THEN
     BEGIN
      IF NOT SPLITHAND AND NOT BUSTFIRST THEN WIN:=TRUE;
      IF SPLITHAND AND NOT BUSTSECOND THEN WIN:=TRUE;
      END
     ELSE WIN:=TRUE;
   END;
  IF PUSH THEN BEGIN
   CLEAR_LINE(XOVER,YOVER);
   WRITE(' - PUSH -');
  END;
  HV:=HANDVAL[2];
  IF (NOT PUSH) AND (NOT BUST) THEN
   BEGIN
    CLEAR_LINE(XOVER,YOVER);
    IF HV=21 THEN
     WRITE('DEALER HAS 21!!')
     ELSE WRITE('PAY ',HV+1);
   END; {NOT PUSH}
 END; {EVALUATE}
 
 PROCEDURE DEALSPLIT;
 BEGIN
  RANSUIT(CARD);
  SCORE;
  NAMECARD;
  SHOWHAND;
  DEAL;
  SCORE;
  SHOWHAND;
  {TENCOUNT;}
  DEALPLAYER;
  IF BUST THEN
   BEGIN
   IF SPLITHAND THEN BUSTSECOND:=TRUE
   ELSE BUSTFIRST:=TRUE;
   BUST:=FALSE;
  END;
  PSCORE;
 END;
 
 
 PROCEDURE SPLITPR;
  BEGIN
  HANDVAL[1]:=0;
  HANDVAL[3]:=0;
  NUMACES[1]:=0;
  NUMACES[3]:=0;
  XPLYR:=0;
  YPLYR:=YHAND0;
  CARD:=FIRSTCARD;
  DEALSPLIT;
  XPLYR:=XSPLIT;
  YPLYR:=YSPLIT;
  CARD:=THIRDCARD;
  SPLITHAND:=TRUE;
  DEALSPLIT;
  IF BUSTFIRST AND BUSTSECOND THEN DBLBUST:=TRUE;
  END;
  
  PROCEDURE INSURANCE;
   BEGIN
     IF ACEUP THEN
        BEGIN
           CLEAR_LINE(XOVER,YOVER);
           SQUAWK;
           WRITE('Do want insurance (y/n)? ');
           READ(REPLY);
           IF REPLY IN ['Y', 'y' ] THEN
             BEGIN
                CLEAR_LINE(XOVER,YOVER);
                WRITE('The maximum insurance bet is $',BET DIV 2);
                GOTOXY(XOVER,YOVER+1);
                WRITE('Your insurance bet?');
                (*$I-*)
                REPEAT
                READLN(INSBET);
                IF (IORESULT<>0) OR (INSBET<=0) OR (INSBET>BET DIV 2) THEN 
                     BEGIN
                       SQUAWK;
                       CLEAR_LINE(XOVER+19,YOVER+1);
                     END;
                UNTIL (INSBET>0) AND (INSBET<=BET DIV 2);
                (*$I+*)
                CLEAR_LINE(XOVER,YOVER+1);
             END
           ELSE EXIT(INSURANCE);
           IF HANDVAL[2]=21 THEN
              BEGIN
                 DOLLARS:=DOLLARS+INSBET+INSBET;
                 WRITE('You win double the insurance bet!');
              END
           ELSE
              BEGIN
                 DOLLARS:=DOLLARS-INSBET;
                 WRITE('No Blackjack, you lose the insurance bet');
              END;
           CLEAR_LINE(XWIN+32,YWIN);
           WRITE(DOLLARS);
      END;
 END;
  
  
 BEGIN          {MAIN PROGRAM}
  CHOICE:=['H','G','D','S','Q'];
  TIME(HI,LO);
  FOR HI:=1 TO 100 DO HI:=HI;
  TIME(HI,LO_AGAIN);
  IF LO=LO_AGAIN THEN
    BEGIN
       {$I-}
       REPEAT
          BEGIN
            WRITE('  PLEASE ENTER A RANDOM NUMBER - ');
            READLN(SEED);
          END;
       UNTIL IORESULT=0;
       {$I+}
    END
  ELSE SEED:=LO_AGAIN;
  IF SEED<0 THEN SEED:=SEED*(-1);
  CLEAR_SCREEN ( 0, 0 );
  WRITELN('  Welcome to Blackjack (aka "21").');
  WRITELN;
  WRITELN('     ',VERSION);
  WRITELN;
  WRITELN('          <space> to start the game');
  WRITELN;
  WRITELN('       Be sure to hold on to your wallet!');
  READ(REPLY);
  CLEAR_SCREEN ( 0, 0 );
  FRESHDECK;
  FOR I:=1 TO 52 DO 
    BEGIN
      CARD_NOT_IN_DECK[I]:=FALSE;
      CARD_ON_TABLE[I]:=FALSE;
    END;
  BET:=200;
  NUMTENS:=16;
  NOTTEN:=36;
  CHANGED_BET:=FALSE;
  SHUFFLE;
  SETUP;
  INSTRUCTIONS;
  PLAYERIN;
  DOLLARS:=0;
  REPEAT
   IF BET>0 THEN BEGIN
    DEAL2;
    INSURANCE;
    TEST21;
    IF NOT BJACK THEN
     BEGIN
      DEALPLAYER;
      IF SPLIT THEN SPLITPR ELSE PSCORE;
      IF DBLBUST THEN
       BEGIN
        BUST:=FALSE;
        END;
      {NOTSEEN;}
      IF NOT (BUST OR (SPLIT AND DBLBUST)) THEN
       BEGIN
        DEALHOUSE;
        IF SPLIT THEN
         BEGIN
          EVALUATE;
          WINNINGS;
          SPLITHAND:=FALSE;
          WIN:=FALSE;
          PUSH:=FALSE;
          EVALUATE;
         END
       ELSE EVALUATE;
      END; {IF NOT BUST}
     END; {NOT BJACK}
    END; {BET>0}
   INSTRUCTIONS;
   WINNINGS;
   PLAYERIN;
   SETUP;
   CLEAR_SCREEN ( 0, YOVER );
  UNTIL BET<0
 END.  {MAIN PROGRAM}
 

========================================================================================
DOCUMENT :usus Folder:VOL11:blackjack.text
========================================================================================

(*$L-#6:*)
(*$S+*)
PROGRAM BLACKJK;
 
 {GAME OF BLACKJACK WRITTEN IN PASCAL BY T.R. STOKES}
 {MODIFICATIONS TO PERMIT S(piltpair AND Q(uit ADDED BY 
  G. W. SCHREYER  8-NOV-80}
 {Further modifications to permit doubling down on a split and
  to allow insurance and a better random number generator added
  by G.W. Schreyer 15-Dec-80}
 {Even further modified to burn a card.  GWS 16-DEC-80}
 {Tens ratio stuff added 19-Dec-80 and revised 23-Dec-80  gws}
                                  {and revised again 24-Dec-80 gws}
                                  {and commented out 7-Apr-81 because
                                   it never did work just right}
 {An original bug in procedure score fixed 26-Dec-80  gws}
 
 CONST
  VERSION = 'blackjack  version 3.0    26 Dec 82';
  XINST =       10; {VARIOUS X-Y COORDS FOR SCREEN MESSAGES}
  YINST =        3;
  XWIN  =       11;
  YWIN  =        2;
  XBET  =        8;
  YBET  =        1;
  YHAND0=        6; {LEVEL-1 OF CARDS PLAYED}
  
 TYPE
  VEGAS =       (PLAYER,DEALER);
  
 VAR
  NOTTEN,NUMTENS        :INTEGER;
  TENS_RATIO            :REAL;
  DECK                  :ARRAY[1..52] OF INTEGER;
  CARD,HI,LO,LO_AGAIN   :INTEGER;
  RANK,SUIT             :INTEGER;
  DBLDOWN3              :BOOLEAN;
  CHANGED_BET           :BOOLEAN;
  NAMRANK,NAMSUIT       :STRING;
  CARDSLEFT             :INTEGER;
  SEED                  :INTEGER;
  PERSON                :VEGAS;
  HANDVAL               :ARRAY[1..3] OF INTEGER;
  HANDSIZE              :ARRAY[1..3] OF INTEGER;
  TBET,BET,DOLLARS      :INTEGER;
  BUST,BJACK,PUSH,WIN   :BOOLEAN;
  XPLYR,YPLYR           :INTEGER;
  XDELR,YDELR           :INTEGER;
  XSPLIT,YSPLIT         :INTEGER;
  I,J,Q                 :INTEGER; {GENERAL PURPOSE INDICES}
  NUMACES               :ARRAY[1..3] OF INTEGER;
  WAIT                  :INTEGER;
  SHUFFLED_SINCE_HOLCARD:BOOLEAN;
  JUST_SHUFFLED         :BOOLEAN;
  CARDVAL               :INTEGER;
  REPLY                 :CHAR;
  HOLVAL,XRANK          :INTEGER;
  HOLCARD               :BOOLEAN;
  CHOICE                :SET OF CHAR;
  XHOLE,YHOLE           :INTEGER;
  HOLSUIT,HOLRANK       :STRING;
  DBLDOWN,PAIR,SPLIT    :BOOLEAN;
  SPLITHAND,DBLBUST     :BOOLEAN;
  FSTCARD               :INTEGER;
  THIRDCARD,FIRSTCARD   :INTEGER;
  BUSTFIRST,BUSTSECOND  :BOOLEAN;
  XOVER,YOVER           :INTEGER;
  ACEUP                 :BOOLEAN;
  INSBET                :INTEGER;
  CARD_ON_TABLE         :ARRAY[1..52] OF BOOLEAN;
  CARD_NOT_IN_DECK      :ARRAY[1..52] OF BOOLEAN;
  CARDS_NOT_SEEN        :INTEGER;
  
  
PROCEDURE SQUAWK;
  BEGIN
    WRITE(CHR(7));
  END;

procedure clear_line ( x, y : integer );
begin
   gotoxy ( x, y );
   write ( chr ( 27 ) , 'K' );  {H-19}
end;

procedure clear_screen ( x, y : integer );
begin
   gotoxy ( x, y );
   write ( chr ( 27 ) , 'J' );  {H-19}
end;

PROCEDURE TENCOUNT;
 BEGIN
   IF HOLCARD THEN XRANK:=HOLVAL ELSE XRANK:=RANK;
   IF (XRANK>9) AND (XRANK<14) THEN NUMTENS:=NUMTENS-1
     ELSE NOTTEN:=NOTTEN-1;
   IF NUMTENS=0 THEN TENS_RATIO:=99.999 ELSE TENS_RATIO:=NOTTEN/NUMTENS;
   CLEAR_LINE(60,9);
   WRITE('Tens ratio');
   CLEAR_LINE ( 62, 11 );
   WRITE(NOTTEN:2,'/',NUMTENS:2);
   CLEAR_LINE(61,12);
   WRITE(TENS_RATIO:5:3);
   CLEAR_LINE(60,15);
   WRITE('Cards left');
   CLEAR_LINE(65,17);
   WRITE(CARDSLEFT);
 END;
 
 PROCEDURE RANSUIT(VAR CARD:INTEGER); FORWARD;
 
 PROCEDURE COUNTERFIX;
   BEGIN
     RANSUIT(CARD);
     {TENCOUNT;}
   END;

PROCEDURE CLEARTOP;
  BEGIN
    CLEAR_LINE(0,0);
  END;
   
   
PROCEDURE SHUFMES;
 BEGIN
  CLEARTOP;
  GOTOXY(5,0);
  WRITE('SHUFFLING-  HAVE A DRINK ON THE HOUSE.');
  FOR WAIT:=1 TO 2000 DO WAIT:=WAIT;
 END;  {SHUFMES}
  
FUNCTION RND:REAL;
 BEGIN
  RND:=SEED/32767;
  SEED:=(103*SEED+1999) MOD 32767;
  IF SEED<0 THEN SEED:=SEED*(-1);
 END; {RND}
 
PROCEDURE FRESHDECK;
 BEGIN
  FOR I:=1 TO 52 DO
   BEGIN
    DECK[I]:=I;
  END; {FOR}
 END;  {FRESHDECK}
 
PROCEDURE NAMECARD;
 BEGIN
  NAMRANK:='     ';         {MAKE IT ONE BYTE LONG}
  NAMRANK[1]:=CHR(RANK+48);   {SO THIS WILL WORK}
  IF RANK=1 THEN NAMRANK:='ACE  '
   ELSE IF RANK>9 THEN
    BEGIN
     CASE RANK OF
    10:NAMRANK:='10   ';
    11:NAMRANK:='JACK ';
    12:NAMRANK:='QUEEN';
    13:NAMRANK:='KING ';
     END {RANKCASE}
    END;
    BEGIN
     CASE SUIT OF
    1:NAMSUIT:='CLUBS   ';
    2:NAMSUIT:='DIAMONDS';
    3:NAMSUIT:='HEARTS  ';
    4:NAMSUIT:='SPADES  ';
     END {SUITCASE}
    END;
   END; {NAMECARD}

PROCEDURE RANSUIT;
 BEGIN
   RANK:=CARD MOD 13;
   IF RANK=0 THEN RANK:=13;
   SUIT:=(CARD-1) DIV 13 + 1;
 END; {RANSUIT}

PROCEDURE BURN;
 VAR T:INTEGER;
 BEGIN
   REPEAT
     CARD:=DECK[CARDSLEFT];
     IF CARD_NOT_IN_DECK[CARD] THEN COUNTERFIX;
     CARDSLEFT:=CARDSLEFT-1;
   UNTIL CARD_NOT_IN_DECK[CARD]=FALSE;
   RANSUIT(CARD);
   NAMECARD;
   GOTOXY(5,0);
   WRITE('Burning a');
   IF (RANK=8) OR (RANK=1) THEN WRITE('n');
   WRITE(' ',NAMRANK:6,' of ',NAMSUIT);
   FOR T:= 1 TO 5000 DO T:=T;
   CLEARTOP;
   HOLCARD:=FALSE;
   {TENCOUNT;}
 END;
 
PROCEDURE SHUFFLE;
 VAR
  TEMP,RI:INTEGER;
 BEGIN
  SHUFMES;
  FOR I:=1 TO 52 DO CARD_NOT_IN_DECK[I]:=CARD_ON_TABLE[I];
  CARDSLEFT:=52;
   FOR I:=1 TO 52 DO
    BEGIN
     TEMP:=DECK[I];
     RI:=TRUNC(52*RND+1);
     DECK[I]:=DECK[RI];
     DECK[RI]:=TEMP;
    END; {FOR}
   CLEARTOP;
   NOTTEN:=36;
   NUMTENS:=16;
   BURN;
   CARDS_NOT_SEEN:=0;
   JUST_SHUFFLED:=TRUE;
  END; {SHUFFLE}
  
PROCEDURE NOTSEEN;
  BEGIN
    IF NOT SHUFFLED_SINCE_HOLCARD AND (BUST OR (SPLIT AND DBLBUST)) THEN
      BEGIN
        CARDS_NOT_SEEN:=CARDS_NOT_SEEN+1;
      END;
    CLEAR_LINE(58,20);
    WRITE('Cards not seen');
    CLEAR_LINE(65,22);
    WRITE(CARDS_NOT_SEEN);
  END;
   
PROCEDURE SETUP;
 BEGIN
  BUST:=FALSE;
  DBLDOWN3:=FALSE;
  TENS_RATIO:=0;
  BJACK:=FALSE;
  SHUFFLED_SINCE_HOLCARD:=FALSE;
  JUST_SHUFFLED:=FALSE;
  ACEUP:=FALSE;
  FOR I:=1 TO 52 DO CARD_ON_TABLE[I]:=FALSE;
  INSBET:=0;
  DBLBUST:=FALSE;
  SPLITHAND:=FALSE;
  BUSTFIRST:=FALSE;
  BUSTSECOND:=FALSE;
  Q:=0;
  PUSH:=FALSE;
  WIN:=FALSE;
  DBLDOWN:=FALSE;
  FSTCARD:=0;
  PAIR:=FALSE;
  SPLIT:=FALSE;
  XOVER:=5;
  YOVER:=4;
  XPLYR:=0;
  YPLYR:=YHAND0;
  XDELR:=26;
  YDELR:=YHAND0;
  XSPLIT:=0;
  YSPLIT:=YHAND0+9;
  FOR I:=1 TO 3 DO
   BEGIN
    HANDVAL[I]:=0;
    NUMACES[I]:=0;
    HANDSIZE[I]:=0;
   END; {FOR}
 END; {SETUP}
 
 PROCEDURE SHOWHAND;
  VAR
   X,Y,CN  :INTEGER;
  BEGIN
   CASE PERSON OF
  PLAYER:
   BEGIN
    YPLYR:=YPLYR+1;
    Y:=YPLYR;
    X:=XPLYR;
   END;
  DEALER:
   BEGIN
    YDELR:=YDELR+1;
    Y:=YDELR;
    X:=XDELR;
    IF SPLIT THEN YSPLIT:=YHAND0;
   END;
  END; {CASE}
   NAMECARD;
   GOTOXY(X,Y);
   CN:=Y-YHAND0;
   IF SPLITHAND THEN CN:=Y-YSPLIT;
   WRITE(CN:3,')',NAMRANK:6,' OF ',NAMSUIT);
   HOLCARD:=FALSE;
 END; {SHOWHAND}
  
PROCEDURE SCORE;
 VAR CARDVAL:INTEGER;
BEGIN
  CASE PERSON OF
  PLAYER:IF SPLITHAND THEN I:=3 ELSE I:=1;
  DEALER:I:=2;
   END; {CASE}
 CARDVAL:=RANK;
 IF RANK>10 THEN CARDVAL:=10;
 IF RANK=1 THEN 
   BEGIN
     CARDVAL:=11;
     NUMACES[I]:=NUMACES[I]+1;
   END;
 HANDVAL[I]:=HANDVAL[I]+CARDVAL;
 WHILE (HANDVAL[I]>21) AND (NUMACES[I]>0) DO 
   BEGIN
      HANDVAL[I]:=HANDVAL[I]-10;
      NUMACES[I]:=NUMACES[I]-1;
   END;
IF HANDVAL[I]>21 THEN BUST:=TRUE;
END; {SCORE}

PROCEDURE PSCORE;
 BEGIN
  IF SPLITHAND THEN I:=3 ELSE I:=1;
  GOTOXY(XPLYR+6,YPLYR+1);
  WRITE('TOTAL = ',HANDVAL[I]:3);
 END; {PSCORE}
 
PROCEDURE HSCORE;
 BEGIN
  GOTOXY(XDELR+6,YDELR+1);
  WRITE('TOTAL = ',HANDVAL[2]:3);
 END; {HSCORE}

PROCEDURE WINNINGS;
 BEGIN
  IF NOT PUSH THEN
   BEGIN
    TBET:=BET;
    IF DBLBUST THEN DOLLARS:=DOLLARS-BET;
    IF DBLDOWN AND (NOT SPLITHAND) THEN TBET:=BET+BET;
    IF DBLDOWN3 THEN TBET:=BET+BET;
    IF WIN THEN DOLLARS:=DOLLARS+TBET
    ELSE DOLLARS:=DOLLARS-TBET
  END;
  CLEAR_LINE(XWIN,YWIN);
  WRITE('In U.S. of A. Dollars you have $',DOLLARS);
 END; {WINNINGS}
 
PROCEDURE DOWHAT;
 BEGIN
  CLEAR_LINE(XOVER,YOVER);
  REPEAT
   GOTOXY(XOVER,YOVER);
   WRITE('YOUR MONEY ? ');
   READ(REPLY);
   IF REPLY IN [ 'a'..'z' ] THEN REPLY := CHR ( ORD ( REPLY ) - 32 );
   CLEAR_LINE(XOVER,YOVER+1);
  UNTIL REPLY IN CHOICE;
  IF (REPLY='D') AND (HANDSIZE[1]>2) AND (NOT SPLIT) THEN
   BEGIN
    CLEAR_LINE(XOVER,YOVER+1);
    WRITE('NO-NO, NOT AFTER 3 OR MORE!!');
    SQUAWK;
    DOWHAT;
   END;
  IF (REPLY='S') AND (NOT PAIR) THEN
   BEGIN
    CLEAR_LINE (XOVER,YOVER+1);
    WRITE ('YOU DON''T HAVE A PAIR TO SPLIT!');
    SQUAWK;
    DOWHAT;
   END;
    IF SPLIT AND (REPLY='S') THEN
     BEGIN
      CLEAR_LINE(XOVER,YOVER+1);
      WRITE('YOU CAN''T SPLIT A SPLIT PAIR!');
      SQUAWK;
      DOWHAT;
     END;
     END; {DOWHAT}
 
PROCEDURE NOSHOW;
 VAR CN:INTEGER;
 BEGIN
  YDELR:=YDELR+1;
  GOTOXY(XDELR,YDELR);
  CN:=YDELR-YHAND0;
  WRITE(CN:3,')   ?????????');
  XHOLE:=XDELR;
  YHOLE:=YDELR;
  HOLSUIT:=NAMSUIT;
  HOLRANK:=NAMRANK;
  HOLVAL:=RANK;
 END; {NOSHOW}
 
PROCEDURE INSTRUCTIONS;
 BEGIN
  GOTOXY(XINST,YINST);
  WRITE('H)it, G)ood, D)oubledown, S)plitpair, Q(uit');
 END; {INSTRUCTIONS}
 
PROCEDURE PLAYERIN;
 VAR C,B:CHAR;
BEGIN
  (*$I-*)
 CLEAR_LINE(XBET,YBET);
 IF (NOT CHANGED_BET) AND (BET<>0) THEN
    BEGIN
       WRITE('HOUSE LIMIT IS $200.. BET LIMIT ? (Y/N) ');
       READ(B);
       IF B<>'N' THEN BET:=200 ELSE BET:=0;
    END
 ELSE
  BEGIN
   CHANGED_BET:=TRUE;
   REPEAT
     CLEAR_LINE(XBET,YBET);
     IF BET=0 THEN
      BEGIN
        REPEAT
          CLEAR_LINE(XBET,YBET);
(*$I BJACK.1.TEXT*)


========================================================================================
DOCUMENT :usus Folder:VOL11:chase.text
========================================================================================

(*$S+*)
PROGRAM CHASE;
CONST   MAN        = 'O';                     {SYMBOL FOR THE MAN}
        EDGE       = 'I';                     {SYMBOL FOR THE FENCE}
        OBST       = '*';                     {SYMBOL FOR AN OBSTRUCTION}
        ROBOT      = 'R';                     {SYMBOL FOR A ROBOT}
        BLANK      = ' ';                     {AN ASCII BLANK}
       
        DROB       =   3;                     {STARTING NO OF ROBOTS}
        ROBMAX     =  20;                     {MAX NO OF ROBOTS ALLOWED}
        XMAX       =  39;                     {MAX HORIZONTAL FIELD DIMENSION}
        YMAX       =  14;                     {MAX VERTICAL FIELD DIMENSION}
        
        TOP        =   2;                     {SPACE ABOVE FIELD}
        SIDE       =   5;                     {SPACE TO LEFT OF FIELD}
        
        CLRSCRN    =  26;                     {CLEAR SCREEN CODE}


VAR     FIELD      : PACKED ARRAY[0..XMAX,0..YMAX] OF CHAR;
        AGAIN,PLAY : BOOLEAN;
        WIN        : BOOLEAN;
        MI,MJ      : INTEGER;                 {COORDINATES OF THE MAN}
        R          : INTEGER;                 {NUMBER OF ROBOTS LEFT}
        RI,RJ      : ARRAY[1..ROBMAX] OF INTEGER;  {ROBOT COORDINATES}
        SEED       : INTEGER;
        DIFF       : INTEGER;                 {DIFFICULTY}
        IDIFF      : 0..10;                   {INITIAL DIFFICULTY}
        GAMENU     : INTEGER;                 {GAME NUMBER}
        M          : CHAR;
        NROB       : INTEGER;                 {NUMBER OF ROBOTS}
        WINS       : INTEGER;                 {NUMBER OF GAMES WON}
        GOODCHAR   : SET OF CHAR;             {GOOD CHARACTERS}
        MOVES      : INTEGER;                 {COUNT OF MOVES}
        CRASH      : INTEGER;                 {NO OF ROBOTS "CRASHED"}

FUNCTION RND(LO,HI:INTEGER):INTEGER;          {RANDOM NUMBER GENERATOR}
VAR  Q       :REAL;
     I       :INTEGER;
BEGIN
   Q:=SEED/32767;
   SEED:=(103*SEED+1999) MOD 32767;
   IF SEED<0 THEN SEED:=-1*SEED;
   RND:=TRUNC((HI-LO)*Q)+LO;
END;
    


PROCEDURE DOMOVE(COL,ROW:INTEGER;SYMBOL:CHAR); {DISPLAY SYMBOL AT I,J ON FIELD}
BEGIN
  GOTOXY(COL,ROW);         {POSITION CURSOR}
  WRITE(SYMBOL)
END;            {END OF DOMOVE PROCEDURE}


PROCEDURE CLEARSCREEN; BEGIN
  WRITE(CHR(27),CHR(69))        {h-19 specific}
END;

PROCEDURE CURSOR_OFF;
BEGIN
   WRITE(CHR(27),'x5');   {H-19}
END;

PROCEDURE CURSOR_ON;
BEGIN
   WRITE(CHR(27),'y5');   {H-19}
END;

PROCEDURE INSTRUCTIONS;                       {DISPLAY INSTRUCTIONS}
VAR M:CHAR;
BEGIN
  CLEARSCREEN;
  WRITELN('WELCOME TO THE WONDERFUL EXCITING GAME OF CHASE':60);
  GOTOXY(0,3);
  WRITE('WOULD YOU LIKE INSTRUCTIONS ? (Y OR N) ':55);
  READ(M);
  IF M in ['Y', 'y' ] THEN
  BEGIN
    WRITELN;WRITELN;
    WRITELN('    HERE ARE SOME INSTRUCTIONS');
    WRITELN('YOU,"O",ARE IN A HIGH VOLTAGE MAZE.');
    WRITELN('THE ROBOTS,"R",ARE TRYING TO DESTROY YOU.');
    WRITELN('TO WIN, YOU MUST DESTROY THE ROBOTS.');
    WRITELN('THIS IS DONE BY RUNNING THEM INTO FENCE POSTS,"*",');
    WRITELN('OR BY RUNNING THEM INTO EACH OTHER.');
    WRITELN('THE DIAGRAM BELOW THE MAZE SHOWS HOW YOU CAN MOVE');
    WRITELN('THE ROBOTS WILL TRY TO FOLLOW YOU.');
    WRITELN('THERE ARE 3 ROBOTS TO START FOR A BEGINNER.');
    WRITELN('THE NUMBER WILL INCREASE AS YOU WIN GAMES !');
    WRITELN;
    WRITELN('          GOOD LUCK!!!!!')
  END;
END;                                          {END OF INSTRUCTIONS}


PROCEDURE STARTGAME;
VAR    SK: CHAR;
BEGIN
WRITELN;WRITELN;WRITELN;
  WRITE('ENTER A NUMBER FOLLOWED BY RETURN ':51);READLN(SEED);
  REPEAT
     CLEARSCREEN;
     WRITELN('      HOW GOOD A PLAYER ARE YOU ?');
     WRITELN;
     WRITELN('        BEGINNER     - B');
     WRITELN('        INTERMEDIATE - I');
     WRITELN('        EXPERT       - E');
     WRITELN('        OLD PRO      - P');
     WRITELN;
     WRITE('              TYPE IN YOUR SKILL ');
     READ (SK);
     WRITELN;
     IF SK IN ['a'..'z'] then sk := chr ( ord ( sk ) - 32 );
     IF NOT (SK IN ['B','I','E','P']) THEN
     BEGIN
       GOTOXY(10,10);
       WRITE('    WHAT WAS THAT AGAIN PLEASE ? ',CHR(7));
       READ (SK);
       IF SK IN ['a'..'z'] then sk := chr ( ord ( sk ) - 32 );
     WRITELN
     END;
  UNTIL (SK IN ['B','I','E','P']);
  CLEARSCREEN;
  CASE SK OF
    'B': IDIFF:=0;
    'I': IDIFF:=1;
    'E': IDIFF:=3;
    'P': IDIFF:=5;
  END;
END;


PROCEDURE INITIALIZE;   {SET UP BLANK FIELD SURROUNDED BY FENCE}
VAR I,J:INTEGER;
BEGIN
  FOR I:=0 TO XMAX DO
  BEGIN
    FOR J:=0 TO YMAX DO
    IF((I=0) OR (I=XMAX) OR (J=0) OR (J=YMAX)) THEN FIELD[I,J]:=EDGE
      ELSE FIELD[I,J]:=BLANK
   END;
END;    {END OF INITIALIZE}


PROCEDURE INNERFIELD;   {SET UP MAN, ROBOTS AND OBSTRUCTIONS}
VAR I,J,L,POSTS:INTEGER;
BEGIN
  CURSOR_OFF;
  MI:=RND(1,XMAX-1); MJ:=RND(1,YMAX-1); {LOCATE MAN AT ANY RANDOM POSITION}
  FIELD[MI,MJ]:=MAN;
  R:=NROB;
  FOR L:=1 TO R DO                            {NOW DO R ROBOTS}
  BEGIN
    REPEAT
      I:=RND(0,XMAX);J:=RND(0,YMAX);
    UNTIL FIELD[I,J]=BLANK;
    FIELD[I,J]:=ROBOT;
    RI[L]:=I;
    RJ[L]:=J
  END;
  POSTS:=RND(25,35);                          {NOW SET UP 25 TO 35 POSTS}
  FOR L:=1 TO POSTS DO
  BEGIN
    REPEAT
      IF DIFF>3 THEN
      BEGIN
        I:=RND(0,XMAX);
        J:=RND(0,YMAX)
      END ELSE
      BEGIN
        I:=RND(1,XMAX-1);
        J:=RND(1,YMAX-1)
      END;
    UNTIL FIELD[I,J]=BLANK;
    FIELD[I,J]:=OBST
    END;
  CURSOR_ON;
END;                                          {END OF INNERFIELD}


PROCEDURE MAP;                                {DISPLAY PLAYING FIELD}
VAR I,J:INTEGER;
BEGIN
  CURSOR_OFF;
  CLEARSCREEN;
  WRITELN('GAME  DIFF   ROBOTS    WINS    MOVE':79);
  WRITE(' ':44,GAMENU:3,DIFF:5,R:8,WINS:10,MOVES:8);
  GOTOXY(0,0);
  FOR J:=0 TO YMAX DO
  BEGIN
    FOR I:=0 TO XMAX DO WRITE(FIELD[I,J]);
    WRITELN
  END;
  WRITELN;
  WRITELN('7 8 9      Q = QUIT');
  WRITELN('4 X 6      5 = NO MOVE'); 
  WRITE('1 2 3                  MOVE => ');
  CURSOR_ON;
END;                                          {END OF MAP}

PROCEDURE MOVE;                               {ENTER YOUR MOVE FROM KEYBOARD}
VAR     M : INTEGER;
        C : CHAR;
      BAD : BOOLEAN;
BEGIN
  BAD:=FALSE;
  REPEAT
    WRITE(' ',CHR(8));
    READ (C);
    IF C IN ['a'..'z'] then c := chr ( ord ( c ) - 32 );
     IF NOT (C IN GOODCHAR) THEN
    BEGIN
      GOTOXY(4,21);
      BAD:=TRUE;
      WRITE('BAD MOVE, PLEASE TRY AGAIN ':33,CHR(7))
    END;
  UNTIL (C IN GOODCHAR);
  IF BAD THEN
    BEGIN
      GOTOXY(4,21);
      WRITE(' ':40);
      GOTOXY(10,22);
    END;
  IF C='Q' THEN
    BEGIN
     PLAY:=FALSE;
     WIN:=FALSE
    END;
  CURSOR_OFF;
  M:=ORD(C)-48;
  FIELD[MI,MJ]:=BLANK;
  DOMOVE(MI,MJ,BLANK);
      CASE M OF
  7: BEGIN MI:=MI-1; MJ:=MJ-1 END;
  8: MJ:=MJ-1;
  9: BEGIN MI:=MI+1; MJ:=MJ-1 END;
  4: MI:=MI-1;
  5: ;
  6: MI:=MI+1;
  1: BEGIN MI:=MI-1; MJ:=MJ+1 END;
  2: MJ:=MJ+1;
  3: BEGIN MI:=MI+1; MJ:=MJ+1 END
     END;
  MOVES:=MOVES+1;
  IF FIELD[MI,MJ] = BLANK THEN
    BEGIN
      DOMOVE(MI,MJ,MAN);
      FIELD[MI,MJ]:=MAN 
    END ELSE
  BEGIN
    IF FIELD[MI,MJ] = EDGE THEN
    BEGIN
      WIN:=FALSE;
      PLAY:=FALSE;
      WRITELN('OUCH, YOU GOT ELECTROCUTED!')
    END ELSE
    BEGIN
      IF FIELD[MI,MJ] = ROBOT THEN 
      WRITELN('THWACK! YOU RAN INTO A ROBOT (TURKEY!)') ELSE
      WRITELN('ZZAP! YOU RAN INTO AN ELECTIFIED POST');
      WIN:=FALSE;
      PLAY:=FALSE
    END;
  END;
  CURSOR_ON;
END;            {END OF MOVE PROCEDURE}


PROCEDURE ROBOTMOVE;    {COMPUTE MOVE FOR R OR FEWER ROBOTS}
VAR M,L,I,J:INTEGER;
BEGIN
  FOR L:=1 TO NROB DO
  BEGIN
    IF((RI[L]<>0) AND (WIN)) THEN
    BEGIN
      FIELD[RI[L],RJ[L]]:=BLANK;
      DOMOVE(RI[L],RJ[L],BLANK);
      IF MI>RI[L] THEN RI[L]:=RI[L]+1;
      IF MI<RI[L] THEN RI[L]:=RI[L]-1;
      IF MJ>RJ[L] THEN RJ[L]:=RJ[L]+1;
      IF MJ<RJ[L] THEN RJ[L]:=RJ[L]-1;
      I:=RI[L];J:=RJ[L];
      IF FIELD[I,J]=BLANK THEN
      BEGIN
        FIELD[RI[L],RJ[L]]:=ROBOT;
        DOMOVE(I,J,ROBOT)
      END
      ELSE
      BEGIN
        IF ((FIELD[I,J]=OBST) OR (FIELD[I,J]=ROBOT))  THEN 
        BEGIN
          GOTOXY(XMAX+12,CRASH+2);
          CRASH:=CRASH+1;
          WRITELN('CRASH!! YOU GOT ONE!!');
          R:=R-1;
          GOTOXY(53,1);             {CHANGE NO OF ROBOTS}
          WRITE(R:8);
          RI[L]:=0;
          IF R=0 THEN
          BEGIN
            GOTOXY(XMAX+16,CRASH+2);
            WRITELN('GOOD WORK!');
            GOTOXY(XMAX+8,CRASH+3);
            WRITELN('YOU HAVE DESTROYED THEM ALL!!');
            WIN:=TRUE;
            PLAY:=FALSE
          END;
        END;
      END;
      IF FIELD[RI[L],RJ[L]]=FIELD[MI,MJ] THEN
      BEGIN
        WRITELN('ZAP! A ROBOT GOT YOU!');
        WIN:=FALSE;
        PLAY:=FALSE
      END;
    END;
 END;
END;                                         {END OF ROBOTMOVE PROCEDURE}



BEGIN             {START OF MAIN PROGRAM}
  GOODCHAR:=['1'..'9','Q'];
  WRITE(CHR(27),'u');  {set keypad not shifted mode}
  GAMENU:=1;
  WINS:=0;
  AGAIN:=TRUE;
  PLAY:=TRUE;     {INITIALIZE QUIT}
  INSTRUCTIONS;   {DISPLAY INSTRUCTIONS}
  STARTGAME;      {INPUT STARTING POSITION AND SKILL LEVEL}
  DIFF:=IDIFF;    {INITIAL DIFFICULTY LEVEL}
  NROB:=DROB+DIFF*2;  {INITIAL NUMBER OF ROBOTS}
  WHILE AGAIN DO
  BEGIN
    MOVES:=1;WIN:=TRUE;CRASH:=0;
    INITIALIZE;     {CLEARS FIELD[X,Y]}
    INNERFIELD;     {SETS UP PLAYING FIELD}
    WHILE PLAY DO
    BEGIN
      IF MOVES=1 THEN MAP ELSE
      BEGIN
        GOTOXY(70,1);
        WRITELN(MOVES:8);
        DOMOVE(30,18,BLANK)             {INPUT NEXT MOVE}
      END;
      MOVE;         {LETS YOU MOVE}
      IF(PLAY) THEN ROBOTMOVE     {MOVES THE ROBOTS}
    END;
    GOTOXY(0,21);
    WRITE('WOULD YOU LIKE TO PLAY AGAIN (Y OR N) ');
    READ(M);
    CLEARSCREEN;
    IF M in ['N', 'n'] THEN AGAIN:=FALSE ELSE
    BEGIN
      PLAY:=TRUE;
      GAMENU:=GAMENU+1;
      IF WIN THEN
      BEGIN
        WINS:=WINS+1;
        IF WINS>2 THEN DIFF:=IDIFF+1;
        IF WINS>5 THEN DIFF:=IDIFF+2;
        IF WINS>8 THEN DIFF:=IDIFF+3;
        IF WINS>11 THEN DIFF:=IDIFF+4;
        IF WINS>15 THEN DIFF:=IDIFF+6;
        IF WINS>20 THEN DIFF:=IDIFF+8;
        IF WINS>30 THEN DIFF:=IDIFF+12;
        NROB:=DROB+2*DIFF;
        IF NROB > 18 THEN NROB:=19;
      END;
    END;
  END;
WRITE(CHR(27),'t');  {sets keypad shifted mode}
END.


========================================================================================
DOCUMENT :usus Folder:VOL11:contents.text
========================================================================================



USUS(UK) SOFTWARE LIBRARY VOLUME 1                  23RD MARCH 1982

Contents of this volume                       Austin Tate, ERCC 22-Feb-82
-------------------------------------------------------------------------

This volume holds a mailing address data base, mailing label and forms
letter production utility called MAIL along with associated text files
and utilities.

See the file MAIL.READ.TEXT for details of the files included.


========================================================================================
DOCUMENT :usus Folder:VOL11:mail.doc.text
========================================================================================

--------------------------------------------------------------------------
                          MAIL                     19th February, 1982
--------------------------------------------------------------------------


Preface:

Some users are going to wish to use only the word processing capabilities
of this program.  Others are going to want to use all the facilities that
are offered. A word to the wise is in order. Take your time and understand
what the manual has to say BEFORE you run the program.  It is always a good
idea when using software to do so, but in this case it is essential. Thank
you and good luck.

The program and manual were begun by Patrick Horton at Associated Computer
Industries.  They were subsequently updated and modified by Austin Tate at
the Edinburgh Regional Computing Centre.

The program and manual are copyright (c) 1982 by Austin Tate, ERCC.




TABLE OF CONTENTS
------------------------------------------------
Welcome
Files in the System
Flags (part 1)
getting started
prompt line
preliminary functions:
   O)ptions
   D)escriptions
basic functions
   A)dd
   C)hange
   D)elete
   R)estore
   F)ind
   1)st
   ' ')step
   Z)ero
   S)ort
   O)ptions
      Input and Output files
      Flags (part 2)
      Mailing Labels Format
      Letter Format
        Page Layout
      Quit option
   M)labels
   L)etter
final commands
   Q)uit
   K)runch
   I)nit
word processing
   special characters
      ^        page throws
      =        carriage return suppressed
      ~        literal line direction (~ is default)
      [:   :]  margin and spacing specification
      {%   %}  flagged paragraphs
      (*   *)  tokens for fields of selected records
      \\       include mailing label in letter
   flagged paragraphs
   field designators
   greeting
   tokens
   spacing and margins
   general rules
summary
Notes
   Implementation notes
      mailing labels file format
      overview of operation of MAIL
   Restriction on file sizes
ERCC Notes
   Initialisation of MAIL data files
   Conversion of MAILER names and addresses into MAIL
   Increasing the size of a MAIL data file
   Data Manipulation on records of your own description
   Producing files for SORT/MERGE operations




Welcome to the Mail program users manual.

The main purpose of a manual like this, and perhaps the hardest to achieve,
is to provide the user with an intuitive understanding of the program. It
is the task of the writer to convey the feeling of being in complete
control of the program to the user.
          
This feeling of confidence probably defines the difference between a useful
program and one which is never used.  Hopefully this manual will convey to
you the fact that the program is actually quite simple to use although it
has some relativly complicated features.
          
The program is designed to maintain a mailing list and allow for the
production of two types of output: mailing labels and form letters. The
form letter producer is essentially a text processor designed to work best
towards a certain goal - that of producing form letters.
          
The program is also designed to be very compatible with the UCSD p-System,
utilizing the same single stroke commands and descriptive prompt lines. In
other words it was made to look like part of the system.
          
                    
          
Files in the system                     
-------------------                     
          
There are several files associated with the program that you as a user will
be involved with. The first is the code file for the program itself:
MAIL.CODE.  This is the file that you will instruct the system to execute.
          
The second file is called MAIL.INFO.DATA and contains the working
parameters of the system. These parameters are variables that determine how
the functions of the program will act. They are kept in a file so that you
don't have to set up the operating environment everytime you run the
program. Some examples of the parameters kept in this file are: left and
right margins for letters, number of labels wide to a page, and output file
(printer port or filename). A complete description of everything in this
file will be given later.
          
The third file you will run into is the mailing system data file. The
default name for this is MAIL.DATA, although, as you will see, you can
specify any name you wish for this file.  The data in the file is stored as
records.  Records contain data stored in two different formats. The first
is fields, which are essentially strings of character data such as first
name, or address.
          
The second format or type of data stored in a record is called a flag.
There are 48 flags stored with each record.  Each flag is essentially an
on-off switch, or a yes-no bit of information, that you set when you add
the record to the file. The description or meaning of each flag is
arbitrarily set by you and is stored in the file MAIL.INFO.DATA.  Also
stored in MAIL.INFO.DATA are 48 flags which are used as a mask by which
records can be selected for output for labels or letters.  For now, all you
need to know is that there are 48 flags stored with each record in
MAIL.DATA, and 48 flags and 48 descriptions stored in the file
MAIL.INFO.DATA.
          
The fourth file associated with the system is the input file for the
L)etters command of the program.  This file may have any name ending in
'.TEXT', and contains text along with special word-processing symbols and
tokens. The exact format of the file will be described later. The file name
for this file is stored in the file MAIL.INFO.DATA as the I)nput file.
          
Several sample input files are available:

MAIL.E.G.TEXT  gives a brief explanation of the MAIL system
               itself.  It is suitable for use with MAIL as it is
               normally distributed (i.e., before changes are
               made to the O)ptions set by default).  The MAIL
               system will assume that it should use this example
               text file for processing by the L)etters command
               if the MAIL O)ptions are not altered.

MAIL.LETT.TEXT is a short form letter and may be used as a guide
               for constructing your own letters for use with
               MAIL.

MAIL.FORM.TEXT is a text which when processed by the L)etter
               command in MAIL will produce a form containing all
               the data stored about an individual in the MAIL
               data file.

The fifth and last file associated with the program has been previously
mentioned.  It is the file to which output will be directed. It may not
even be a file, but may be a port-device such as 'REMOTE:', or 'PRINTER:'.
When wishing to output things to the screen, '#2:'  should be used rather
than 'CONSOLE:'  as the program recognizes it and will compensate for the
fact that the prompt lines and the output are both going to the same place.
The name for this file is also stored in the file MAIL.INFO.DATA.

          
          
First Things First                          
------------------                      
          
It is important that you have a good overview of the internal workings of
the program before you actually start to use it.  Otherwise, you might not
realize that there was actually a more efficient way to do something than
the one you had chosen.
          
          
          
Back to the Flags                      
-----------------                      
          
Summing up what you have already learned about flags, you know that there
are 48 flags and descriptions stored in the format file, and 48 flags
stored with each record in the data file. It was also previously mentioned
that you will arbitrarily set up the meanings associated with each flag.
This should be done before you add records so that you may set the flags on
the records as you add them, rather than going back over them later when
you decide what the flags mean.
          
The flags will be used for three purposes.  They will be used for the
selection of records for output, for the inclusion of paragraphs or
sentences into letters and for the construction of a 'greeting' in form
letters.
          
You can determine which records will be output to labels or letters by
setting the flags in MAIL.INFO.DATA (henceforth called system flags). These
flags are used as a mask against which the individual record flags are
compared.  There are two options for selecting a record: either all flags
must match or any single flag must match. This and other options are set up
in the O)ptions part of the program.
          
You can mark out part of the text in a letter file into what is called a
flagged paragraph using special characters which will be described later.
Then the paragraph (or sentence, or word) will only be included in a
certain letter if the corresponding flag is set.  You can also determine
the form of greeting used in form letters where no overriding specification
is given for a particular record.  This is done by setting some of a
special set of five flags associated with the greeting (flags 44-48) - see
later.
          
It should be pointed out that it is not nessecary to use the flags, only
sometimes beneficial.  Most people will never use all 48 flags.  Usually
about 10 will be sufficient to categorize the different records in the
file.
          
          
          
Getting Started                             
---------------                       
          
Although you should wait until you have a good understanding of the program
to add data to it, now is a good time to set up the files associated with
the program.
          
When the UCSD p-System is running and at the main command level, you
should execute (by typing 'X') the MAIL program from whichever disk it
resides on.  After a few seconds the program will say:
          
'Give volume for file MAIL.INFO.DATA (...):'
          
You should respond with something like '#4:', or '4', or 'MAIL1:', or the
name of a presently active diskette.  The default would be '#5:'.  The
program will then inform you that it is making the file.
          
After this, the program will say that it couldn't find the file MAIL.DATA,
and ask you to enter another filename.  If you wish to call your file
MAIL.DATA then enter a blank carriage return, otherwise enter another
filename.  Later on, after you have already used the program, entering this
filename would be all you have to do;  however since you are creating it
you have to specify some other things now. The program will ask you on
which volume you wish to place the file.  Respond with the number or name
of a volume which has at least 5 blocks or enough room to handle a file of
the size you desire (The default for this would be '#5:'). The program will
then ask you the size in blocks for the file that you wish to create.  Five
blocks is the minimum, and if you enter a return it will maximize the size
of the file to the number of remaining blocks on the specified diskette.
The file may be of any size, but you should know now that the program's
sort utility can only handle 250 blocks.  If you know you have a large data
base of information to enter type 250 here.

After all of this is done the program will return with the Mail prompt
line. If these files already exist (as in the second time through) then
the program will go directly to the prompt line. Any time you run the
program it will look for MAIL.DATA.  If not found you will be able to
create it or specify another file. If the other file you specify does not
already exist you will be allowed to create it. The files MAIL.DATA and
MAIL.INFO.DATA will be found, if existent, on either the #4 or #5 disk
drives.  The program will work with single drive systems as well.
          
          
          
          
Prompt line                         
-----------                         
          
So now you have the files and you should see the prompt line:
          
>Mail: A)dd, C)hange, D)elete, F)ind, 1)st, ' ')step, O)ptions, Q)uit ?

You can view the extended prompt line:

>Mail: L)etter, M)labels, S)ort, I)nit, K)runch, R)estore, Z)ero ?

by entering a '?'.
          
          
          
Options                              
-------                            
          
The first command you should explore and work with is the O)ptions command.
This allows you to set up the parameters in the file MAIL.INFO.DATA.  So
type 'O'  for O)ptions and in a few seconds you should get a screen full of
data, along with the prompt line:
          
O)ptions: D)scrps, F)lags, M)labels, L)etter, I)nput, O)utput, Q)uit:
          
Quickly read over the different fields presented on the screen.  The
environment should be set up to input a file called *MAIL.E.G.TEXT and
output it to the screen. Type 'D' for D)escriptions, and we will begin to
actually set up the descriptions for our flags.
          
          
          
Descriptions                         
------------                         
          
You should set one descriptor for every type of record you are going to use
in the file. To do this type the number of the descriptor followed by a
return, followed by the description you wish to tag to that number and
another return.  Some descriptors that have already been mentioned as
potentially useful are:  Employee, Friend, Vendor, and OEM.  The important
thing is that you set as many or more than you need right now, before you
add records to the file, so use your imagination. Do you need a breakdown
on the number of employees?  Would it be useful if you knew if the person
was married or had kids?  There are many that you can probably think of. Be
sure that you have set as many as plausible before proceeding.
          
You may have noticed that flags 44-48 already have descriptions.  They are
prefix, fname, minit, lname, and suffix.  There exists a way to combine the
different fields of the label along with the letter text file.  These flags
allow you to pre-determine what will fall into a super-field called the
greeting. Since in the data file the name is broken up into the prefix,
first name, middle initial, and so on, there must exist a way of putting
them together.  Although you could include the tokens for each of the
individual fields (the method for this will be described later)  it would
be easier if there was one field which would be a common greeting.  These
five flags represent what parts of the file data will go into the greeting-
name.  So given the name 'Mr. Bob R. Smith, PhD.', and the setting of the
flags for Prefix and Lname, the greeting field would come out to 'Mr.
Smith'.  It is important that this is understood before the data is added
to the file.
          
Once you have set the descriptions you may type a 'Q' for Q)uit.  You
should now see the Options prompt line again. You may type 'Q' for quit
again followed by 'U' for update and the information will be written out to
the file. Now you are ready to begin adding information to the file.
          
                    
          
Basic Functions                       
---------------                      
          
The basic functions to establishing a mailing list with the program MAIL
are:
               
A)dd, C)hange, D)elete, R)estore, F)ind, 1)st, ' ')step, S)ort, and Z)ero. 
          
In addition to these basic functions there are the following output
functions:  M)labels (print mailing labels), L)etter, and O)ptions (which
allows you to modify the output parameters, etc).  There is also a class of
functions termed final functions because of their file closing
capabilities.  They are Q)uit (which has the sub-options U)pdate and E)xit
without updating), K)runch, and I)nitialize.  This repertoire of functions
allows for a diversified approach to the management of the data.
          
          
Adding Records                               
--------------                        
          
Once you have all the necessary files, and have set up the descriptions
associated with the flags, you may begin adding records. Enter the command
A)dd and then enter the necessary information. The miscellaneous field may
be used for any purpose you wish. It may be broken down into as many as ten
sub-fields by the use of backslashes.  These subfields or the whole field
may be included in the text of the form letter (as can any other field in
the file) by including a token which will be described later.  After
setting the flags that are associated with the particular record the
program will then display the record and ask 'O.K.? '. Upon answering 'Y'
or 'y' for yes, you will then be allowed to add more records or to process
the record using any of the other commands.
          
          
Changing Information                     
--------------------                                   
          
To change the data in the file merely position the window at the record you
wish to change using the commands S)tep or F)ind, and then enter the
command C)hange. You may then change any field in the record or you may
Q)uit.
          
Whenever you change a record, a backup copy of the original record is made
and is available for your use should you want to make a change for some
temporary purpose or should you find the changes you made unsatisfactory.
To access the back-up on an individual record basis you may type R)estore
and the record will be retrieved and put back into its original place.  If
you wish to restore all the records then you will have to enter either
I)nit OR Q)uit and E)xit without updating.  However, the commands I)nit and
Q)uit E)xit without updating have the unpleasant side effect of also
removing any records you might have added to the work file, so be careful
with their usage.
          
          
Deleting Records                        
----------------                      
          
To delete a record, position the window at the record and type 'D' for
D)elete.  A D)elete is not made permanent until a K)runch or U)pdate is
executed.  This is the same as with C)hange.  Also the same is the fact
that I)nit and Q)uit E)xit without updating will undo a D)elete.  In other
words an I)nit or Q)uit E)xit without updating will restore any D)eletes,
but as with change, you will lose any A)dds you might have done.....  so
use the commands I)nit and Q)uit E)xit without updating cautiously.
          
          
Restore                              
-------                          
          
The command R)estore allows one to retrieve the information that was in a
record before it was C)hanged. To use the command merely position the
window on the record you wish to restore and type 'R' for R)estore and the
record will be returned to its original form. In this way you can change
the data in a record for some temporary purpose without losing the original
information.
          
          
Finding a Record                         
----------------                      
          
The command F)ind allows you to look for a record.

You may search by R)ecnumber, any field in the file, or any previously
entered searchkey.
          
To find a certain record number enter the F)ind command followed by a R)ec#
command and then the record number you wish to be at. The program will then
position itself as close as possible to that record number.
          
If you wish to find by a certain field after entering the F)ind command,
enter the proper field designator (ie. 'F' for F)irstname)  then enter the
identifier you wish to find filled with question marks where you don't
care. (ie. The wildcard '92???' for zip code would find all zip codes
starting with 92. The wildcard '92?' would find all three digit zip codes
starting with 92. )

Find commands using field specifications begin their search at the current
record and search in the set direction until the start or end of the file
is reached.

The symbol '$' may be used as the last character of a wildcard to mean "and
any further characters remaining".  Thus partial matches may be specified.
          
If you already have used the command you may continue processing from the
record you are at searching for the wildcard field you previously entered
by entering a '^'  instead of a field designator.
          
          
1st - First record
------------------

Since it is often necessary to return to the first record of the data
base, '1' for 1)st is provided as a shorthand for F)ind R)ecordnumber 1 at
the command level of MAIL to perform this function.


Step                              
----                             
          
By typing a space (or blank)  you may move the window one record in the
direction specified by the arrow at the beginning of the prompt line. The
commands '>', '+' and '.' will set the arrow in a positive direction wheras
the commands '<', '-' and ',' will set the arrow in the negative direction.
          
          
Sort                            
----                            
          
The command S)ort allows you to sort the file by any field within the file.
When a S)ort is executed a K)runch is also done. This is to insure the
integrity of the file. To sort the file enter a S)ort command followed by
the field designator for the field that you wish the file to be sorted by.
Approximately one point two seconds maximum per record are required for the
sort on a Pascal Microengine. The sort takes approximately two point four
seconds maximum per record for a Z-80 based microcomputer.
          
          
Zero                              
----                             
          
The command Z)ero allows you to zero out the mailing labels file.  However,
when it asks 'Caution: Type 'YES' if you want to zero out the file:', you
must type out the word 'YES'. A 'Y' response is not sufficient.  This is a
safeguard to stop one from accidently destroying the file. This change is
NOT reversable by the I)nit or Q)uit Exit without updating commands, IT IS
PERMANENT.
          
          
          
Options                                   
-------                         
          
The Options command allows you to set the input and output file, output
formatting parameters, and the record selection criteria. The sub-commands
under O)ptions are:  D)escriptions, F)lags, M)ailing labels, L)etter,
I)nput, and O)utput. The next few paragraphs define the action of the
commands under the O)ptions command.
          
          
Input and Output                      
----------------                        
          
The command O)utput allows one to change the device to which the output
will be directed.  The terminal is designated as '#2:', the printer port is
'#6:' or 'PRINTER:', and the remote port is '#8:' or 'REMOUT:'. You may
also specify a filename such as '#5:MAILING.TEXT' as your purpose
dictates.
          
The I)nput command refers to the input file used in producing L)etters. The
command will only allow the entry of a legitimate file that is available
on a disk presently active in the system.  This file contains text along
with optional formatting information.  The exact format of the formatting
information will be included in the section 'Word Processing'.
          
          
Flags                             
-----                           
          
S)et and R)emove may be used to alter the flags used for record selection
in the L)etter and M)labels MAIL commands.

There are two different O)ptions for the use of the flags.  The first -
A)ll - specifies that for each match flag set, the corresponding record
flag must also be set. Hence all flags must match before any record will be
output. The second option - S)ingle - specifies that if any single record
flag is in the set of selection critera then the record will be included
for output.
          
You may set the D)escriptions associated with each flag arbitrarily.  The
only descriptions that the program reserves for its own use are: Prefx,
Suffx, Lname, Fname, and Minit.  If these reserved flags are S)et, they
will be used as standard flags for creating the greeting token when
processing letters.  If none of these are set, a default form of greeting
is used.
          
You may dump the current flags set and descriptions by entering a D)ump
command under the sub-command: F)lags.
          
          
Mailing Labels Format                            
---------------------                    
          
The variable parameters for mailing labels are: 

     type - may be rolodex or envelope 
            (rolodex includes phone number)     
     number of mailing labels wide to a page.  
     vertical tab between rows of labels  
     left margin after EACH label     
          
          
Letter Format                        
-------------                        
          
For outputting Letters, the parameters that are contained under the
O)ptions command are as follows:
              
     the directive character used in letters (the default is '~')
     number of characters per line of text 
     number of lines per page of text 
     top margin   
     left margin 
     right margin 
     paragraph margin (indentation) 
     paragraph widow (do not start a new paragraph if 
                      within this number of lines from the      
                      bottom of the page) 
     starting page number 
     pagination (on-off)
     justification (on-off)
     stop between pages (on-off)  
     form feed between pages (on-off)
     flagged paragraph matching option (A)ll or S)ingle)       
           (Recall  that  there was an option as to whether a
           single  flag was  sufficient  or if all flags were
           to match  before a record  would be  output. As it
           was for the  selection of records so it is for the
           inclusion  of  paragraphs.  There is an  option by
           which  you can  determine  whether  to  include  a
           paragraph  if a single  flag  matches  or if it is
           necessary that all flags must match.)
         
The method of changing any of these parameters is straightforward and
should be self-explanitory upon the running of the program.
 
 
Page Layout
-----------

Each line of text is made up as follows:

<...left margin...><...text...><...right margin...>
<...............characters per line...............>

At the start of each paragraph, the text is indented the set number of
characters for the paragraph margin as well as the left margin (ie the
paragraph margin is the number of characters to be indented from the left
margin edge).  When paging is NOT selected, a number of blank lines equal
to the set top margin are output for each letter and then the whole
document follows on a line by line basis (subject to the formatting options
embedded in the letter itself).

When paging is selected, the pages are processed as follows:-

     1.  top margin blank lines
     2.  text lines at the required line spacing
     3.  a 5 line footer which on letters over one page long will
         have a page number on the 3rd line
     4.  an optional form feed (for sheet feeders, etc)
     5.  an optional pause to allow the user to manually insert
         or align paper in the printer.
         
1, 2 and 3 together comprise the set number of lines per page.
         
         
Quit option                          
-----------                         
          
Once you have entered the O)ptions command you may make changes to any of
the parameters listed above until such a time as you decide to Q)uit. Upon
Q)uitting you have three options.  R)eturning allows you to continue
changing parameters.  U)pdating makes permanent any changes you have made
during O)ptions.  Lastly, E)xit without updating allows you to return the
output parameters to the state they were in when you first entered
O)ptions.  
          
          
          
M)labels
--------                           
          
When an M)labels command is issued there are four choices for output. The
first:  S)ingle, allows a record to be added to the mailing label output
queue, regardless of the flags set. The second:  A)ll will loop through all
records and use the flag selection criteria for adding labels for records
to the output queue.  The flag selection criteria must have been previously
set in the O)ptions MAIL command. The command W)ildcard has a similar
function to the F)ind function except that labels for EVERY record matching
the wildcard are output, not just the first one. And lastly there is the
R)epeat function which allows you to generate as many copies of the current
record in the window as you please.  Its use is straightforward and need
not be discussed here.
          
You will notice that above it was mentioned that the labels for records
will be added to the 'output queue'.  What this means is that if you have
set the parameter for the number of labels wide to a page to three, then NO
labels will be printed until three records have been added to the queue.
This only applies to S)ingle print commands, as the commands A)ll,
W)ildcard, and R)epeat will dump any remaining records in the queue upon
completion of their loop, regardless of how many there are.


Letter                            
------                           
          
The command L)etter has a similar function to M)labels, but there is no
queue to worry about.  The sub-commands:  A)ll, S)ingle, and W)ildcard are
available.  The L)etter command, A)ll and W)ildcard options process
records from the currently selected record onwards.  This allows for a
simple recovery mechanism in case of print failure on long form letter
runs.  Note that the ribbon and paper out detection lights on the printer
are not monitored by the program.  Therefore, the user should ensure that
enough paper is available and that the ribbon will not run out before
starting any long letter runs.
          
          
                    
Final Commands                       
--------------                        
          
The commands that are included under final commands are: Q)uit, I)nit, and
K)runch.
          

Quit                                
----                             
          
The command Q)uit has three sub-commands.  R)eturn allows you to continue
the session.  U)pdate performs a K)runch, (see below) then leaves the
program.  E)xit without updating resets the records to their original
status and leaves the program.
          
          
Init                              
----                               
          
I)nit resets the program (apart from Z)ero or any changes in O)ptions) to
its beginning state.
          
          
Krunch                            
------                            
          
K)runch makes any A)dds, D)eletes, and C)hanges permanent.
          
                            
          
Word Processing                           
---------------                      
          
The command L)etter invokes the word processor to act upon the input file
listed in the O)ptions section.  The command L)etter allows for either
S)ingle, A)ll (with flag criteria), or W)ildcard selection of records for
combination with text.  The input file is processed sequentially from start
to finish for each record selected to be output.
          
          
Special Characters                      
------------------                     
          
There are special characters, that when encountered in the input file by
the program, have special functional meanings.  Some of the characters are
actually two character combinations that are treated as single characters. 
          
The special characters are:
          
    ^      -  when the option 'pagination' is set to 'yes'
              throws a page when encountered as the first character of
              the line 
              (ASCII 94, carat, andsymbol ...)  
          
    =      -  when the first character in the line causes the following
              carriage return to be suppressed if the line evaluates to
              a blank line 
              (ASCII 61, equals ...) 
               
    ~      -  causes the line which contains it to be output literally
              (not formatted into paragraphs)  
              (ASCII 126, tilde, squiggle ...) 
          
              The '~' is the default directive character.  It may be
              altered in the O)ption section of MAIL.  This could be
              of value on terminals which cannot generate '~'.
          
The two character combinations are:   
          
[:  ,  :]  -  (left square bracket, colon) (colon,right square bracket)  
              (ASCII 91, ASCII 58) (ASCII 58, ASCII 93)  
              - mark special margin and spacing values 
              
{%  ,  %}  -  (left curly bracket, percent) (percent, right curly bracket)    
              (ASCII 123, ASCII 37) (ASCII 37, ASCII 125)
              - mark what is termed a flagged paragraph      
          
(*  ,  *)  -  (left parenthesis, asterisk) (asterisk, right parenthesis) 
              (ASCII 40, ASCI 42) (ASCII 42, ASCII 41) 
              - mark what is termed a 'Token'     
  
  \\       -  (backslash, backslash)
              (ASCII 92, ASCII 92)
              - in the interest of simplifying the usage of the
                text processor it is possible to insert a
                formatted mailing label anywhere in the text by
                merely including a double backslash (\\) at the
                beginning of a line.
          
*** all ascii values given in decimal  
           

Flagged Paragraphs                         
------------------                        
          
When the character {% is encountered it is assumed to start what is called
a flagged paragraph.  Everything between {% and %} is considered in the
paragraph, whether it be part of a line or a page, whether it contains
tokens, or any other special characters.
          
A flagged paragraph is only included if the flags on the record that is
currently be output are set correctly. There are two options for the
selection of a paragraph. They are S)ingle and A)ll.  S)ingle means that if
any single flag in the record matches one of the flags specified in the
paragraph then the paragraph is output. A)ll means that all flags must
match.
          
The method for setting flagged paragraphs is that the opening '{%' is
followed by a flag number (1-48)  and a slash (/). As many flags as you
desire may be included at the beginning of any paragraph.
          
      ie.  given the flagged paragraph:  {%1/2/ Hello there %} 
           the words 'Hello there' would be included in the letter   
           if:   a) flagged paragraph option is set to A)ll            
                    and record flags 1 AND 2 are set, 
           or:   b) flagged paragraph option is set to S)ingle
                    and record flag 1 OR 2 is set.
          
You may also indicate that text is to be include if a flag is NOT set by
listing that flag as a negative number.
          
      ie.  given that the option is set to A)ll and the flagged
      paragraph: '{%1/-2/ Hello there %}', then the words 'Hello
      there'  will only be included if flag 1 is set and flag 2
      is NOT set.
                
Flagged paragraphs may be nested to any level.
          
          
Fields in a record                         
------------------                      
          
There exists a method of combining the data from the file with the letter
text. The information from the file is made up of groups of letters called
'fields'.  For our purposes some method of designating the fields is
necessary.
          
      The designations for the fields in the record are as follows:     
      (they may be upper or lower case)   
      PR  -  prefix to the name
      FN  -  first name
      MN  -  middle initial
      LN  -  last name
      SU  -  suffix to the name  
      TI  -  title
      CN  -  company name
      AD  -  address 
      CI  -  city
      ST  -  state
      CO  -  country
      ZI  -  zip or post code
      PN  -  phone number
      MI  -  miscellaneous
      M0 to M9   parts of miscellaneous field
          
In addition to these fields there is another field called the 'greeting'
which is designated 'GR'.
          
          
Greeting                                
--------                           
           
It would be wise to discuss the concept of 'standard flags'  here.  Recall,
if you will, that there were five flags which were reserved for system use.
These flags, if set on a particular record, decide which name fields will
be combined into the 'greeting'.  If a particular record does not have any
of the five flags set or the setting does not lead to the production of a
greeting, the setting of the default standard flags are used to try to
produce a greeting for the record.  If no standard flags are set then the
greeting field will be the prefix and the last name.  If the prefix is
blank then the greeting will the first name.  If none of these provide
reasonable results the greeting will be 'Sir'.
          
          
Tokens                            
------                           
          
Anything on a single line falling between (* and *) is considered a token.
The main use of tokens is to include some data from the record, in a
formatted way, with the letter. The token '(*FN*)'  evaluates to the first
name from the record. So, given the phrase 'Hello there (*FN*)', and a
record for 'Harry S. Smith', the letter would end up with 'Hello there
Harry'.  A field size designator may be included, and justification within
this field is indicated by the presence of blanks within the token.
          
       ie. (* FN:60 *)    -    first name centered in 60 spaces. 
           (* LN:60*)     -    last name right justified in 60 spaces.  
           (*GR:60 *)     -    greeting left justified in 60 spaces.
          
Sometimes it is nice to be able to have the presence or absence of a group
of characters contingent on a field being blank or not. This is done by
following that field with the desired characters in between equals signs.
For instance when putting the personal title on a line with company name
you will want a comma and a space if the title is not blank, but if the
title is blank you don't want the extra comma. The way to specify this is:
            
           (*TI*)=, =(*CN*)   (everything between the equals signs 
                               is included only if the title is not   
                               blank)
          
The last aspect of tokens to be discussed is nested tokens.  Tokens may be
nested ONLY two deep. Any deeper tokens will cause the program to botch at
that point.
          
      ie.  (* (*FN*) (*MN*)= =(*LN*):60 *) will cause the first name       
            middle initial (and blank if there is a middle initial),   
            and last name to be combined into one field, and that     
            larger field to be centered in 60 spaces.     
           (* This is the name (*FN*):60 *) will cause the words: 
            'This is the name' to combined with the first name from    
            the record into one large field and for this larger field 
            to be centered in sixty spaces.   
           (* Center This:60 *) will cause the words 'Center This' to 
            be centered in 60 spaces.
          
          
Spacing and Margins                       
-------------------                    
          
Anything between '[:'  and ':]' is considered for parsing as a spacing
designator or a margin designator. [:L30:]  says set the left margin to 30,
[:R30:]  does the same thing for the right margin.  [:S2:]  means switch to
double spacing, [:S1:]  means switch to single spacing. These parameters
are reset to their default settings upon the start of a new paragraph.
          
          
General Rules                          
-------------                        
          
The program will take sentences from the file and combine them into
paragraphs.  Any blank line is assumed to start (or end) a paragraph. Hence
the necessity of the '~' special character.  If you have a line in a letter
that consists only of (* FN:60 *)  and another line that consists of only
(* LN:60 *)  then upon output these two lines will be combined into one
line of a paragraph and the spacing information in the letter will be
ignored to allow for right justification.  If the spacing layout is to be
preserved, a direction character ('~' by default) should be included
anywhere in a line.  When a direction character is encountered, the line
will be output without justification or other layout changes (the '~' will
be removed).
  
          
The only other character that needs further explaining is the '=' at the
beginning of a line.  This means that if the line evaluates to a blank line
then DO NOT count the carriage return at the end of the line. One use for
this is:
          
            given two lines:
                             ~(* (*FN*) (*LN*) *)
                             =~(* (*TI*)=, =(*CN*) *)
          
there would be no blank line if there were no company or title.  This is
usually used on letterheads containing a mailing label. 
          
          
          
Summary                           
-------                           
          
This concludes the user manual for the program Mail. There is a file of
examples called 'MAIL.E.G.TEXT'  which you should dump and then run through
the letter processor so you can see exactly how it works in practice.
Please direct any questions or comments to the:
          
ERCC Microcomputer Support Unit

in the first instance.


          
Notes
-----
          
I  Implementation Notes
   --------------------
  
Format of MAIL data file
------------------------

For anyone wishing to access the mailing labels data the file format is
defined as follows:
           
      TYPE labelrec = RECORD        
                       code   :STRING[6];  
                       lname  :STRING[15];    
                       fname  :STRING[10];  
                       minit  :STRING[2]; 
                       prefx  :STRING[5];  
                       suffx  :STRING[6]; 
                       title  :STRING[15]; 
                       coname :STRING[30]; 
                       phone  :STRING[15];    
                       address:STRING[30];     
                       city   :STRING[15]; 
                       state  :STRING[2]; 
                       country:STRING[15]; 
                       zip    :STRING[8];  
                       misc   :STRING[90];
                       flags  :ARRAY[1..48] OF BOOLEAN; 
                      END;   
          
Overview of the operation of the MAIL program
---------------------------------------------

Mail System Data File:

The mail system maintains a direct access file of mail records.  Record 0
is special and holds the current maximum record in the zip field (as a
string).  The system can claim space for new records so long as there is
unused space on the disk following the current mail records file.  So, it
is straightforward to move files to allow for expansion of a mail data file
up to a complete disk if needed.  There are no limits built into the
program in this respect. However, if a S)ort is to be done, it is
recommended that there be a maximum of 350 record entries (as heap space is
used during the sort).

Code entry on records:

A 'code' entry is kept with each record.  This holds 'Perm' for normal
entries.  Record 0 also has 'Perm' in its code. During the execution of the
system, various values are placed in here ('Add', 'Change', etc.).  Deleted
records have a blank code entry. Such blank entries are used, where
possible, before new space is allocated for A)dded records.

Backup linked list of records:

As records are changed, the old versions are kept on a linked list of
backup records.  The new versions are then put in the main data file.
R)estore operations on a record or a Q)uit from the program and E)xit
without updating can then use this list to restore the old values.

II Restrictions on file sizes
   --------------------------

The mailing label file may be of any size, however the S)ort routine is
only capable of safely handling 350 records or approximately 250 blocks of
data. This should be taken into consideration when building files and using
the system.



ERCC Notes
----------

I   Initialisation of MAIL data files
    ---------------------------------

The utility MAIL.INIT may be used to convert a text file containing name,
addresses and information fields into MAIL data records.  The input format
expected is:

<blank line>
name                       and its maximum width is 30
company name                                        30
address                                             30
city, zip or post code           15 for city, 8 for zip or post code
miscellaneous information                           90                     
<blank line>
<blank line>
<blank line>

This can be repeated for further individuals.  Note that a comma is used to
separate a city from any zip or post code present.

An example of an input file for the MAIL.INIT utility is available on the
release disk as file MAILINITEG.TEXT.


II  Conversion of MAILER names and addresses into MAIL
    --------------------------------------------------

The ERCC initially supported a simple mailing label manager named MAILER.
The MAIL system is intended to replace this package and to increase the
facilities available to users. In order to protect the investment already
made in data capture of mailing information by MAILER users, the utility
MAIL.INIT may be used to read text files produced as output by MAILER (i.e.,
the format defined for input to MAIL.INIT is that produced as output from
the earlier MAILER system).

The MAIL.INIT program should be self explanatory.  Besides importing name,
address and miscellaneous information to MAIL records, it allows a single
MAIL Flag to be set on each record imported.  This is useful if you wish to
mark all the imported records as belonging to some grouping (e.g., all
members of a single committee).  Further uses of the MAIL data file for
other purposes can then add to the records by using other Flags to
differentiate the groupings.

MAIL.INIT creates a new MAIL data base and populates it with the names and
addresses in the given input file.

Note that there may not be an exact correspondence between your original
address fields (which could have unrestricted use) and those assigned in
MAIL.  However, it should enable simple interactive changes to the new MAIL
data file to be made in MAIL itself.

The actual mapping of the information fields is:

         MAILER         --->            MAIL
         name                           Prefix,Fname,Minit,Lname,
                                        Suffix or title
         address 1                      company name
         address 2                      address
         address 3                      city, zip or post code
         information                    miscellaneous

III  Increasing the size of a MAIL data file
     ---------------------------------------

A MAIL data file will grow to occupy the free (unused) space on a disk
following the existing data file.  If the data file becomes full and
deletions cannot be made, you should copy the existing data file to a
larger unused area to ensure that free (unused) space is available
following it.  The UCSD Filer can be used to achieve this by K(runching
disks, C(hanging file names and T(ransferring files.  After the operation,
the MAIL data file should retain its original name.


IV   Data Manipulation on records of your own description
     ----------------------------------------------------

If you require functions similar to those provided in MAIL but on records
of your own description, you could investigate the FORMULEX package
provided on various UCSD systems (including SuperBrain and Apple II).  This
system lets you define your own screen form with various fields and gives
facilities to build up a file of such records.  Record searching and file
manipulation is provided for.  The system is one of a selection of systems
which provide 'electronic form' interfaces to data.

The form letter production facility of MAIL is not directly available in
FORMULEX.


V    Producing files for SORT/MERGE operations
     -----------------------------------------

SORT/MERGE is a package which enables files of records to be sorted
according to some key fields.  One version of the package is available to
sort text files consisting of fixed single line records according to up to
6 keys.  The L)etter facility of the MAIL program may be used to output
files in a form suitable for SORT/MERGE operations.

A L)etter I)nput file is prepared which consists of a single line defining
the record format.  It should be preceeded by the tilde ('~') character to
prevent justification.  Fixed width fields can be forced by
(*<token>:<width>*)  (e.g., (*LN:30*) will put out the Last Name in a field
of width 30 characters).  An example might be:

~(*FN:30*)(*LN:30*)(*CN:30*)

This should be placed as the I)nput filename in the O)ptions section of
MAIL or given explicitly as the input file name for L)etter.  The O)utput
filename should be specified as some disk file.  This will become the input
to a subsequent SORT/MERGE operation.  It is also necessary to set up the
L)etter O)ptions such that non-paginated, non-stop-between-pages, output
with no top, left or right margins is produced.  The characters on a line
should be set wider than the record width to be written to the O)utput
file.  All these options may be set in the MAIL O)ptions command.

You may then do a L)etter operation and use a selection criteria which will
produce an output record for each MAIL record selected. This O)utput file
will become the input to SORT/MERGE operations. Note that any additional
blank lines inserted by MAIL between records will be ignored by SORT/MERGE.


========================================================================================
DOCUMENT :usus Folder:VOL11:mail.e.g.text
========================================================================================

This is a file of examples for the L)etter command of the program        
mail. The fields available for insertion anywhere in the letter are:

~ prefix to the name   :  (*PR*)
~ first name           :  (*FN*)
~ middle initial       :  (*MN*)
~ last name            :  (*LN*)
~ suffix to the name   :  (*SU*)
~ title                :  (*TI*)
~ company name         :  (*CN*)
~ phone number         :  (*PN*)
~ street address       :  (*AD*)
~ city                 :  (*CI*)
~ state                :  (*ST*)
~ country              :  (*CO*)
~ zip                  :  (*ZI*)
~ whole misc field     :  (*MI*)
~ misc sub-fields      :  (*M0*), (*M1*), (*M2*), (*M3*), (*M4*),
~                         (*M5*), (*M6*), (*M7*), (*M8*), (*M9*)

In addition to these other fixed fields there is one variable 
field called the 'Greeting' (in this case : (*GR*)).    
This field can be set up to a predetermined subset of the whole name
by using the 5 STANDARD FLAGS (44-48), or will default to an     
appropriate greeting (ie Mr. Smith  if possible or Bob or etc...)

~These fields may be left justified:  
~(*GR*)
~(* right justified::60*)  
~(* GR:60*)
~(* or centered::60 *) 
~(* GR:60 *)
~in any number of spaces.

The fields may be combined with or without regular text 
into larger tokens and these tokens may  
be left, right, or center justified just as individual tokens:
~(* (*PR*) (*FN*) (*MN*) (*LN*) (*SU*):60 *)

The right justification is automatic and
text
is 
taken
from
succsesive 
lines 
as
necessary
to 
make
up 
paragraphs.
In
fact,
the 
text
for
this
paragraph
is 
stored
as
consecutive
lines
of
single
words.
This is important when introducing tokens can upset the length of the line.
Lines can be input upto 255 characters in length with complete integrity
upon output. 

{%30/Flagged paragraphs are structures which allow individual records     
or groups of record to include specifed words, sentences, or paragraphs        
in text. 
Flags may be nested any number deep but tokens may only be nested one
level deep.
{%31/This sentence has the flag 31 tied to it. %}{%32/33/   
This sentence has the flags 32 and 33 tied to it. %}{%-32/You can 
specify sentences or paragraphs to be added if certain flags are NOT
set. %} In fact you can specify any number of flags to be set or
NOT set, and you can also determine if ALL specified flags (or NOT flags)
are necessary to include the
 paragraph or only ONE of the specified flags is needed.

%} 

[:l20:][:r20:]Spacing and Margin commands may be included in the text which will  
[:s3:]affect the output at the first opportunity and will last until a  
[:s2:][:r30:]new paragraph is started. At the beginning of each and every paragraph 
[:s1:][:l30:]the spacing and margins  are assigned to their default values.  
This is an example of these spacing and margin commands which
can be used for various purposes.

Within the program the records can be processed in a sequential manner.
Records can be selected for output to mailing labels or letters singly, or
by wildcard from any field, or to match a flag 
mask, or any combination therof.
The records may also be sorted by any field within the record.

The program has been made fail-safe by allowing one to Abort or
Update upon leaving or to individually Restore any record
changed. The program is self-initializing if the files are already
present. If not it allows one to specify the file upon which it
will act, and the disk upon which the output format data file 
will go. %}

========================================================================================
DOCUMENT :usus Folder:VOL11:mail.form.text
========================================================================================

~+----------------------------------------------------------+
~| Name:     (* (*PR*) (*FN*) (*MN*)= =(*LN*) (*SU*):47*) |
~|           (* (*TI*)=; =(*CN*):47*) |
~| Address:  (* (*AD*):47*) |
~|           (* (*CI*)=, =(*ST*)=, =(*CO*)=, =(*ZI*):47*) |
~+----------------------------------------------------------+
~| Phone:    (* PN:47*) |
~+----------------------------------------------------------+
~| Greeting: (* GR:47*) |
~+----------------------------------------------------------+
~| Misc [0]: (* M0:47*) |
~| Misc [1]: (* M1:47*) |
~| Misc [2]: (* M2:47*) |
~| Misc [3]: (* M3:47*) |
~| Misc [4]: (* M4:47*) |
~| Misc [5]: (* M5:47*) |
~| Misc [6]: (* M6:47*) |
~| Misc [7]: (* M7:47*) |
~| Misc [8]: (* M8:47*) |
~| Misc [9]: (* M9:47*) |
~+----------------------------------------------------------+
~| Flags   : (*{%1/1 %}{%2/2 %}{%3/3 %}{%4/4 %}{%5/5 %}{%6/6 %}:47 *) |
~|           (*{%7/7 %}{%8/8 %}{%9/9 %}{%10/10 %}{%11/11 %}{%12/12 %}:47 *) |
~|           (*{%13/13 %}{%14/14 %}{%15/15 %}{%16/16 %}{%17/17 %}{%18/18 %}:47 *) |
~|           (*{%19/19 %}{%20/20 %}{%21/21 %}{%22/22 %}{%23/23 %}{%24/24 %}:47 *) |
~|           (*{%25/25 %}{%26/26 %}{%27/27 %}{%28/28 %}{%29/29 %}{%30/30 %}:47 *) |
~|           (*{%31/31 %}{%32/32 %}{%33/33 %}{%34/34 %}{%35/35 %}{%36/36 %}:47 *) |
~|           (*{%37/37 %}{%38/38 %}{%39/39 %}{%40/40 %}{%41/41 %}{%42/42 %}:47 *) |
~|           (*{%43/43 %}{%44/44 %}{%45/45 %}{%46/46 %}{%47/47 %}{%48/48 %}:47 *) |
~+----------------------------------------------------------+


========================================================================================
DOCUMENT :usus Folder:VOL11:mail.info.data
========================================================================================

< binary file -- not listed >

========================================================================================
DOCUMENT :usus Folder:VOL11:mail.init.text
========================================================================================

{Mail.Init - convert a text file to MAIL data file}
{
23-Feb-82 AT
}
{      
** program    : MAIL - Text processing mailing label data manager.         **
** authors    : Patrick R. Horton, Associated Computer Industries          **
**              Austin Tate, Edinburgh Regional Computing Centre           **
** Copyright  : (C) 1982, Austin Tate, ERCC                                **
**              Permission to use this program for non-profit purposes     **
**              is hereby granted, provided that this note is included.    **
**              Enquiries concerning uses for other purposes should be     **
**              directed to the copyright owner.                           **
}

{$S+} { V-} {pragma needed on Apple}
PROGRAM MailInit;
{the format accepted is that output by the print labels option of MAILER}
{this will allow movement from the earlier supported mailing list system}

{   format is   <blank>                   maps to MAIL component:
                name                      prefix, fname, minit, lname,
                                          suffix or title
                address line 1            company name
                address line 2            address
                address line 3            city, zip or post code
                information               miscellaneous
                <blank>
                <blank>
                <blank>
     which reflects the output format for labels printed at 6 lines per inch
}
     TYPE rec1 = RECORD    
                  code    :STRING[6]; 
                  lname   :STRING[15];   
                  fname   :STRING[10];
                  minit   :STRING[2];
                  prefx   :STRING[5];
                  suffx   :STRING[6];
                  title   :STRING[15];
                  coname  :STRING[30];
                  phone   :STRING[15];   
                  address :STRING[30];    
                  city    :STRING[15];
                  state   :STRING[2];
                  country :STRING[15];
                  zip     :STRING[8];  
                  misc    :STRING[90];
                  flags   :ARRAY[1..48] OF BOOLEAN; 
                 END;   
     VAR disk1                  : FILE OF rec1;  
         finp                   : TEXT;
         fname1,fname2          : STRING;
         iname,addr1,addr2,addr3: STRING;
         info                   : STRING[90];
         numrecs,FLAGNO,at,temp : INTEGER;  
         ch                     : CHAR; 
         InputOK                : BOOLEAN;

 PROCEDURE Fixit(VAR s: STRING);
  BEGIN
   temp := 0;
   WHILE temp<LENGTH(s) DO 
    BEGIN
     temp := temp + 1;
     IF NOT (ORD(s[temp]) IN [32..126]) THEN 
      BEGIN
       WRITELN('illegal char at pos=',temp,'   chr=',ORD(s[temp]));
       DELETE(s,temp,1); 
       temp := temp - 1;
      END;
    END;
  END;
  
PROCEDURE Pget;
 BEGIN
   {$I-}
   readln(finp);
   readln(finp,iname);
   readln(finp,addr1);
   readln(finp,addr2);
   readln(finp,addr3);
   readln(finp,info);
   readln(finp);
   readln(finp);
   readln(finp);
   {$I+}
   writeln('--------------------------------------');
   writeln(iname);
   writeln(addr1);
   writeln(addr2);
   writeln(addr3);
   writeln(info);
END; 

PROCEDURE Str(i : INTEGER; VAR s : STRING);         
 VAR startedstring : BOOLEAN;  
     factor        : INTEGER;                  
     numstr        : STRING[9];
 BEGIN   
  s := '';
  IF i < 0 THEN  
   BEGIN
    s := '-';
    i := - i;
   END;
  numstr := '123456789';
  startedstring := FALSE; 
  factor := 10000;
  WHILE factor<>0 DO    
   BEGIN
    IF i >= factor THEN   
     BEGIN
      s := CONCAT(s,COPY(numstr,i DIV factor,1));     
      i := i - (i DIV factor)*factor;               
      startedstring := TRUE;
     END
    ELSE IF startedstring THEN s := CONCAT(s,'0');
    factor := factor DIV 10;
   END;  
  IF LENGTH(s) = 0 THEN s := '0';    
 END;  

(*$I-*) 
FUNCTION Chkfiles(var s : STRING; suffix:string) : BOOLEAN;     
 VAR intb : BOOLEAN;
 BEGIN
  intb := TRUE; 
  RESET(disk1,s);  
  IF IORESULT <> 0 THEN
    begin
      close(disk1);
      s:=concat(s,suffix);
      reset(disk1,s);
      if ioresult<>0 then intb := FALSE;
    end;
  CLOSE(disk1); 
  Chkfiles := intb; 
 END;  
(*$I+*)
 
PROCEDURE Uppercase(VAR s: STRING);      
 VAR t : INTEGER;
 BEGIN
  FOR t := 1 TO LENGTH(s) DO
   IF s[t] IN ['a'..'z'] THEN s[t] := CHR(ORD(s[t])-32);  
 END;

FUNCTION Val(s : STRING) : INTEGER;                     
 VAR i,j,k: INTEGER;                      
 BEGIN   
  j := 0; k := 0; i := 1;         
  IF LENGTH(s)<>0 THEN
   BEGIN
    IF (LENGTH(s)>0) AND (s[1] = '-') THEN
      BEGIN
         k := k + 1;i := -1;
      END;        
    IF k<LENGTH(s) THEN      
     REPEAT
      k := k + 1; 
      IF (k<=LENGTH(s)) AND (s[k] IN ['0'..'9']) THEN     
       BEGIN
        j := j * 10; 
        j := j + ORD(s[k]) - 48;  
       END; 
     UNTIL (k=LENGTH(s)) OR NOT(s[k] IN ['0'..'9']);   
   END;
  Val := i*j;   
 END (* Val *);      
      
PROCEDURE Wnew0rec;
 BEGIN
  disk1^.code := 'Perm  ';
  STR(numrecs,disk1^.zip);
  SEEK(disk1,0);
  PUT(disk1);
 END;
 
PROCEDURE Zerodisk1;
 BEGIN
  WITH disk1^ DO
   BEGIN
    code    := 'Perm  ';  
    country := '';  
    city    := '';    
    lname   := '';
    fname   := '';
    minit   := '';
    prefx   := '';
    suffx   := '';
    title   := '';
    coname  := '';                     
    phone   := '';              
    address := '';
    state   := '';  
    zip     := '';
    misc    := ''; 
    FOR temp := 1 TO 48 DO flags[temp] := FALSE; 
   END;
 END; 
      
PROCEDURE Getname;
 VAR tfile : TEXT;
     token : ARRAY[1..10] OF STRING;  
     postoken : STRING;
     ntokens,temp1 : INTEGER;  
     tstring : STRING;
 
  PROCEDURE Decrntokens;
   VAR temp2 : INTEGER;
   BEGIN 
    FOR temp2 := 1 TO ntokens - 1 DO 
     token[temp2] := token[temp2+1];
    ntokens := ntokens - 1;
   END;
   
  PROCEDURE Chkprefix;   
   BEGIN
    tstring := token[1];
    Uppercase(tstring);
    IF POS('.',tstring)<>0 THEN DELETE(tstring,POS('.',tstring),1);
    IF (tstring='MR') OR
       (tstring='MRS') OR
       (tstring='MISS') OR
       (tstring='DR') OR
       (tstring='MS') OR
       (tstring='PROF') OR
       (tstring='SIR') THEN
     BEGIN
      disk1^.prefx := token[1];
      Decrntokens;
     END;
   END;
   
  PROCEDURE Chksuffix;
   VAR cflg : BOOLEAN;
       temp:integer;
   BEGIN 
    WHILE POS(' ',postoken) = 1 DO DELETE(postoken,1,1);
    tstring := postoken; 
    Uppercase(tstring);
    if pos('.',tstring)<>0 then delete(tstring,pos('.',tstring),1);
    IF (tstring = 'PHD') OR
       (tstring = 'MD' ) OR
       (tstring = 'DDS') OR
       (tstring = 'II' ) OR
       (tstring = 'III') OR
       (tstring = 'IV' ) OR
       (tstring = 'V'  ) OR
       (tstring = 'MA' ) OR
       (tstring = 'BA' ) OR
       (tstring = 'BS' ) OR
       (tstring = 'BSC') OR
       (tstring = 'MS' ) OR
       (tstring = 'MSC') OR
       (tstring = 'AA' ) OR
       (tstring = 'EE' ) OR
       (tstring = 'EDS') THEN
     BEGIN
      disk1^.suffx := postoken; 
     END
     ELSE
     BEGIN 
      IF LENGTH(postoken)<=15 THEN disk1^.title := postoken
       ELSE 
        BEGIN
         disk1^.title := '               ';
         FOR temp := 1 TO 15 DO disk1^.title[temp] := postoken[temp];
        END;
     END;
   END;   
  
  PROCEDURE Firstname;  
   BEGIN
    IF ntokens <= 1 THEN EXIT(Firstname);
    IF LENGTH(token[1])<= 10 THEN disk1^.fname := token[1] 
     ELSE {take initial}
      disk1^.fname := CONCAT(COPY(token[1],1,1),'.');  
   END; 
   
  PROCEDURE Middleinitial;
   BEGIN
    IF ntokens <= 2 THEN EXIT(Middleinitial);
    IF LENGTH(token[2])>2 THEN  
     BEGIN {take initial}
      disk1^.minit := COPY(token[2],1,1); 
      disk1^.minit := CONCAT(disk1^.minit,'.');
     END
    ELSE disk1^.minit := token[2];
   END;    
   
  PROCEDURE Lastname;    
   var temp:integer;
   BEGIN
    IF ntokens = 0 THEN EXIT(Lastname);        
    IF ntokens <= 3 THEN
     BEGIN
      IF LENGTH(token[ntokens])<=15 THEN disk1^.lname := token[ntokens]
       ELSE 
        BEGIN
         disk1^.lname := '               ';
         FOR temp := 1 TO 15 DO disk1^.lname[temp] := token[ntokens][temp];
        END;
      ntokens := 0;
     END  
    ELSE
     BEGIN
      IF LENGTH(token[3])<=15 THEN disk1^.lname := token[3]
       ELSE 
        BEGIN
         disk1^.lname := '               ';
         FOR temp := 1 TO 15 DO disk1^.lname[temp] := token[3][temp];
        END;
      ntokens := ntokens - 3;
     END;
   END;  
   
   
  PROCEDURE Anymore; 
   BEGIN
    IF ntokens<>0 THEN {there is more in the name}
      begin
        {do nothing at present}
      end;
   END; 
   
 BEGIN   
    ntokens := 0; 
    postoken := ''; 
    IF POS(',',iname) > 4 THEN
     BEGIN
      postoken := COPY(iname,POS(',',iname)+1,LENGTH(iname)-POS(',',iname));
      DELETE(iname,POS(',',iname),LENGTH(iname)-POS(',',iname)+1);
     END;
    IF LENGTH(postoken)<>0 THEN Chksuffix;
    {now suffix coped with convert . in name to spaces for tokenisation}
    while pos('.',iname)<>0 do iname[pos('.',iname)]:=' ';
    WHILE (ntokens<10) AND (LENGTH(iname)>0) DO
     BEGIN
      ntokens := ntokens + 1;
      token[ntokens] := '';  
      WHILE POS(' ',iname)=1 DO DELETE(iname,1,1);
      IF POS(' ',iname)<>0 THEN 
       BEGIN
        token[ntokens] := COPY(iname,1,POS(' ',iname)-1);
        DELETE(iname,1,POS(' ',iname));   
       END
      ELSE 
       BEGIN
        token[ntokens] := iname; 
        iname := '';  
       END;
      IF LENGTH(token[ntokens]) = 0 THEN ntokens := ntokens - 1;      
     END;  
    IF ntokens = 0 THEN EXIT(Getname);
    IF ntokens = 1 THEN 
     BEGIN
      IF LENGTH(token[1])<=15 THEN disk1^.lname := token[1]
       ELSE 
        BEGIN
         disk1^.lname := '               ';
         FOR temp := 1 TO 15 DO disk1^.lname[temp] := token[1][temp];
        END;
      EXIT(Getname);  
     END;
    Chkprefix;
    Firstname;
    Middleinitial;
    Lastname;
    Anymore;
 END; 
 
PROCEDURE Chgformat;  
 var addrcity,addrzip:string;
     poscomma:integer;
 BEGIN
  Zerodisk1;
  Getname;
  numrecs:=numrecs+1;
  disk1^.misc := info;    
  IF LENGTH(addr1)<=30 THEN disk1^.coname := addr1
   ELSE 
    BEGIN
     disk1^.coname := '                              ';
     FOR temp := 1 TO 30 DO disk1^.coname[temp] := addr1[temp];
    END;
  IF LENGTH(addr2)<=30 THEN disk1^.address := addr2
   ELSE 
    BEGIN
     disk1^.address := '                              ';
     FOR temp := 1 TO 30 DO disk1^.address[temp] := addr2[temp];
    END;
  addrcity:=addr3; addrzip:='';
  poscomma:=POS(',',addr3);
  if poscomma>1 then
    begin
      addrcity:=COPY(addr3,1,poscomma-1);
      if poscomma<>length(addr3) then
        addrzip:=COPY(addr3,poscomma+1,length(addr3)-poscomma);
      {remove leading spaces}
      while pos(' ',addrzip)=1 do delete(addrzip,1,1);
    end;
  IF LENGTH(addrcity)<=15 THEN disk1^.city := addrcity
   ELSE 
    BEGIN
     disk1^.city := '               ';
     FOR temp := 1 TO 15 DO disk1^.city[temp] := addrcity[temp];
    END;
  IF LENGTH(addrzip)<=8 THEN disk1^.zip := addrzip
   ELSE 
    BEGIN
     disk1^.zip := '        ';
     FOR temp := 1 TO 8 DO disk1^.zip[temp] := addrzip[temp];
    END;
  IF FLAGNO<>0 THEN disk1^.Flags[FLAGNO]:=true;
  SEEK(disk1,numrecs);
  PUT(disk1);
 END;        
 
FUNCTION Notblankname : BOOLEAN;
 BEGIN
  WHILE POS(' ',iname)=1 DO DELETE(iname,1,1); 
  Notblankname := NOT (iname='');;
 END;
 
PROCEDURE MailFile(VAR Filename:STRING);
 VAR ch : CHAR;
     t1,t2 : STRING[15];
     tmpstr:STRING;

{$I-}
PROCEDURE Makefile( s : STRING);
 VAR  tafile : FILE; 
      tarry : packed array [1..512] of char;
      Res,num,blkasked,written,temp   : INTEGER;
 BEGIN
  WRITE('Making: ',s);
  REWRITE(tafile,s);  
  Res:=IORESULT;
  IF Res<>0 THEN
    begin
      Writeln;
      Writeln('Error making file ',s,' IOResult=',Res);
    end
  else
    begin
      fillchar(tarry,512,chr(0));
      temp := POS('[',s);
      {no block number if max area to be claimed}
      IF temp=0 THEN blkasked:=0
      else blkasked:=VAL(COPY(s,temp+1,LENGTH(s)-temp));
      {-9999 is fault return from VAL}
      if blkasked<0 then blkasked:=0;
      num:=0;
      REPEAT      
        if (num mod 10)=0 then WRITE('.');
        written:=BLOCKWRITE(tafile,tarry,1);     
        num:=num+written;
      UNTIL (num=blkasked) or (written=0) or (IORESULT<>0); 
      WRITELN;
      if (blkasked<>0) and (num<>blkasked) then
          WRITELN('Could only initialise ',num,' blocks.')
      else WRITELN(num,' blocks initialised.');
      CLOSE(tafile,lock); 
      Res:=IORESULT;
      IF Res<>0 THEN Writeln('Error closing file ',s,'IOResult=',Res);
    end;
 END; 
{$I+}
    
 PROCEDURE Getmfile; 
  BEGIN
   IF LENGTH(filename)=0 THEN filename := 'MAIL.DATA';   
   IF POS(':',filename)=0 THEN
    BEGIN
     WRITELN;
     WRITE('Give volume for file ',filename,' (<cr> for #5, <esc><cr> to quit):');    
     READLN(t1);
     IF LENGTH(t1)> 0 THEN IF t1[1] = CHR(27) THEN EXIT(MailInit);
     IF LENGTH(t1)=0 THEN t1 := '#5:';
     IF (t1='4') OR (t1='5') OR
        (t1 = '9') OR (t1='10') OR
        (t1 = '11') OR (t1='12') THEN
          t1 := CONCAT('#',t1,':');
     IF POS(':',t1)=0 THEN t1 := CONCAT(t1,':');      
     filename := CONCAT(t1,filename);      
    END;
   WRITELN;
   WRITELN('The file can hold approximately 4 records in every 3 blocks.');
   WRITE('How many blocks for this file (<esc><cr> to quit):');
   READLN(t2);
   IF LENGTH(t2)> 0 THEN IF t2[1]=CHR(27) THEN EXIT(MailInit);
   temp := Val(t2); {-9999 indicates bad string or null response}
   if temp<0 then temp:=0;
   IF (temp<5) OR (LENGTH(t2)>3) THEN t2 := '';  
   IF (temp<>0) THEN 
    BEGIN
     IF (temp<10) AND (LENGTH(t2)<>1) THEN STR(temp,t2);     
     IF (temp>=10) AND (temp<100) AND (LENGTH(t2)<>2) THEN STR(temp,t2);     
     IF (temp>=100) AND (LENGTH(t2)<>3) THEN STR(temp,t2);    
    END; 
  END;

 BEGIN    
   WRITELN;
   WRITELN('Enter <cr> to create new MAIL.DATA, <esc><cr> to quit,');
   WRITE  ('      or another filename to use for data:');
   READLN(filename);     
   IF LENGTH(filename)<>0 THEN IF filename[1]=CHR(27) THEN EXIT(MailInit);
   IF filename='' THEN filename:='MAIL.DATA';
   IF ChkFiles(filename,'') then
     BEGIN
       WRITE('File ',filename,' already exists.  Destroy it (Y/N):');
       REPEAT
         READ(KEYBOARD,CH);
       UNTIL CH IN ['Y','y','N','n'];
       Writeln(CH);
       IF (CH='Y') OR (CH='y') THEN
         BEGIN
           {$I-}
           RESET(disk1,filename);
           CLOSE(disk1,PURGE);
           {$I+}
         END
       ELSE EXIT(MailInit);
     END;
   IF NOT Chkfiles(filename,'') THEN        
     BEGIN  
      REPEAT
       Getmfile;
       if length(t2)>0 then tmpstr := CONCAT(filename,'[',t2,']')
       else tmpstr:=filename;     
       Makefile(tmpstr);
      UNTIL Chkfiles(filename,'');          
     END;
 END; 
    
BEGIN  
 WRITELN;
 WRITELN('----------------------------------------------------------------');
 WRITELN('ERCC WORDSET - MAIL Initialisation Utility 1.1 - 23-Feb-82');
 WRITELN('----------------------------------------------------------------');
 WRITELN;
 InputOK:=FALSE;
 REPEAT
   WRITE('Enter the input filename (<esc> <return> to quit):');
   READLN(fname2);
   if fname2<>'' then
     begin
       if fname2[1]=chr(27) {ESC} then EXIT(MailInit);
       InputOK:=Chkfiles(fname2,'.TEXT');
     end;
   if NOT InputOK then writeln('File ',fname2,' does not exist.');
 UNTIL InputOK;
 RESET(finp,fname2);
 MailFile(fname1);
 WRITELN;
 WRITELN('Give a Flag number to be set on each record.');
 WRITELN('                   0 means set no flag');
 WRITE  ('                   1-48 are legal');
 WRITELN;
 REPEAT
   WRITE('Flag number:');
   READLN(FLAGNO);
 UNTIL (FLAGNO>=0) and (FLAGNO<=48);
 WRITELN;
 {$I-}
 REWRITE(disk1,fname1);  
 if ioresult<>0 then
   begin
     writeln('Cannot open output file.');
     exit(MailInit);
   end;
 {$I-}
  numrecs:= 0;
 WHILE NOT EOF(finp) DO 
  BEGIN
   Pget;  
   IF Notblankname THEN Chgformat;      
  END;
 Wnew0rec; {puts count information in rec 0}
 CLOSE(disk1,lock);
 CLOSE(finp);
END.


========================================================================================
DOCUMENT :usus Folder:VOL11:mail.lett.text
========================================================================================

~                        Edinburgh Regional Computing Centre
~                                          59, George Square
~                                          Edinburgh EH8 9JU

\\


~Dear (*GR*),

       thankyou for attending our demonstration of the Off-Load UCSD 
p-System based Office Workstation.  We have noted your interest in (*M0*).


~                              Yours sincerely,
~
~                                    Dr. Austin Tate
~                                    Micro Support Unit


========================================================================================
DOCUMENT :usus Folder:VOL11:mail.read.text
========================================================================================

Contents of this volume                       Austin Tate, ERCC 22-Feb-82
-------------------------------------------------------------------------

This volume holds a mailing address data base, mailing label and forms
letter production utility called MAIL along with associated text files
and utilities.

MAIL was initially written by Patrick Horton at Associated Computer
Industries.  It was subsequently updated and modified by Austin Tate
at the Edinburgh Regional Computing Centre.  The copyright was transfered
to Austin Tate in February 1982 by ACI.

The files available are:

MAIL.TEXT               The main program which has include files for the rest
MAIL1.TEXT              The include files follow.
MAIL2A.TEXT
MAIL2B.TEXT
MAIL3.TEXT
MAIL4.TEXT
MAIL5.TEXT
MAIL6.TEXT
MAIL7.TEXT
MAIL8.TEXT
MAIL9.TEXT

SCREENOPSX.TEXT        The MAIL program uses a UNIT SCREENOPS for screen
SCREENOPSA.TEXT        control.  In version IV and other systems which
                       provide a compatible SCREENOPS UNIT just use that.
                       If one is not available on your system, the two files
                       provided should provide enough of the SCREENOPS
                       functions to allow MAIL to work.  SCREENOPSX should
                       work with any VDU which uses FF (ASCII 12 decimal)
                       as the Clear Screen and Home control character.
                       SCREENOPSA is specifically for the Apple II and will
                       get the control characters from the *SYSTEM.MISCINFO
                       for UCSD II.1.
                       
MAIL.INIT.TEXT         A utility to initialise a MAIL data base from a
                       text file holding names and addresses. See the
                       documentation for more details.
                       
MAIL.DOC.TEXT          The documentation.  It was prepared with the UCSD
                       Advanced Systems Editor (ASE) from Volition Systems
                       and may be too large to edit with the standard
                       in-memory UCSD editor.  You should be able to list
                       it though.
                       
MAIL.READ.TEXT         This note.

MAIL.E.G.TEXT          A "form letter" which serves as an example of the
                       use of MAIL for building your own form letters.
MAIL.LETT.TEXT         A sample straightforward form letter, you could model
                       your own on this.
MAIL.FORM.TEXT         A "form" which can be used as a form letter to print
                       the information held i the data base about an
                       individual.  Usefule for reports, etc.
MAILINITEG.TEXT        An example file which can be used as input to the
                       MAIL.INIT utility to create a MAIL data base from
                       existing name and address lists.  Use this as a
                       sample to get the format correct.
                       
MAIL.CODE              On some disks, the code files for the MAIL and
MAIL.INIT.CODE         MAIL.INIT programs may be present.

MAIL.DATA              On some disks, the data files created (by default)
MAIL.INFO.DATA         by the MAIL program may be present.  If they are
                       present, the MAIL system will use these and not ask
                       you for your own mail files.  Rename or destroy
                       these two to start your own mailing lists.
                       
Preparation
-----------

The MAIL and MAIL.INIT programs have been made to be compatible with
a wide range of UCSD systems.  However, some changes are required to
the sources to allow compilation on pre-version IV UCSD systems.

1. Choose a suitable SCREENOPS UNIT if your system does not provide one
   and compile it to SCREENOPS.CODE on the prefix disk.  The MAIL sources
   assume that the inerface pert of SCREENOPS can be found in SCREENOPS.CODE.
   
2. For the Apple II, edit the compiler directive at the head of file
   MAIL.TEXT to include the V- option.  This is marked in the sources.
   
3. For UCSD versions which do not provide many segment slots (e.g., II.0
   Apple Pascal 1.0, etc) edit the SEGMENT PROCEDURE declarations in
   MAIL6.TEXT - for Add and Change procedures - to be normal PROCEDURES.
   The sources are marked appropriately.  This will have the effect of
   cutting down on heap space available for sorting, etc. so try to use
   the maximum number of segments that you can.
   
4. Now you should be able to compile MAIL.  Run the program and it will
   deal with all necessary file initialisation.  You can pre-initialise
   the mail data base from a text file holding names and addresses with
   the utility MAIL.INIT (prior to running MAIL)if you wish.




========================================================================================
DOCUMENT :usus Folder:VOL11:mail.text
========================================================================================

{Mail - Main program}
{
22-Feb-82 AT
}
{     
*** * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ***
** * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * **
**                                                                         **
** program    : MAIL - Text processing mailing label data manager.         **
**                                                                         **
** authors    : Patrick R. Horton, Associated Computer Industries          **
**              Austin Tate, Edinburgh Regional Computing Centre           **
**                                                                         **
** description: This program maintains a data file of name-address         **
**              information. By combining this data with a word-           **
**              processor form letters may be produced.                    **
**                                                                         **
** Copyright  : (C) 1982, Austin Tate, ERCC                                **
**              Permission to use this program for non-profit purposes     **
**              is hereby granted, provided that this note is included.    **
**              Enquiries concerning uses for other purposes should be     **
**              directed to the copyright owner.                           **
**                                                                         **
** * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * **
*** * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ***
}
 
(*$S+*) (* V- needed for Apple also*)                                  
PROGRAM Mail;           

 USES {$U ScreenOps.Code} SCREENOPS;
 
 CONST Spaces30='                              ';
 
 TYPE labelrec = RECORD    
                  code    :STRING[6]; 
                  lname   :STRING[15];   
                  fname   :STRING[10];
                  minit   :STRING[2];
                  prefx   :STRING[5];
                  suffx   :STRING[6];
                  title   :STRING[15];
                  coname  :STRING[30];
                  phone   :STRING[15];   
                  address :STRING[30];    
                  city    :STRING[15];
                  state   :STRING[2];
                  country :STRING[15];
                  zip     :STRING[8];  
                  misc    :STRING[90];
                  flags   :ARRAY[1..48] OF BOOLEAN; 
                 END;   
       linkedrec = RECORD
                    recpart : labelrec;
                    lpart   : ^linkedrec;
                   END;
       linkrec2 = RECORD
                   intpart : INTEGER;
                   lpart2  : ^linkrec2;
                  END;
       bstring = STRING[255]; 
       justification = (left,center,right);
 
 VAR odisk    : TEXT;     
     infile   : TEXT; 
     disk     : FILE OF labelrec;     
     heaptr   : ^INTEGER;
     ptr,first    : ^linkedrec; {lists of backup records kept on heap}
     first2,ptr2  : ^linkrec2;
     format   : FILE OF 
      RECORD    
       spacing                                : 1..3;        
       infilename,ofilename                   : STRING[30];    
       llmgin,lrmgin,
       lspage,lpwid,lvtab, 
       lpin,lchar,lpsiz,
       mwide,mvtab,mmgin                      : INTEGER;
       rolodex,poption,foption,loption,option : BOOLEAN;   
       meanings                               : ARRAY[1..48] OF STRING[30];   
       fflags                                 : ARRAY[1..48] OF BOOLEAN;
       ffeed                                  : boolean;
       LDirCh                                 : char;
       joption                                : boolean;
      END;    
     mailarry : ARRAY[1..4] OF labelrec;     
     wfield   : (p,f,n,l,u,c,t,h,a,i,s,y,z,m);
     outmode  : (reg,ad); {regular display or display during add operation}
     stdflg   : ARRAY[1..5] OF INTEGER;  
     tmpstr   : STRING[100];
     wildcard : STRING[90];  
     ffilename,filename    : STRING;    
     tname,field           : STRING[30];
     tlname                : STRING[15];
     
     command:CHAR;
     temp,temp1,temp2,columat,increment,
     orignrecs,ladd,column,numrecs,recnumber  : INTEGER;      
     firstflg,pflg,eflg,cnflg,otrecflg,orecflg: BOOLEAN;      
     
  
FUNCTION Val(s : STRING):INTEGER;                   FORWARD;
FUNCTION Chkfiles(s : STRING):BOOLEAN;              FORWARD; 
FUNCTION Wildok : BOOLEAN;                          FORWARD;      
FUNCTION Chkflgs : BOOLEAN;                         FORWARD;   
PROCEDURE Uppercase(VAR s : STRING);                FORWARD; 
PROCEDURE Rdata(a,x,y,l : INTEGER; VAR s :bstring); FORWARD;     
PROCEDURE Getint(x,y : INTEGER; VAR t1 : INTEGER);  FORWARD; 
PROCEDURE Wild1(wch:char);                          FORWARD; 
PROCEDURE Wild2;                                    FORWARD; 
PROCEDURE Str(i : INTEGER; VAR s:STRING);           FORWARD;
Procedure Reporterr(st1,st2:string;res:integer);    FORWARD;
Procedure MakeFile(s:string);                       forward;
Procedure Gtstdflgs;                                forward;
Procedure WNew0Rec;                                 forward;
Procedure Step;                                     forward;
Procedure Krunch;                                   forward;
Procedure Outrec;                                   forward;

(*$I  MAIL1.TEXT   *) {Init - holds version and date}
(*$I  MAIL2a.TEXT  *) {2a and 2b are the LETTER segment}
(*$I  MAIL2b.TEXT  *)
(*$I  MAIL3.TEXT   *) {1 thru 6  contain segments}
(*$I  MAIL4.TEXT   *)
(*$I  MAIL5.TEXT   *)
(*$I  MAIL6.TEXT   *) {on version II.0 remove segments}
(*$I  MAIL7.TEXT   *) {first non segment procedures}

(*$I  MAIL8.TEXT   *)
(*$I  MAIL9.TEXT   *)

PROCEDURE Str;
 VAR startedstring : BOOLEAN;  
     factor        : INTEGER;
     numstr        : STRING[9];
 BEGIN 
  s := '';
  IF i < 0 THEN
   BEGIN
    s := '-';
    i := - i;
   END;
  numstr := '123456789';
  startedstring := FALSE; 
  factor := 10000;
  WHILE factor<>0 DO    
   BEGIN
    IF i >= factor THEN   
     BEGIN
      s := CONCAT(s,COPY(numstr,i DIV factor,1));       
      i := i - (i DIV factor)*factor;                 
      startedstring := TRUE;
     END
    ELSE IF startedstring THEN s := CONCAT(s,'0');
    factor := factor DIV 10;
   END;  
  IF LENGTH(s) = 0 THEN s := '0';
 END;  

BEGIN (* Mail *);                 
 Firstflg := TRUE; {for Init}
 Init;  {will leave recordnumber=0}
 command := '$'; {initial dummy value}
 REPEAT            
  pflg := TRUE; 
   REPEAT
    IF (numrecs <> 0) AND (NOT(command IN ['?',',','.','<','>','+','-'])) THEN
     BEGIN
      if recnumber < 1 then recnumber := 1;
      IF recnumber > numrecs THEN recnumber := numrecs;
      recnumber:=recnumber-increment;
      {set up so that step will move to next genuine record or current record}
      Step; {if recnumber=1 will find first genuine record}
      outmode := reg; 
      Outrec;       
     END;
    SC_Clr_Line(0);
    IF increment=1 THEN WRITE('>');      
    IF increment=-1 THEN WRITE('<');                             
    IF pflg  
     THEN WRITE('Mail: A)dd, C)hange, D)elete, F)ind, 1)st, '' '')step, O)ptions, Q)uit ? ')   
     ELSE WRITE('Mail: L)etter, M)labels, S)ort, I)nit, K)runch, R)estore, Z)ero ? ');
    REPEAT
      READ(KEYBOARD,command);         
      if (command>='a') AND (command<='z') THEN command:=chr(ord(command)-32);
    UNTIL command in ['A','C','D','F','1',' ','M','Q','I','K','L',
                      'S','R','O','Z','?',',','.','<','>','+','-'];
    write(command);
    IF command = '?' THEN pflg := NOT pflg;
    IF (numrecs=0) THEN
     BEGIN
      IF command='A' THEN Add;
      IF command='O' THEN Options;
     END
    ELSE
     CASE command OF    
      'A' : Add;
      'C' : Change;
      'D' : Delte;
      'F' : Find;
      'I' : Initialize;
      'K' : Krunch;
      'L' : Letter;
      'O' : Options;
      'M' : Mlabels;
      'R' : Restore;
      ' ' : Step;
      'S' : Sortit;
      'Z' : Zero;
      '1' : recnumber:=0;
  '-','<',',' : increment := -1;
  '+','>','.' : increment := 1;
      END;
   UNTIL command='Q';
  UNTIL Quit;
 END. (* Mail *)  




========================================================================================
DOCUMENT :usus Folder:VOL11:mail1.text
========================================================================================

{Mail1 - Init (holds version number and date}
{
22-Feb-82 AT
}
{      
** program    : MAIL - Text processing mailing label data manager.         **
** authors    : Patrick R. Horton, Associated Computer Industries          **
**              Austin Tate, Edinburgh Regional Computing Centre           **
** Copyright  : (C) 1982, Austin Tate, ERCC                                **
**              Permission to use this program for non-profit purposes     **
**              is hereby granted, provided that this note is included.    **
**              Enquiries concerning uses for other purposes should be     **
**              directed to the copyright owner.                           **
}

SEGMENT PROCEDURE Init;

PROCEDURE Rights;
 BEGIN
  SC_Clr_Screen;
  WRITELN;
  WRITELN('----------------------------------------------------------------');
  WRITELN('ERCC WORDSET - MAIL - Text processing mailing label data manager');
  WRITELN('               1.4    22-Feb-82');
  WRITELN('----------------------------------------------------------------');
  WRITELN;
  WRITELN('authors    : Patrick R. Horton, Associated Computer Industries');
  WRITELN('             Austin Tate, Edinburgh Regional Computing Centre');
  WRITELN;
  WRITELN('description: This program maintains a data file of name-address');
  WRITELN('             information.  Selected data may be merged with a');
  WRITELN('             document to produce form letters. Mailing labels');
  WRITELN('             can be printed.');
  WRITELN;
  WRITELN('Copyright  : (C) 1982, Austin Tate, ERCC');
  WRITELN;
  WRITELN('document   : ERCC hosts in file MICROS.DOC_MAIL');
  WRITELN;
  WRITELN('----------------------------------------------------------------');
  REPEAT
    GOTOXY(0,22);
  UNTIL NOT(Space_Wait(TRUE));
END;

PROCEDURE Initformat;    
 BEGIN  
  IF Chkfiles('#4:MAIL.INFO.DATA') THEN
   BEGIN
    ffilename := '#4:MAIL.INFO.DATA';                    
    RESET(format,ffilename);
   END
  ELSE IF Chkfiles('#5:MAIL.INFO.DATA') THEN    
   BEGIN
    ffilename := '#5:MAIL.INFO.DATA';
    RESET(format,ffilename);
   END
  ELSE
   BEGIN
    WRITELN;
    WRITELN;  
    WRITELN('The file MAIL.INIT.DATA was not found.');
    WRITE('Give volume for file MAIL.INFO.DATA (<cr> for #5, <esc><cr> to quit):');
    READLN(ffilename);
    if length(ffilename)>0 then if ffilename[1]=CHR(27) then Exit(Mail);
    IF LENGTH(ffilename)=0 THEN ffilename := '#5:';
    IF (ffilename = '4') OR (ffilename='5') OR
     (ffilename = '9') OR (ffilename='10') OR
     (ffilename = '11') OR (ffilename='12') THEN
     ffilename := CONCAT('#',ffilename,':');
    IF POS(':',ffilename)=0 THEN ffilename := CONCAT(ffilename,':');
    ffilename := CONCAT(ffilename,'MAIL.INFO.DATA[4]');     
    Makefile(ffilename);   
    {$I-}
    RESET(format,ffilename);  
    if IORESULT<>0 then
      begin
        ReportErr('Leaving Mail to take corrective action.','',IORESULT);
        EXIT(MAIL);
      end;
    {$I+}
    {********}
    WITH format^ DO 
     BEGIN
      infilename := '*MAIL.E.G.TEXT'; 
      ofilename := '#2:';
      llmgin := 10;   
      lrmgin := 10;        
      lpin := 6;
      lchar := 80;
      lpsiz := 23;
      mwide := 1;
      mvtab := 4;
      mmgin := 0;
      rolodex := FALSE;
      FOR temp := 1 TO 48 DO
       BEGIN
        fflags[temp] := FALSE;
        meanings[temp] := '';
       END;
      meanings[48] := 'Suffx'; 
      meanings[47] := 'Lname'; 
      meanings[46] := 'Minit'; 
      meanings[45] := 'Fname'; 
      meanings[44] := 'Prefx'; 
      poption := TRUE;
      foption := TRUE;
      loption := TRUE;    
      option := FALSE;
      ffeed:=FALSE;
      LDirCh:='~';
      joption:=TRUE;
      lspage := 1;  
      lpwid :=  4;
      lvtab := 2;
      spacing := 1;
     END;
    SEEK(format,0); 
    PUT(format);
   END;
  SEEK(format,0);  
  GET(format);
  CLOSE(format);  
 END;   

PROCEDURE Initmail;   
 VAR ch : CHAR;
     t1,t2 : STRING[15];
 
 PROCEDURE Getmfile; 
  BEGIN
   IF LENGTH(filename)=0 THEN filename := 'MAIL.DATA';   
   IF POS(':',filename)=0 THEN
    BEGIN
     WRITELN;
     WRITE('Give volume for file ',filename,' (<cr> for #5, <esc><cr> to quit):');    
     READLN(t1);
     IF LENGTH(t1)> 0 THEN IF t1[1] = CHR(27) THEN EXIT(Mail);
     IF LENGTH(t1)=0 THEN t1 := '#5:';
     IF (t1='4') OR (t1='5') OR
        (t1 = '9') OR (t1='10') OR
        (t1 = '11') OR (t1='12') THEN
          t1 := CONCAT('#',t1,':');
     IF POS(':',t1)=0 THEN t1 := CONCAT(t1,':');      
     filename := CONCAT(t1,filename);      
    END;
   WRITELN;
   WRITELN('The file can hold approximately 4 records in every 3 blocks.');
   WRITE('How many blocks for this file (<esc><cr> to quit):');
   READLN(t2);
   IF LENGTH(t2)> 0 THEN IF t2[1]=CHR(27) THEN EXIT(Mail);
   temp := Val(t2); {-9999 indicates bad string or null response}
   if temp<0 then temp:=0;
   IF (temp<5) OR (LENGTH(t2)>3) THEN t2 := '';  
   IF (temp<>0) THEN 
    BEGIN
     IF (temp<10) AND (LENGTH(t2)<>1) THEN STR(temp,t2);     
     IF (temp>=10) AND (temp<100) AND (LENGTH(t2)<>2) THEN STR(temp,t2);     
     IF (temp>=100) AND (LENGTH(t2)<>3) THEN STR(temp,t2);    
    END; 
  END;
 

 BEGIN    
  IF NOT FirstFlg THEN {filename set on first Init} RESET(disk,filename)
  ELSE IF Chkfiles('#5:mail.data') THEN
   BEGIN
    filename := '#5:mail.data';    
    RESET(disk,filename);
   END
  ELSE IF Chkfiles('#4:mail.data') THEN
   BEGIN
    filename := '#4:mail.data';
    RESET(disk,filename);
   END
  ELSE
   BEGIN
    WRITELN; 
    WRITELN;
    WRITELN('The file MAIL.DATA was not found.');
    WRITELN('Enter <cr> to create new MAIL.DATA, <esc><cr> to quit,');
    WRITE  ('      or another filename to use for data:');
    READLN(filename);     
    IF LENGTH(filename)<>0 THEN IF filename[1]=CHR(27) THEN EXIT(Mail);
   IF NOT Chkfiles(filename) THEN        
     BEGIN  
      REPEAT
       Getmfile;
       if length(t2)>0 then tmpstr := CONCAT(filename,'[',t2,']')
       else tmpstr:=filename;     
       Makefile(tmpstr);
      UNTIL Chkfiles(filename);          
      RESET(disk,filename);
      numrecs := 0;
      Wnew0rec;    
      CLOSE(disk);
     END;
    RESET(disk,filename);  
   END;
  END; 
    

 BEGIN {Init}            
  recnumber  := 0;    
  columat    := 0;  
  increment  := 1;  
  cnflg      := FALSE; 
  wildcard   := '';      
  wfield     := n;  
  first      := NIL;
  first2     := NIL;
  MARK(heaptr);  
  IF FirstFlg THEN
    begin
      Rights;
      SC_Clr_Screen;
      Initformat;   
      Initmail;     
      Firstflg:=FALSE;
    end;
  SEEK(disk,0);                                          
  GET(disk);      
  numrecs := Val(disk^.zip);                     
  orignrecs := numrecs; 
  ladd := 0;
  Gtstdflgs;  
  SC_Clr_Screen;
  {assert recnumber=0 and increment=1}
  {Step in main program will find first genuine record}
 END (* Init *);                



========================================================================================
DOCUMENT :usus Folder:VOL11:mail2a.text
========================================================================================

{Mail2A - Letter part 1}
{
22-Feb-82 AT
}
{      
** program    : MAIL - Text processing mailing label data manager.         **
** authors    : Patrick R. Horton, Associated Computer Industries          **
**              Austin Tate, Edinburgh Regional Computing Centre           **
** Copyright  : (C) 1982, Austin Tate, ERCC                                **
**              Permission to use this program for non-profit purposes     **
**              is hereby granted, provided that this note is included.    **
**              Enquiries concerning uses for other purposes should be     **
**              directed to the copyright owner.                           **
}

SEGMENT PROCEDURE Letter;                                 
 {DirStr is the directive character for letter processing - default is '~'}
 
 VAR  DirStr                              : STRING[1];
      tline,line,oline                    : bstring;
      lmarg,pmarg,Lettername              : STRING[60];
                                          {limits max left and para maragins}
      token,greet                         : STRING[90];      
                                          {length is maximum of fields}
      ljustify,sjustify                   : justification;   
      tpmgin,temp3,temp4,pageat,  
      pmgin,tlmgin,tlsize,
      nlwg,numtoadd,linat,lmgin,lsize     : INTEGER; 
      epar,newpar,pgflg,FileEnd,
      LastPageWritten                     : BOOLEAN;         
      spc                                 : 1..3; 
      ch,tempch                           : char;
     
FUNCTION Flgsok : BOOLEAN;        
  VAR intb : BOOLEAN;
      numarray : ARRAY[1..48] OF (t,f,n);
  BEGIN    
   temp3 := POS('{%',line)+2;       
   tline := COPY(line,temp3,LENGTH(line)-temp3+1);        
   intb := FALSE;           
   FOR temp := 1 TO 48 DO numarray[temp] := n;   
   REPEAT
    temp3 := POS('/',tline);  
    temp := VAL(tline);       
    IF (temp3 <> 0) AND (temp3<5) THEN DELETE(tline,1,temp3);
    IF (temp3<5) AND (temp>0) AND (temp<=48) THEN numarray[temp] := t;
    IF (temp3<5) AND (temp<0) AND (temp>=-48) THEN numarray[-1*temp] := f;
   UNTIL (temp3 = 0) OR (temp3>4);   
   IF format^.loption THEN                          
    BEGIN
     intb := TRUE; 
     FOR temp := 1 to 48 DO
      BEGIN              
       IF numarray[temp]=t THEN IF NOT disk^.flags[temp] THEN intb := FALSE;
       IF numarray[temp]=f THEN IF disk^.flags[temp] THEN intb := FALSE;
      END;
    END      
   ELSE     
    BEGIN
     FOR temp := 1 TO 48 DO   
      BEGIN  
       IF numarray[temp]=t THEN IF disk^.flags[temp] THEN intb := TRUE;  
       IF numarray[temp]=f THEN IF NOT(disk^.flags[temp]) THEN intb := TRUE;
      END;
    END;      
   Flgsok := intb;        
   IF intb THEN  
    BEGIN
     temp4 := POS('{%',line);           
     tline := COPY(line,1,temp4-1);  
     DELETE(line,1,temp4+1);          
     WHILE (POS('/',line)<5) AND (POS('/',line)<>0) DO
       DELETE(line,1,POS('/',line));                                        
     line := CONCAT(tline,line);
    END;    
   END;    

  PROCEDURE Skptpt;       
   VAR tline : STRING[255];          
       level : INTEGER;
   BEGIN
    tline := COPY(line,1,POS('{%',line)-1);       
    DELETE(line,1,POS('{%',line)+1);
    level := 1;
    REPEAT
     IF (POS('%}',line)=0) AND (POS('{%',line)=0) THEN      
      IF NOT EOF(infile) THEN READLN(infile,line) ELSE line := '';  
     IF (POS('{%',line)<>0) AND    
        (((POS('%}',line)<>0) AND (POS('%}',line)>POS('{%',line))      
           OR (POS('%}',line)=0))) THEN   
        BEGIN
         level := level + 1;  
         DELETE(line,1,POS('{%',line)+1);
        END
     ELSE IF (POS('%}',line)<>0) AND       
      (((POS('{%',line)<>0) AND (POS('{%',line)>POS('%}',line))            
       OR (POS('{%',line)=0))) THEN               
        BEGIN
         level := level - 1;
         DELETE(line,1,POS('%}',line)+1);     
        END;    
    UNTIL (level=0) OR EOF(infile);                      
    line := CONCAT(tline,line);                        
   END;    
  
  PROCEDURE Prflgs;         
   BEGIN  
    REPEAT
     WHILE (POS('%}',line)<>0) AND   
      ((POS('{%',line)=0) OR (POS('{%',line)>POS('%}',line)))
       DO DELETE(line,POS('%}',line),2);    
     WHILE POS('{%',line)<>0 DO         
      IF NOT Flgsok THEN Skptpt;              
    UNTIL (POS('{%',line)=0) AND (POS('%}',line)=0); 
   END;

PROCEDURE Chkorquit;   
 var ch1:char;
 BEGIN
 IF format^.foption THEN        
  BEGIN
  IF format^.ofilename<>'#2:' THEN WRITELN;    
  WRITE('<space> to continue, <esc> to quit:');
  REPEAT
   READ(KEYBOARD,ch1);   
  UNTIL (ch1=CHR(27)) OR (ch1=' '); 
  WRITELN;
  IF ch1 = CHR(27) THEN  
   BEGIN
    SC_Clr_Screen;
    CLOSE(infile); 
    CLOSE(odisk,lock); 
    EXIT(Letter); 
   END; 
 END;
END;


 
PROCEDURE Getgreet;
  type farray = array [1..48] of boolean;
  
  procedure greet1(var greet:string; var farr:farray);
  begin
   IF (stdflg[1]<>0) THEN
    IF farr[stdflg[1]] AND (LENGTH(disk^.prefx)<>0) THEN     
     greet := CONCAT(greet,disk^.prefx);                 
   IF (stdflg[2]<>0) THEN 
    IF farr[stdflg[2]] AND (LENGTH(disk^.fname)<>0) THEN
     BEGIN
      IF LENGTH(greet)<>0 THEN greet := CONCAT(greet,' ');             
      greet := CONCAT(greet,disk^.fname);                             
     END;
   IF (stdflg[3]<>0) THEN
    IF farr[stdflg[3]] AND (LENGTH(disk^.minit)<>0) THEN    
     BEGIN
      IF LENGTH(greet)<>0 THEN greet := CONCAT(greet,' ');   
      greet := CONCAT(greet,disk^.minit);           
     END;
   IF (stdflg[4]<>0) THEN
    IF farr[stdflg[4]] AND (LENGTH(disk^.lname)<>0) THEN        
     BEGIN
      IF LENGTH(greet)<>0 THEN greet := CONCAT(greet,' ');       
      greet := CONCAT(greet,disk^.lname);               
     END;
   IF (stdflg[5]<>0) THEN
    IF farr[stdflg[5]] AND (LENGTH(disk^.suffx)<>0) THEN          
     BEGIN
      IF LENGTH(greet)<>0 THEN greet := CONCAT(greet,' ');
      greet := CONCAT(greet,disk^.suffx);                   
     END;              
  end;
  
  BEGIN
   greet := '';                    
   temp1 := 0;
   greet1(greet,disk^.flags); {try from actual record}
   {if not try from the entries S(et in O(ptions F(lags}
   if length(greet)=0 then greet1(greet,format^.fflags);
   
   IF LENGTH(greet)=0 THEN  
    IF (LENGTH(disk^.lname)<>0) and (length(disk^.prefx)<>0)  THEN
      greet := CONCAT(disk^.prefx,' ',disk^.lname);  
   
   IF LENGTH(greet)=0 THEN                 
    IF (LENGTH(disk^.fname)>1) THEN
      begin
        IF (disk^.fname[2]<>'.')  THEN
        {first name present and not an initial} greet := disk^.fname;
      end;
    
  IF LENGTH(greet)=0 THEN greet := 'Sir';  
 END;      
  
 FUNCTION Hasmgin : BOOLEAN;           
  VAR intb : BOOLEAN;
  BEGIN 
   intb := FALSE;
   WHILE  ( ( POS(':]',token)<POS('[:',token) ) AND (POS(':]',token)<>0) ) OR   
          ( ( POS('[:',token)=0 ) AND (POS(':]',token)<>0) ) DO 
    DELETE(token,POS(':]',token),2);
   IF (POS(':]',token)<>0) AND (POS('[:',token)<>0) THEN intb := TRUE;   
   Hasmgin := intb;
  END;
    
 procedure SetPLMargins(p,l:integer);
 begin
   if length(pmarg)<>p then pmarg:=copy(concat(Spaces30,Spaces30),1,p);
   if length(lmarg)<>l then lmarg:=copy(concat(Spaces30,Spaces30),1,l);
 end;
 
 function ValorDefault(Val,Default:integer):integer;
 begin
   if val=-9999 then ValOrDefault:=Default else ValorDefault:=Val;
 end;
 
 PROCEDURE Getmgin;      
  BEGIN  
   IF token[POS('[:',token)+2] IN ['L','l'] THEN      
    BEGIN
     temp := tlmgin;
     tlmgin := ValOrDefault(Val(COPY(token,POS('[:',token)+3,3)),lmgin);
     tlsize := tlsize + temp - tlmgin;           
    END 
   ELSE IF token[POS('[:',token)+2] IN ['R','r'] THEN
    BEGIN          
     tlsize := format^.lchar - tlmgin         
              - ValOrDefault(Val(COPY(token,POS('[:',token)+3,3)),
                             format^.lrmgin);
    END
   ELSE IF token[POS('[:',token)+2] IN ['P','p'] THEN 
    BEGIN
     tpmgin := ValOrDefault(Val(COPY(token,POS('[:',token)+3,3)),pmgin); 
    END
   ELSE IF token[POS('[:',token)+2] IN ['S','s'] THEN                      
    BEGIN
     temp := Val(COPY(token,POS('[:',token)+3,3));
     IF (temp>0) AND (temp<=3) THEN spc := temp;      
    END;
   IF tlmgin<0 THEN tlmgin := format^.llmgin;    
   IF tlsize<=0 THEN
    tlsize := format^.lchar-format^.lrmgin-format^.llmgin;         
   DELETE(token,POS('[:',token),
          POS(':]',token)-POS('[:',token)+2);                 
   IF ((NOT newpar) AND (LENGTH(oline)<tlsize)) 
    OR (newpar AND (LENGTH(oline)<tlsize-tpmgin)) THEN     
   BEGIN  
    {these may have been altered by directives within line just output}
    lsize := tlsize;
    if (pmgin<>tpmgin) or (lmgin<>tlmgin) then
      begin
        pmgin := tpmgin;
        lmgin := tlmgin;
        SetPLMargins(pmgin,lmgin);
      end;
   END;      
  END;    
  
PROCEDURE Rjustify;
 VAR srt,srted,pspace,lwg   : ARRAY[0..50] OF INTEGER;       
     
 PROCEDURE Addtoall(i : INTEGER);      
  VAR lstcharspace : BOOLEAN;              
  BEGIN  
   temp1 := 0;  
   lstcharspace := FALSE;  
   WHILE temp1 < LENGTH(oline) DO                 
    BEGIN
     temp1 := temp1 + 1;
     IF oline[temp1]<>' ' THEN        
      IF lstcharspace THEN          
       BEGIN
        FOR temp2 := 1 TO i DO INSERT(' ',oline,temp1);              
        temp1 := temp1 + i;    
        lstcharspace := FALSE;                
       END
      ELSE
     ELSE lstcharspace := TRUE;     
    END;
  END; 
  
 PROCEDURE Addrems(i : INTEGER);  
  VAR prevhi,temp3 : INTEGER;        
  BEGIN
   FOR temp1 := 1 TO i DO    
    BEGIN    
     prevhi := 0;                        
     FOR temp2 := 1 TO i DO 
      IF srted[temp2] > prevhi THEN 
       BEGIN    
        prevhi := srted[temp2];        
        temp3 := temp2;
       END;
     INSERT(' ',oline,pspace[srted[temp3]]+ 
      (srted[temp3]-1)*(numtoadd DIV nlwg));        
     srted[temp3] := 0; 
    END;   
  END; 
  
 PROCEDURE Sortlwg;
  VAR prevhi : INTEGER;  
  BEGIN
   FOR temp1 := 1 TO nlwg DO srt[temp1] := lwg[temp1];         
   FOR temp1 := 1 TO nlwg DO  
    BEGIN
     prevhi := 0;
     FOR temp2 := 1 TO nlwg DO 
      IF srt[temp2]>prevhi THEN       
       BEGIN
        prevhi := srt[temp2];        
        srted[temp1] := temp2;               
       END;
     srt[srted[temp1]] := 0;      
    END;
  END;     
 
  BEGIN (* Rjustify *)         
   temp1 := 0;                                
   nlwg := 0;  
   WHILE temp1 < LENGTH(oline) DO             
    BEGIN
     temp1 := temp1 + 1;
     IF oline[temp1]=' ' THEN            
      BEGIN 
       nlwg := nlwg + 1;     
       pspace[nlwg] := temp1;   
      END;
    END;
   pspace[0] := 0;    
   pspace[nlwg+1] := LENGTH(oline)+1;         
   FOR temp1 := 1 TO nlwg DO       
    lwg[temp1] := pspace[temp1+1] - pspace[temp1-1] - 1;
   Sortlwg;
   numtoadd := lsize - LENGTH(oline);       
   IF newpar THEN numtoadd := numtoadd - format^.lpin;                     
   IF nlwg <> 0 THEN         
    BEGIN
     IF numtoadd DIV nlwg >= 1 THEN Addtoall(numtoadd DIV nlwg); 
     IF numtoadd MOD nlwg >= 1 THEN Addrems(numtoadd MOD nlwg);  
    END;  
  END;
  
  procedure PutTopMargin;
  begin
    for temp:=1 to format^.lvtab do writeln(odisk);
    linat:=format^.lvtab;
  end;
  
  PROCEDURE Chkpage;  
   VAR ch1 : CHAR;
   BEGIN
    linat := linat + ORD(spc);    
    IF pgflg OR FileEnd OR
       ((epar OR newpar) AND ((linat+5+format^.lpwid)>format^.lpsiz)) OR
       (linat+5>format^.lpsiz) THEN
     BEGIN
      if NOT(LastPageWritten) then
        begin
          FOR temp := linat TO format^.lpsiz-3 DO WRITELN(odisk);
          IF NOT(FileEnd AND (pageat=format^.lspage)) THEN                   
            WRITE(odisk,lmarg,' ':(lsize DIV 2)-3,'- ',pageat,' -');   
          FOR temp1 := 1 TO 3 DO WRITELN(odisk);                
          if format^.ffeed then write(odisk,chr(12)); {formfeed}
          ChkorQuit;
          if NOT(FileEnd) then
            begin
              PutTopMargin;
              pageat := pageat + 1;
            end
          else LastPageWritten:=true;
          pgflg := FALSE;        
        end;
     END; 
   END;  
    
  PROCEDURE Outline;           
   BEGIN    
    IF (format^.joption) AND (POS('\\',line)<>1) AND (NOT(FileEnd)) AND
       (NOT(epar)) AND (POS(DirStr,line)=0) THEN Rjustify;
    
    IF newpar THEN WRITE(odisk,pmarg);     
    WRITE(odisk,lmarg,oline);     
    FOR temp4 := 1 TO ORD(spc) DO WRITELN(odisk); 
    
    newpar := FALSE;   
    IF format^.ofilename <> '#2:' THEN WRITE('.');     
    IF format^.poption THEN Chkpage;     
    IF (NOT epar) AND (POS(DirStr,line)=0) THEN oline := token           
                                        ELSE oline := '';
    {these may have been altered within the line just output}
    lsize := tlsize;
    pmgin := tpmgin;
    lmgin := tlmgin;
    SetPLMargins(pmgin,lmgin);
   END;          
  
  

PROCEDURE Chgtokens;        
 VAR  ltoken,leqpart,lfield               : bstring;
      seqpart,   
      legalfchrs,legal2chrs,
      stoken                              : STRING[90];
                                          {max length of fields}
      lfsize,sfsize,lposinline,sposinline : INTEGER;   
      rflg,lflg                           : BOOLEAN;
         
PROCEDURE Putone(just : justification;               
          ins : bstring;
          fsz,pos : INTEGER;    
          VAR ln : bstring);    
  BEGIN
   tline := '';       
   FOR temp1 := 2 TO fsz - LENGTH(ins) DO
    tline := CONCAT(tline,' '); 
   CASE just OF                
    right   : BEGIN
               INSERT(ins,ln,pos);  
               INSERT(tline,ln,pos);
              END;
    center  : BEGIN            
               INSERT(COPY(tline,1,(LENGTH(tline)+1) DIV 2),ln,pos);
               INSERT(ins,ln,pos);
               INSERT(COPY(tline,1,(LENGTH(tline)) DIV 2),ln,pos);
              END;            
    left    : BEGIN        
               INSERT(tline,ln,pos);
               INSERT(ins,ln,pos);
              END;
   END; 
  END; 
  
 PROCEDURE Getmtoken;    
  VAR tline : STRING[90];
  BEGIN
   temp1 := temp2 - 15;
   tline := disk^.misc;
   FOR temp3 := 1 TO temp1 DO 
    IF POS('\',tline)<>0 THEN
     BEGIN
      stoken := COPY(tline,1,POS('\',tline)-1);
      DELETE(tline,1,POS('\',tline));
     END
    ELSE
     BEGIN
      stoken := tline;
      tline := '';
     END;
  END; 
  
 PROCEDURE Chg1(VAR s : bstring);     
  BEGIN  
   tmpstr := COPY(stoken,1,2);    
   Uppercase(tmpstr);      
   temp1 := POS(tmpstr,'GRPRFNMNLNSUTICNADCISTZIPNCOMIM0M1M2M3M4M5M6M7M8M9');  
   temp2 := (temp1 + 1) DIV 2;   
   IF temp2 * 2 <> temp1 + 1 THEN temp2 := 0;
   stoken := ''; 
   WITH disk^ DO
   CASE temp2 OF
    1 : stoken := greet;
    2 : stoken := prefx; 
    3 : stoken := fname;  
    4 : stoken := minit;    
    5 : stoken := lname;      
    6 : stoken := suffx;
    7 : stoken := title; 
    8 : stoken := coname;
    9 : stoken := address;      
    10: stoken := city;    
    11: stoken := state;   
    12: stoken := zip;                            
    13: stoken := phone;
    14: stoken := country;            
    15: stoken := misc;     
    16,17,18,19,20,21,22,23,24,25 : Getmtoken; 
   END;  
   IF LENGTH(stoken)<>0 THEN INSERT(seqpart,s,sposinline);              
    IF NOT(
           (LENGTH(stoken)=0) AND       
           (NOT rflg) AND
           (NOT lflg)) THEN     
    Putone(sjustify,stoken,sfsize,sposinline,s);    
  END; 
  



========================================================================================
DOCUMENT :usus Folder:VOL11:mail2b.text
========================================================================================

{Mail2B - Letter part 2}
{
19-Feb-82 AT
}
{      
** program    : MAIL - Text processing mailing label data manager.         **
** authors    : Patrick R. Horton, Associated Computer Industries          **
**              Austin Tate, Edinburgh Regional Computing Centre           **
** Copyright  : (C) 1982, Austin Tate, ERCC                                **
**              Permission to use this program for non-profit purposes     **
**              is hereby granted, provided that this note is included.    **
**              Enquiries concerning uses for other purposes should be     **
**              directed to the copyright owner.                           **
}

PROCEDURE Getstoken(VAR s : bstring);            
 VAR tmpstr : STRING[90];
 BEGIN 
  temp1 := POS('(*',s);
  sposinline := temp1;    
  stoken := '';  
  stoken := COPY(s, temp1+2 , POS('*)',s)-temp1-2);          
  DELETE(s,POS('(*',s),POS('*)',s)-POS('(*',s)+2);                        
  seqpart := '';         
  IF temp1 <= LENGTH(s) THEN       
   BEGIN
    IF s[temp1]='=' THEN             
     BEGIN
      tmpstr := COPY(s,temp1,LENGTH(s)-temp1+1);    
      DELETE(tmpstr,1,1); 
      IF POS('=',tmpstr)>1 THEN   
        seqpart := COPY(tmpstr,1,POS('=',tmpstr)-1);  
      IF LENGTH(tmpstr)=0 THEN temp2 := 1        
      ELSE IF POS('=',tmpstr)=0 THEN temp2 := LENGTH(tmpstr)+1
      ELSE temp2 := POS('=',tmpstr)+1;        
      IF temp2 <> 0 THEN DELETE(s,temp1,temp2);          
     END;     
   END;
 rflg := FALSE;           
 lflg := FALSE;    
 IF POS(' ',stoken)=1 THEN         
  BEGIN
   DELETE(stoken,1,1);
   lflg := TRUE;
  END;
 IF LENGTH(stoken)<>0 THEN
  IF stoken[LENGTH(stoken)] = ' ' THEN
   BEGIN
    DELETE(stoken,LENGTH(stoken),1);
    rflg := TRUE;
   END;
 IF lflg AND rflg THEN sjustify := center        
  ELSE IF lflg THEN sjustify := right 
   ELSE sjustify := left;    
 sfsize := 0;     
 IF POS(':',stoken)<>0 THEN     
  IF POS(':',stoken)<> LENGTH(stoken) THEN         
   BEGIN    
    tmpstr := COPY(stoken,                  
                   POS(':',stoken)+1,      
                   LENGTH(stoken)-POS(':',stoken));      
    sfsize := 30;  
    sfsize := Val(tmpstr);  
    DELETE(stoken,POS(':',stoken),
           LENGTH(stoken)-POS(':',stoken)+1);          
   END
  ELSE DELETE(stoken,LENGTH(stoken),1);    
 END;   
               
FUNCTION Hastoken(VAR s : bstring) : BOOLEAN;
 VAR intb : BOOLEAN;      
 BEGIN (* Hastoken *)     
  intb := FALSE;    
  WHILE (POS('*)',s)<>0) AND    
        ((POS('(*',s)=0) OR     
         (POS('(*',s)>POS('*)',s))) DO                                  
   DELETE(s,POS('*)',s),2);
  IF ((POS('(*',s)<>0) AND (POS('*)',s)<>0)) AND                  
     (POS('(*',s)<POS('*)',s)) THEN
   BEGIN
    intb := TRUE;    
    Getstoken(s);   
   END;   
  Hastoken := intb;
 END;
     
   
PROCEDURE Getltoken;
 VAR level : INTEGER;      
 BEGIN 
  ltoken := '';
  level := 1;  
  WHILE (lposinline<=LENGTH(line)) AND (level>0) DO           
   BEGIN
    ltoken := CONCAT(ltoken,COPY(line,lposinline,1));       
    IF LENGTH(ltoken)>1 THEN   
     BEGIN
      IF (ltoken[LENGTH(ltoken)]=')') AND           
         (ltoken[LENGTH(ltoken)-1]='*') THEN           
       level := level - 1; 
      IF (ltoken[LENGTH(ltoken)]='*') AND
         (ltoken[LENGTH(ltoken)-1]='(') THEN  
       level := level + 1;
     END;
    DELETE(line,lposinline,1);    
   END;  
  IF (ltoken[LENGTH(ltoken)]=')') AND (LENGTH(ltoken)>1)                     
   THEN IF (ltoken[LENGTH(ltoken)-1]='*') THEN  
   DELETE(ltoken,LENGTH(ltoken)-1,2);  
   IF ltoken[LENGTH(ltoken)]=' ' THEN         
    BEGIN
     DELETE(ltoken,LENGTH(ltoken),1);    
     rflg := TRUE;            
    END;
   IF lflg AND rflg THEN ljustify := center        
    ELSE IF lflg THEN ljustify := right
     ELSE ljustify := left;
    lfsize := 0; 
    temp1 := SCAN(-LENGTH(ltoken),=':',ltoken[LENGTH(ltoken)]);     
    IF temp1<>-LENGTH(ltoken) THEN  
     BEGIN
      lfsize := Val(COPY(ltoken,LENGTH(ltoken)+temp1+1,-temp1));
      DELETE(ltoken,LENGTH(ltoken)+temp1,-temp1+1);      
     END;
    leqpart := '';   
    IF lposinline<LENGTH(line) THEN         
     IF line[lposinline]='=' THEN 
      BEGIN    
       DELETE(line,lposinline,1);      
       WHILE (lposinline<=LENGTH(line)) AND (line[lposinline]<>'=') DO
        BEGIN
         leqpart := CONCAT(leqpart,COPY(line,lposinline,1));         
         DELETE(line,lposinline,1);    
        END;
       IF leqpart[LENGTH(leqpart)]='=' THEN                            
        DELETE(line,lposinline,1);             
       IF leqpart[LENGTH(leqpart)]='=' THEN    
        DELETE(leqpart,LENGTH(leqpart),1);            
      END;   
 END (* Getltoken *);    
   
FUNCTION Hasltoken: BOOLEAN;     
 VAR intb : BOOLEAN;  
 BEGIN 
  intb := FALSE;
  WHILE (POS('*)',line)<>0) AND           
        ((POS('(*',line)=0) OR 
         (POS('(*',line)>POS('*)',line))) DO 
   DELETE(line,POS('*)',line),2);  
  lposinline :=  POS('(*',line);  
  DELETE(line,lposinline,2);   
  lflg := FALSE;
  rflg := FALSE;
  IF line[lposinline] =' ' THEN     
   BEGIN
    DELETE(line,lposinline,1);      
    lflg := TRUE;
   END;      
  IF (POS(COPY(line,lposinline,1),legalfchrs)=0) OR                             
     (POS(COPY(line,lposinline+1,1),legal2chrs)=0) OR  
     (line[lposinline+2] IN ['A'..'Z','a'..'z']) OR     
     (NOT (line[lposinline+2] IN [':',' ','*'])) THEN
   BEGIN
    intb := TRUE;
    Getltoken;        
   END
  ELSE
   BEGIN  
    IF lflg THEN INSERT(' ',line,lposinline);          
    INSERT('(*',line,lposinline); 
   END;  
  Hasltoken := intb;   
 END;   
    
 BEGIN (* Chgtokens *)    
  legalfchrs := 'gpfmlstcacszpcmGPFMLSTCACSZPCM';         
  legal2chrs := 'rrnnnuinditinoiRRNNNUINDITINOI0123456789';       
  REPEAT  
   IF POS('(*',line)<>0 THEN   
    BEGIN              
     IF Hasltoken THEN           
      BEGIN
       WHILE (POS('(*',ltoken)<>0) AND
             Hastoken(ltoken) DO Chg1(ltoken);            
       IF LENGTH(ltoken)<>0 THEN
        INSERT(leqpart,line,lposinline);          
       Putone(ljustify,ltoken,lfsize,lposinline,line);    
      END
     ELSE IF Hastoken(line) THEN Chg1(line);             
    END;  
  UNTIL POS('(*',line)=0;                     
 END;       
         
  PROCEDURE Getnext;            
   VAR eqflg : BOOLEAN;    
       chsonline:integer;
       {temp count of chs put on the line for comma decisions}
   BEGIN    
    REPEAT  
     READLN(infile,line);    
     Prflgs;       
     IF LENGTH(line)>0 THEN Chgtokens;                      
     eqflg := FALSE;  
     IF POS('^',line)=1 THEN
      BEGIN
       DELETE(line,1,1);
       pgflg := TRUE;       
      END;
     IF POS('=',line)=1 THEN     
      BEGIN
       DELETE(line,1,1);
       eqflg := TRUE;
      END;
     IF POS(DirStr,line)=0 THEN                               
      WHILE POS(' ',line)=1 DO DELETE(line,1,1)    
     ELSE  
      IF eqflg THEN
       BEGIN          
        tline := line;      
        WHILE POS(DirStr,tline)<>0 DO DELETE(tline,POS(DirStr,tline),1);
        WHILE POS(' ',tline)=1 DO DELETE(tline,1,1);    
        IF LENGTH(tline)=0 THEN line := '';        
       END;
    UNTIL EOF(infile) OR (NOT eqflg) OR ((LENGTH(line)<>0) AND eqflg);     
   IF POS('\\',line)=1 THEN WITH disk^ DO {insert mailing label in letter}
    BEGIN 
     {linat alters in here by 2 to 4 - ignored if poption FALSE}
     Outline;
     WRITE(odisk,lmarg);
     IF LENGTH(prefx)<>0 THEN WRITE(odisk,prefx,' ');
     WRITE(odisk,fname,' ');
     IF LENGTH(minit)<>0 THEN WRITE(odisk,minit,' ');
     WRITE(odisk,lname);
     IF LENGTH(suffx)<>0 THEN WRITE(odisk,', ',suffx);    
     WRITELN(odisk);
     Linat:=linat+1;
     IF (LENGTH(title)<>0) OR (LENGTH(coname)<>0) THEN    
      BEGIN
       WRITE(odisk,lmarg,title);
       IF (LENGTH(title)<>0) AND (LENGTH(coname)<>0)
        THEN WRITE(odisk,', ');     
       WRITELN(odisk,coname);                
       linat := linat + 1;
      END;
     WRITELN(odisk,lmarg,address);   
     linat:=linat+1;
     WRITE(odisk,lmarg,city);     
     chsonline:=length(city);
     IF (chsonline<>0) and (length(state)<>0)  THEN WRITE(odisk,', ');
     IF (LENGTH(state)<>0) THEN WRITE(odisk,state,'.');
     chsonline:=chsonline+length(state); {approx length only}
     if length(country)+length(zip)<>0 then
       begin
         if chsonline<>0 then write(odisk,', ');
         write(odisk,country);
         chsonline:=chsonline+length(country); {approx only}
         IF (chsonline<>0) and (length(zip)<>0) THEN WRITE(odisk,', ');
         WRITELN(odisk,zip);
         linat:=linat+1;
       end;
     Getnext; 
    END; 
   END;   
  
  procedure LInitParams;
   BEGIN
    with format^ do begin
      lmgin := llmgin;         
      pmgin := lpin;
      SetPLMargins(pmgin,lmgin);
      lsize := (lchar-llmgin)-lrmgin;                
      spc   := spacing;
      {set up temporaries - these are reset within a line with [: :] barckets}
      tlmgin := lmgin;
      tpmgin := pmgin; 
      tlsize := lsize; 
     end;
   END;  

  PROCEDURE Getline;   
   BEGIN  
    IF NOT EOF(infile) THEN      
     REPEAT
      Getnext;   
      IF POS(DirStr,line)=0 THEN     
       WHILE POS(' ',line)=1 DO DELETE(line,1,1);        
      epar := (LENGTH(line)=0); {blank line encountered ends para}
      {flush last line if its contains something}
      IF (epar OR (POS(DirStr,line)<>0)) AND (oline<>'') THEN Outline;       
      IF epar THEN
        begin
          LInitParams;
          epar := FALSE;  
        end;
      WHILE (NOT(FileEnd)) AND   
           ((LENGTH(line)=0) OR (POS(DirStr,Line)<>0)) DO 
       BEGIN  
        IF LENGTH(line)=0 THEN newpar := TRUE;      
        IF POS(DirStr,line)<>0 THEN newpar := FALSE;    
        WHILE POS(DirStr,line)<>0 DO           
         DELETE(line,POS(DirStr,line),1);              
        
        WRITE(odisk,lmarg,line);                     
        FOR temp4 := 1 TO ORD(spc) DO WRITELN(odisk);      
        
        if EOF(infile) then
          begin
            FileEnd:=true;
            line:='';
          end;
        IF format^.poption THEN Chkpage;                 
        if NOT(FileEnd) then
          begin
            Getnext; 
            IF POS(DirStr,line)=0 THEN 
               WHILE POS(' ',line)=1 DO DELETE(line,1,1);  
          end;
       END;      
    UNTIL EOF(infile) OR (POS('\\',line)<>1);   
   END;         
   
  PROCEDURE Getoken;            
   BEGIN  
    token := '';           
    REPEAT
     IF POS(' ',line)<>0 THEN             
       BEGIN    
        token := COPY(line,1,POS(' ',line)-1);        
        DELETE(line,1,POS(' ',line))        
       END     
      ELSE   
       BEGIN
        token := line;     
        line := '';      
       END;
      WHILE Hasmgin DO Getmgin;    
      WHILE POS(' ',token)=1 DO DELETE(token,1,1);   
      IF (LENGTH(token)=0) AND (LENGTH(line)=0) THEN Getline;
    UNTIL (LENGTH(token)<>0) OR EOF(infile);                                    
   END;       
   
  FUNCTION Addable : BOOLEAN;
   BEGIN
    temp := lsize;
    IF newpar THEN temp := temp - pmgin; 
     Addable := NOT(LENGTH(token)=0) AND (LENGTH(token)+LENGTH(oline)+1<temp);
   END; 
  
  PROCEDURE Addit;      
   BEGIN
    IF LENGTH(oline)<>0 THEN oline := CONCAT(oline,' ',token)     
     ELSE oline := token;      
   END;   
  
  PROCEDURE Oletter;   
   BEGIN             
    {$I-}
    RESET(infile,LetterName);    
    IF IORESULT<>0 THEN
      Reporterr('Cannot open input file ',LetterName,IORESULT)
    else
      begin
        SC_Clr_Screen;
        IF format^.ofilename <> '#2:' THEN WRITE('Processing a letter');
        LInitParams;
        pageat := format^.lspage;                               
        newpar := TRUE;         
        pgflg  := FALSE; 
        epar   := FALSE;        
        oline  := '';      
        token  := '';   
        FileEnd:=false;
        LastPageWritten:=false;
        PutTopMargin;
        Getgreet;
        WHILE NOT EOF(infile) DO                                     
         BEGIN            
          Getline;      
          WHILE LENGTH(line)>0 DO           
           BEGIN
            Getoken;  
            IF LENGTH(oline)<tlsize THEN
              BEGIN
                lsize:=tlsize;
                lmgin:=tlmgin;
              END;
            IF Addable THEN Addit 
                       ELSE Outline;    
           END;  
         END;  
         FileEnd:=true;
         if oline<>'' then Outline; {force out remainder of line}
        CLOSE(infile);  
      end;
     {$I+}
     if format^.ofilename<>'#2:' then
       begin
         writeln;
         writeln('Finished with this letter.');
       end;
  END;   
    
 PROCEDURE Wparta;
 var ch2:char;
  BEGIN  
   repeat
     SC_Clr_Line(1);
     SC_Clr_Line(0);        
     WRITELN('Wildcard: P)refix, F)name, mi(N)it, L)name, s(U)ffix, T)itle, C)mpny, ');
     WRITE('         #)ph, A)dd, c(I)ty, S)tate, cntr(Y), Z)ip, M)isc, Q)uit:');
     READ(KEYBOARD,ch2);
   until (ch2 IN ['P','p','F','f','N','n','L','l','U','u','T','t','M','m',     
            'C','c','#','A','a','I','i','S','s','Y','y','Z','z','Q','q']);
   if (ch2 in ['Q','q']) then EXIT(Letter);    
   SC_Clr_Line(1);
   SC_Clr_Line(0);
   Wild1(ch2);        
   increment:=1;
   FOR recnumber := recnumber TO numrecs DO   
    BEGIN
     SEEK(disk,recnumber);    
     GET(disk);   
     Wild2;
     IF (disk^.code='Perm  ') OR (disk^.code='Add   ') 
      OR (disk^.code='Change') THEN
      IF Wildok THEN    
     BEGIN
      Oletter;  
      if NOT(format^.poption) then Chkorquit;
     END;
    END;     
   END;  
 
 procedure GetLetterName;
 var ch:char; ok,newname:boolean;
 begin
   Lettername:=format^.infilename;
   SC_Clr_Line(1);
   SC_Clr_Line(0);
   Write('Do you wish to use the letter in ',LetterName,' (Y/N):');
   repeat
     read(KEYBOARD,ch);
   until ch in ['Y','y','N','n'];
   write(ch);
   newname:=((ch='N') or (ch='n'));
   ok:=false;
   repeat
     if newname then
       begin
         SC_Clr_Line(1);
         write('Give file holding the letter ',
               '(<esc><cr> to quit):');
         readln(LetterName);
         if length(LetterName)>0 then
            if Lettername[1]=CHR(27) then Exit(Letter);
         UpperCase(LetterName);
         if (Length(LetterName)<=5) or
            (POS('.TEXT',LetterName)<>(Length(LetterName)-4))
         then LetterName:=CONCAT(LetterName,'.TEXT');
       end;
     newname:=true; {in case check fails}
     if chkfiles(LetterName) then ok:=true
     else
       begin
         SC_Clr_Line(0);
         write('Cannot open input file ',LetterName);
       end;
   until ok;
 end;
 
 BEGIN (* Letter *)           
  GetLettername;
  SC_Clr_Line(1);
  SC_Clr_Line(0);   
  WRITE('Letter: A)ll, S)ingle, W)ildcard, Q)uit:');
  repeat
    READ(KEYBOARD,ch); 
  until ch in ['A','a','S','s','W','w','Q','q'];
  write(ch);
  if not(ch in ['Q','q']) then
    begin
      tempch:=format^.LDirCh;
      if NOT (tempch IN ['!','#','$','%','&','@','|','~']) then tempch:='~';
      DirStr:=' ';
      DirStr[1]:=tempch;
      {$I-}
      REWRITE(odisk,format^.ofilename);         
      IF IORESULT<>0 THEN
        Reporterr('Cannot open output file ',format^.ofilename,IORESULT)
      else
        begin
          CASE ch OF
           'W','w' : Wparta;     
           'A','a' : begin
                     increment:=1;
                     FOR recnumber := recnumber TO numrecs DO               
                      BEGIN 
                       SEEK(disk,recnumber);    
                       GET(disk);      
                       IF (disk^.code='Perm  ') OR (disk^.code='Add   ')  
                        OR (disk^.code='Change') THEN  
                         IF Chkflgs THEN 
                          BEGIN
                           Oletter;       
                           if NOT(format^.poption) then Chkorquit;  
                          END; 
                      END;       
                     end;
           'S','s' : BEGIN 
                      SEEK(disk,recnumber);  
                      GET(disk);
                      Oletter;       
                     END;
          END; 
          CLOSE(odisk,lock);   
          IF IORESULT<>0 THEN
            Reporterr('Cannot close output file ',format^.ofilename,IORESULT);
        end;
      {$I+}
    end;
END;   
        
        



========================================================================================
DOCUMENT :usus Folder:VOL11:mail3.text
========================================================================================

{Mail3 - Mlabels}
{
19-Feb-82 AT
}
{      
** program    : MAIL - Text processing mailing label data manager.         **
** authors    : Patrick R. Horton, Associated Computer Industries          **
**              Austin Tate, Edinburgh Regional Computing Centre           **
** Copyright  : (C) 1982, Austin Tate, ERCC                                **
**              Permission to use this program for non-profit purposes     **
**              is hereby granted, provided that this note is included.    **
**              Enquiries concerning uses for other purposes should be     **
**              directed to the copyright owner.                           **
}

SEGMENT PROCEDURE MLabels;       
 VAR finame,fconame : ARRAY[1..4] OF STRING[33]; 
     at,numreps : INTEGER; 
     ch,ch2:char;
 
 PROCEDURE Gfnaco;   
  VAR tfname : STRING[10];
  BEGIN 
   FOR temp := 1 TO columat DO WITH Mailarry[temp] DO 
    BEGIN
     IF LENGTH(lname)+LENGTH(fname)+LENGTH(minit) = 0 THEN
      finame[temp] := '                                 '
     ELSE
      BEGIN
       finame[temp] := ''; fconame[temp] := ''; 
       temp1 := LENGTH(lname); 
       IF LENGTH(prefx)<>0 THEN temp1 := temp1 + LENGTH(prefx) + 1;    
       IF LENGTH(suffx)<>0 THEN temp1 := temp1 + LENGTH(suffx) + 1; 
       IF LENGTH(minit)<>0 THEN temp1 := temp1 + LENGTH(minit) + 1;
       IF 33<temp1+1+LENGTH(fname)          
        THEN tfname := CONCAT(COPY(fname,1,1),'.')   
        ELSE tfname := fname;
       finame[temp] := lname;  
       IF LENGTH(minit)<>0 THEN 
        finame[temp] := CONCAT(minit,' ',finame[temp]);  
       IF LENGTH(tfname)<>0 THEN
        finame[temp] := CONCAT(tfname,' ',finame[temp]);       
       IF LENGTH(prefx)<>0 THEN
        finame[temp] := CONCAT(prefx,' ',finame[temp]);  
       IF (LENGTH(suffx)<>0) AND 
        ((LENGTH(finame[temp])+2+LENGTH(suffx))<=33) THEN              
        finame[temp] := CONCAT(finame[temp],', ',suffx);  
      END;
     fconame[temp] := coname;
     IF LENGTH(coname)+LENGTH(title)<=31 THEN {room to put on title} 
      begin
        if length(title)<>0 then
          begin
            if length(coname)<>0 then fconame[temp]:= CONCAT(title,', ',coname)
            else fconame[temp] := title;
          end;
      end;
    END;   
  END;
 
 PROCEDURE Plabel;     
  var filler:string[7];
  BEGIN 
   IF format^.ofilename = '#2:' THEN SC_Clr_Screen;
   Gfnaco;   
   WITH format^ DO   
    BEGIN    
     FOR temp := 1 TO mvtab DO WRITELN(odisk);                       
     IF rolodex THEN FOR temp := 1 TO columat DO WITH mailarry[temp] DO   
      BEGIN 
        WRITE(odisk,phone,' ':(33-LENGTH(phone)),' ':mmgin);                 
      END;
     IF rolodex THEN WRITELN(odisk);
     FOR temp := 1 TO columat DO  
      IF LENGTH(fconame[temp]) <> 0 
       THEN
        BEGIN
         WRITE(odisk,finame[temp],' ':mmgin);   
         IF LENGTH(finame[temp])<33    
          THEN WRITE(odisk,' ':(33-LENGTH(finame[temp])));  
        END
       ELSE  
         WRITE(odisk,' ':33,' ':mmgin);      
     WRITELN(odisk);
     FOR temp := 1 TO columat DO 
      BEGIN 
       IF LENGTH(fconame[temp])<>0 THEN 
        BEGIN
         WRITE(odisk,fconame[temp],' ':mmgin);        
         IF LENGTH(fconame[temp])<33 THEN  
          WRITE(odisk,' ':(33-LENGTH(fconame[temp])));
        END
       ELSE
        BEGIN
         WRITE(odisk,finame[temp],' ':mmgin);      
         IF LENGTH(finame[temp])<33   
          THEN WRITE(odisk,' ':(33-LENGTH(finame[temp])));   
        END;
      END; 
     WRITELN(odisk);
     FOR temp := 1 TO columat DO                
      BEGIN
       WRITE(odisk,mailarry[temp].address,' ':mmgin);
       WRITE(odisk,' ':(33-LENGTH(mailarry[temp].address)));
      END;
     WRITELN(odisk); 
     FOR temp := 1 TO columat DO WITH mailarry[temp] DO
      begin
        WRITE(odisk,city);
        filler:='';
        if (length(city)<>0) and (length(state)<>0) then write(odisk,', ')
        else {needs 2 spaces on end of line to align}
             filler:='  ';
        write(odisk,state,
              ' ':(31-LENGTH(city)-LENGTH(state)),' ':mmgin,filler);    
      end;
     WRITELN(odisk);
     FOR temp := 1 TO columat DO WITH mailarry[temp] DO  
      BEGIN
       WRITE(odisk,country); 
       IF (LENGTH(country) = 0) THEN
         WRITE(odisk,zip:29,'    ',' ':mmgin)    
       ELSE 
          begin
            if length(zip)=0 then filler:='  ' else filler:=', ';
            WRITE(odisk,filler,zip:(28-LENGTH(country)),'   ',' ':mmgin);  
          end;
      END;
     WRITELN(odisk);
    END;
  END;   
  
PROCEDURE Printone;  
 BEGIN  
  WITH format^ DO
   BEGIN  
    IF NOT eflg THEN     
     BEGIN
      columat := columat + 1;            
      mailarry[columat] := disk^;               
     END;        
    GOTOXY(0,22);  
    IF (NOT eflg) AND (columat < mwide) THEN EXIT(Printone);          
    Plabel;
    columat := 0;     
   END;
 END;      
 
 {$I-}
 BEGIN          
  repeat
    SC_Clr_Line(1);
    SC_Clr_Line(0);
    WRITE('MLabels: A)ll matching flag criteria, S)ingle, R)epeat, W)ildcard, Q)uit:');
    READ(KEYBOARD,ch);
  until ch in ['A','a','S','s','W','w','R','r','Q','q'];
  write(ch);
  if (ch='Q') or (ch='q') then exit(MLabels);
  REWRITE(odisk,format^.ofilename);  
  if IORESULT<>0 then
    Reporterr('Cannot open output file ',format^.ofilename,IORESULT)
  else
    begin
      eflg := FALSE;  
      CASE ch OF
       'W','w' : BEGIN 
                  repeat
                    SC_Clr_Line(0);
                    WRITELN('Wildcard: P)refix, F)name, mi(N)it, ',
                            'L)name, s(U)ffix, T)itle, C)mpny,');
                    WRITE('          #)ph, A)dd, c(I)ty, S)tate, cntr(Y), ',
                          'Z)ip, M)isc, Q)uit:');
                    READ(KEYBOARD,ch2);
                  until ch2 in
                     ['P','p','F','f','N','n','L','l','U','u','T','t','M','m',
                      'C','c','#'    ,'A','a','I','i','S','s','Y','y','Z','z',
                      'Q','q']; 
                  write(ch2);
                  if ch2 in ['Q','q'] THEN 
                     BEGIN
                      CLOSE(odisk);
                      EXIT(MLabels);   
                     END;
                  SC_Clr_Line(1);
                  SC_Clr_Line(0);
                  Wild1(ch2);  
                  FOR recnumber := 1 TO numrecs DO  
                   BEGIN
                    SEEK(disk,recnumber); 
                    GET(disk);
                    IF (disk^.code='Perm  ') OR (disk^.code='Add   ') OR
                     (disk^.code='Change') THEN 
                     BEGIN
                      Wild2;
                      IF Wildok THEN Printone;          
                     END;
                   END; 
                  IF columat <> 0 THEN    
                   BEGIN 
                    eflg := TRUE;
                    Printone;
                   END;      
                 END;
       'A','a' : BEGIN  
                  FOR recnumber := 1 TO numrecs DO
                   BEGIN
                    SEEK(disk,recnumber);
                    GET(disk);
                    IF (disk^.code='Perm  ') OR (disk^.code='Add   ') OR
                     (disk^.code='Change') THEN
                      IF Chkflgs THEN Printone;     
                   END;
                   IF columat <> 0 THEN   
                    BEGIN 
                     eflg := TRUE;
                     Printone;
                    END;      
                 END;
       'R','r' : BEGIN
                  SEEK(disk,recnumber);
                  GET(disk);
                  repeat
                    SC_Clr_Line(0);
                    WRITE('Enter number of repetitions (max 100):');
                    numreps:=0; {value returned if integer is illegal}
                    Getint(0,0,numreps);
                  until (numreps<=100) and (numreps>=0);
                  if numreps>0 then FOR at := 1 TO numreps DO Printone;  
                  IF columat<>0 THEN 
                   BEGIN
                    eflg := TRUE; 
                    Printone;
                   END;
                 END;
       'S','s' : BEGIN     
                  SEEK(disk,recnumber);    
                  GET(disk); 
                  Printone;  
                 END;
      END; 
     CLOSE(odisk,lock);  
     if IORESULT<>0 then
       ReportErr('Cannot close output file ',format^.ofilename,IORESULT);
   end;
END;
{$I+}
  
 

========================================================================================
DOCUMENT :usus Folder:VOL11:mail4.text
========================================================================================

{Mail4 - Options}
{
22-Feb-82 AT
}
{      
** program    : MAIL - Text processing mailing label data manager.         **
** authors    : Patrick R. Horton, Associated Computer Industries          **
**              Austin Tate, Edinburgh Regional Computing Centre           **
** Copyright  : (C) 1982, Austin Tate, ERCC                                **
**              Permission to use this program for non-profit purposes     **
**              is hereby granted, provided that this note is included.    **
**              Enquiries concerning uses for other purposes should be     **
**              directed to the copyright owner.                           **
}

SEGMENT PROCEDURE Options;
 VAR illflg : BOOLEAN; 
     ch:char;

{$I-}
PROCEDURE Dumpflgs;          
 BEGIN 
  WITH format^ DO  
   BEGIN
    column := 0;
    REWRITE(odisk,ofilename);  
    IF IORESULT<>0 THEN
      Reporterr('Cannot open output file ',ofilename,IORESULT)
    else
      begin
        if ofilename='#2:' then
          begin
            SC_Clr_screen;
            gotoxy(0,2);
          end;
        WRITELN(odisk,'Descriptions and Flags Set');
        WRITELN(odisk,'----------------------------------------------------------');
        FOR temp := 1 TO 48 DO
         BEGIN
          column := column + 1;
          WRITE(odisk,temp:2,'.',meanings[temp]);    
          IF fflags[temp] THEN
           BEGIN
            WRITE(odisk,'........................':(21-LENGTH(meanings[temp])));
            WRITE(odisk,'*  ');    
           END
          ELSE
            WRITE(odisk,'                             ':24-LENGTH(meanings[temp]));
          IF column = 3 THEN BEGIN column := 0;WRITELN(odisk);END; 
         END;
        CLOSE(odisk,lock);
        if IORESULT<>0 then
          Reporterr('Cannot close output file ',ofilename,IORESULT)
      end;
   END {with format^}; 
 END;
 {$I+}
 
 PROCEDURE Chgfflgs; 
  var ch,ch1:char;
  BEGIN
   WITH disk^,format^ DO  
    REPEAT;
      SC_Clr_Screen;
      temp1 := 2;
      column := 0;
      FOR temp := 1 TO 48 DO        
       BEGIN
        temp1 := temp1 + 1;
        GOTOXY(column * 27,temp1);
        WRITE(temp:2,'.',meanings[temp]);  
        IF fflags[temp] THEN
         BEGIN
          WRITE('.............................':(21-LENGTH(meanings[temp])));
          WRITE('*');      
         END;
        IF temp1 = 18 THEN BEGIN temp1 := 2;column := column + 1;END;
       END; 
      WRITELN;
      WRITE('Matching option: ');
      IF option THEN WRITELN('A)ny positive match')
                ELSE WRITELN('E)xact matches only');
     repeat
       SC_Clr_Line(0);   
       WRITE('Match Flags: D)ump, O)ption, R)emove, S)et, Q)uit:');
       READ(KEYBOARD,ch1);
     until ch1 in ['D','d','O','o','R','r','S','s','Q','q'];
     write(ch1);
     CASE ch1 OF
      'D','d' : Dumpflgs;
      'O','o' : BEGIN
                  repeat
                    SC_Clr_Line(0);
                    WRITE('Flag option: E)xact matches only, ',
                          'A)ny positive match, Q)uit:');
                    READ(KEYBOARD,ch);
                 until ch in ['E','e','A','a','Q','q'];
                 write(ch);
                 CASE ch OF
                  'E','e' : format^.option := FALSE;
                  'A','a' : format^.option := TRUE;
                 END;
                END;    
      'R','r' : BEGIN  
                 SC_Clr_Line(0);
                 WRITE('Enter flagnumber to be removed:');
                 Getint(0,0,temp);  
                 IF (temp>0) AND (temp<=48) THEN    
                  fflags[temp] := FALSE;    
                END;
      'S','s' : BEGIN
                 SC_Clr_Line(0);
                 WRITE('Enter flagnumber to be set:');
                 Getint(0,0,temp);
                 IF (temp>0) AND (temp<=48) THEN   
                  fflags[temp] := TRUE;   
                END;  
     END (* CASE *)  
  UNTIL ch1 IN ['Q','q']; 
  illflg := TRUE;
 END (* Chgfflg *);          
 
 PROCEDURE Chgmeanings;
  BEGIN    
   WITH format^ DO       
    REPEAT
     SC_Clr_Screen;
     column := 0;temp1 := 2;
     FOR temp := 1 TO 48 DO    
      BEGIN
       temp1 := temp1 + 1;
       GOTOXY(column*26,temp1);     
       WRITE(temp:2,'. ',meanings[temp]);
       IF temp1 = 18 THEN BEGIN temp1 := 2;column := column + 1;END;
      END; 
     SC_Clr_Line(0);
     WRITE('Number of Description to change, 0 to Quit:');   
     Getint(0,0,temp);        
     SC_Clr_Line(0);
     IF (temp>0) AND (temp<=48) THEN       
      BEGIN 
       SC_Clr_Line(0);
       WRITE('Enter new description #',temp:2,':');
       Rdata(0,28,0,20,format^.meanings[temp]);
      END;
    UNTIL temp = 0;
   illflg := TRUE;
 END;       
  
 
 PROCEDURE Chgspacing;   
  VAR ch1 : CHAR;
  BEGIN
   WITH format^ DO 
    BEGIN
     repeat
       GOTOXY(32,7); 
       READ(KEYBOARD,ch1);
     until ch1 in ['S','s','D','d','T','t'];
     CASE ch1 OF
      's','S' : spacing := 1;
      'd','D' : spacing := 2;
      't','T' : spacing := 3;
      END;
     GOTOXY(32,7);
     CASE spacing OF
      1 : WRITELN('single');
      2 : WRITELN('double');
      3 : WRITELN('triple');
     END;
   END;
  END; 
     
 PROCEDURE PutJOption;
 BEGIN
   GOTOXY(41,9);
   WRITE('Justification');
   GOTOXY(71,9);
   if format^.joption then write(':yes') else write(':no');
 END;
 
 function lyes(x,y:integer):boolean;
  var yes:boolean;
      ch1:char;
  BEGIN
   repeat
     GOTOXY(x,y);
     READ(KEYBOARD,ch1); 
   until ch1 in ['Y','y','N','n'];
   yes:=((ch1='Y') or (ch1='y'));
   GOTOXY(x,y);
   IF yes THEN WRITELN('yes') 
          ELSE WRITELN('no ');  
   lyes:=yes;
 END; 
 
 PROCEDURE Chglmgins; 
 var ch:char;
 BEGIN    
  repeat
   repeat
    SC_Clr_Line(0);
    WRITE('Letter margins: L)eft, R)ight, T)op, P)aragraph, J)ustify, Q)uit:'); 
    READ(KEYBOARD,ch);
   until ch in ['L','l','R','r','T','t','P','p','J','j','Q','q'];
   write(ch);
   CASE ch OF                
     'P','p' : repeat
                 Getint(32,11,format^.lpin);   
               until format^.lpin<=60;
     'T','t' : begin
                 Getint(32,10,format^.lvtab);   
                 gotoxy(40,10);
                 write('Bottom of page margin is fixed :5');
               end;
     'L','l' : repeat
                 Getint(32,8,format^.llmgin);   
               until format^.llmgin<=60;
     'R','r' : BEGIN
                 Getint(32,9,format^.lrmgin);   
                 PutJOption;
               END;
     'J','j' : format^.joption:=lyes(72,9);
   END; 
  until ch in ['Q','q'];
 END; 
 
 PROCEDURE Chglopts;
  var ch1,ch2:char;
  BEGIN
   repeat
     repeat
       SC_Clr_Line(0);
       WRITE('Letter options: P)age, S)top-pages, ',
             'F(eed pages, M(atch for flag paras, Q)uit:');
       READ(KEYBOARD,ch2); 
     until ch2 in ['M','m','F','f','P','p','S','s','Q','q'];
     write(ch2);
     WITH format^ DO
      CASE ch2 OF
      'M','m' : BEGIN
                 GOTOXY(32,17);
                 READ(ch1); 
                 CASE ch1 OF
                  's','S' : loption := FALSE;         
                  'a','A' : loption := TRUE; 
                 END (* CASE *);
                 GOTOXY(32,17); 
                 IF loption THEN WRITELN('all   ') 
                            ELSE WRITELN('single');  
                END; 
      'F','f' : ffeed:=lyes(32,16);
      'S','s' : foption:=lyes(32,15); 
      'P','p' : poption:=lyes(32,14);  
      END (* CASE *)      
    until ch2 in ['Q','q'];
  END;  
  
PROCEDURE Chgletter; 
 VAR ch1,ch2 : CHAR;
 BEGIN    
  repeat
   Repeat
     SC_Clr_Line(0); 
     WRITE('Letter: C)hrs/ln, L)ns/Pg, M)gin, D)irCh, O)pt, P)g#, ',
           'S)pacing, W)idow, Q)uit:');
     READ(KEYBOARD,ch1);
   until ch1 in ['C','c','D','d','L','l','M','m',
                 'O','o','P','p','S','s','W','w','Q','q'];
   write(ch1);
   CASE ch1 OF
    'D','d' : begin
                repeat
                  gotoxy(32,4);
                  read(KEYBOARD,Ch2);
                until Ch2 in [' ','!','#','$','%','&','@','|','~'];
                {excludes characters used elsewhere in Mail}
                if Ch2<>' ' then 
                  begin
                    format^.lDirCh:=Ch2;
                    write(Ch2);
                  end;
              end;
    'C','c' : Getint(32,5,format^.lchar);    
    'L','l' : Getint(32,6,format^.lpsiz);  
    'M','m' : Chglmgins;
    'O','o' : Chglopts;
    'S','s' : Chgspacing;
    'W','w' : Getint(32,13,format^.lpwid);   
    'P','p' : Getint(32,12,format^.lspage);    
   END;  
  until ch1 in ['Q','q'];
 END; 
 
 PROCEDURE Chgtype;      
  var ch:char;
  BEGIN
   repeat
     GOTOXY(32,23);
     READ(KEYBOARD,ch);    
   until ch in ['E','e','R','r'];
   CASE ch OF
    'E','e' : format^.rolodex := FALSE;              
    'R','r' : format^.rolodex := TRUE;          
   END (* CASE *); 
   GOTOXY(32,23);
   IF format^.rolodex THEN WRITE('rolodex ') 
                      ELSE WRITE('envelope');
  END (* Chgtype *);          

  
PROCEDURE Chglabels;      
 var ch1:char;
 BEGIN    
  repeat
    repeat
      SC_Clr_Line(0);
      WRITE('Mailing labels: N)wide, V)tab, L)margin, T)ype, Q)uit:');
      READ(KEYBOARD,ch1);          
    until ch1 in ['N','n','V','v','L','l','N','n','T','t','Q','q'];
    write(ch1);
    CASE ch1 OF
     'N','n' : Getint(32,22,format^.mwide);           
     'V','v' : Getint(32,20,format^.mvtab);   
     'L','l' : Getint(32,21,format^.mmgin); 
     'T','t' : Chgtype;       
    END;  
  until ch1 in ['Q','q'];
 END;

  FUNCTION Fquit:BOOLEAN;
   var ch:char;
   BEGIN
     repeat
       SC_Clr_Line(0);
       WRITE('Quit Option:');
       WRITE(' E)xit without updating, R)eturn to give more options, U)pdate:');
       READ(KEYBOARD,ch);
     until ch in ['E','e','R','r','U','u'];
     write(ch);
     CASE ch OF    
      'E','e' : BEGIN
                 SEEK(format,0);  
                 GET(format);
                END;
      'U','u' : BEGIN 
                 SEEK(format,0);
                 PUT(format);
                END;
     END;    
     Fquit:=((ch<>'r') AND (ch<>'R'));
   END;

PROCEDURE Foutput;

procedure fout1;
var ch:char;
begin
  WITH format^ DO 
   BEGIN
    SC_Clr_Screen;
    WRITELN; 
    WRITELN('Input filename  :',infilename);
    WRITELN('Output filename :',ofilename);
    WRITELN;
    
    ch:=LDirCh;
    if NOT (ch IN ['!','#','$','%','&','@','|','~']) then ch:='~';
    WRITELN('*Letter Format - Directive char:',ch);
    WRITELN(' Number of characters to a line:',lchar);
    WRITELN(' Number of lines to a page     :',lpsiz);
    WRITE  (' Spacing            (s, d or t):');
    CASE spacing OF
     1 : WRITELN('single');
     2 : WRITELN('double');
     3 : WRITELN('triple');
    END;
    WRITELN(' Left column margin            :',llmgin);
    WRITE  (' Right column margin           :',lrmgin);
    PutJOption; WRITELN;
    WRITE  (' Top of page margin            :',lvtab);
    WRITELN('        Bottom of page margin is fixed:5');
    WRITELN(' Paragraph margin              :',lpin);
    WRITELN(' Starting page number          :',lspage);
   end {with format^}
end {of Fout1};

procedure pyesno(yes:boolean);
begin
  if yes then writeln('yes') else writeln('no');
end;

procedure fout2;
begin
  with format^ do
   begin
    WRITELN(' Paragraph widow               :',lpwid);
    WRITE  (' Pagination            (y or n):');
    pyesno(poption);
    WRITE  (' Stop between pages    (y or n):');
    pyesno(foption);
    WRITE  (' Form feed each page   (y or n):');
    pyesno(ffeed);
    WRITE  (' Match for flag paras  (a or s):');
    if loption then writeln('all')
               else writeln('single');
    WRITELN;
    WRITELN('*Mailing Labels Format -');
    WRITELN(' Vertical tab between rows     :',mvtab);
    WRITELN(' Left margin before each label :',mmgin);
    WRITELN(' Number of labels across page  :',mwide);
    WRITE  (' Type                  (r or e):');
    IF rolodex THEN WRITE('rolodex')
               ELSE WRITE('envelope');
   END;
end {of fout2};

BEGIN
  fout1; {routines split to reduce individual code sizes}
  fout2;
END {of Foutput};

BEGIN
 RESET(format,ffilename);
 SEEK(format,0);
 GET(format);
 WITH format^ DO  
  REPEAT;
   illflg := TRUE;
   REPEAT
    IF illflg THEN Foutput; 
    illflg := FALSE;
    repeat
      SC_Clr_Line(0);
      WRITE('Options: D)scrps, F)lags, M)labels, L)etter, I)nput, O)utput, Q)uit:');
      READ(KEYBOARD,ch);
    until ch in ['D','d','F','f','M','m','L','l','I','i','O','o','Q','q'];
    write(ch);
    CASE ch OF
     'D','d' : Chgmeanings;
     'F','f' : Chgfflgs;    
     'I','i' : BEGIN 
                REPEAT
                 Rdata(1,17,1,30,infilename);   
                 UpperCase(infilename);
                 if (Length(infilename)<=5) or
                    (POS('.TEXT',infilename)<>(Length(infilename)-4))
                 then infilename := CONCAT(infilename,'.TEXT');
                UNTIL Chkfiles(infilename); 
               END;
     'L','l' : Chgletter;
     'M','m' : Chglabels;
     'O','o' : Rdata(1,17,2,30,format^.ofilename);         
    END; 
   UNTIL ch IN ['Q','q'];    
 UNTIL Fquit;   
 Gtstdflgs;
 CLOSE(format);
END;
 


========================================================================================
DOCUMENT :usus Folder:VOL11:mail5.text
========================================================================================

{Mail15 - Sortit}
{
19-Feb-82 AT
}
{      
** program    : MAIL - Text processing mailing label data manager.         **
** authors    : Patrick R. Horton, Associated Computer Industries          **
**              Austin Tate, Edinburgh Regional Computing Centre           **
** Copyright  : (C) 1982, Austin Tate, ERCC                                **
**              Permission to use this program for non-profit purposes     **
**              is hereby granted, provided that this note is included.    **
**              Enquiries concerning uses for other purposes should be     **
**              directed to the copyright owner.                           **
}

SEGMENT PROCEDURE Sortit;
   
  var sortch:char; {global holds type of sort}
  
  TYPE lptr = ^lrec;   
       lrec = RECORD   
               key1           : STRING[6];
               key2           : STRING[30];
               recfrom        : INTEGER;
               link           : lptr;      
              END;
    VAR linkedrec                   : lrec;
        first,ptr,tptr,hptr         : lptr;   
        heaptr                      : ^INTEGER; 
        ch                          : CHAR;   
        tfrecord                    : labelrec;
        rectoaddto,recat            : INTEGER;
    
  PROCEDURE Getkeys(recnumber : INTEGER);                   
   BEGIN      
    SEEK(disk,recnumber);
    GET(disk);
    WRITE('.');
    NEW(ptr);     
    WITH disk^,ptr^ DO
     BEGIN
      key1 := code;
      CASE sortch OF  
       'P','p' : key2 := prefx;
       'F','f' : key2 := fname; 
       'N','n' : key2 := minit;
       'L','l' : key2 := lname; 
       'U','u' : key2 := suffx;
       'T','t' : key2 := title; 
       'C','c' : key2 := coname;
       '#'     : key2 := phone;  
       'A','a' : key2 := address;
       'I','i' : key2 := city;        
       'S','s' : key2 := state;  
       'Y','y' : key2 := country;
       'Z','z' : key2 := zip;
       'M','m' : key2 := COPY(misc,1,30); {sort on first 30 chs of Misc only}
       END;  
      recfrom := recnumber;                                   
     END;
   END;  
   
    FUNCTION Atrecbelowtheonetobeadded: BOOLEAN;      
     VAR intb : BOOLEAN;  
     BEGIN
      intb := FALSE;  
      IF          ptr^.key1>tptr^.key1  THEN intb := TRUE                   
         ELSE IF (ptr^.key1=tptr^.key1) AND 
                 (ptr^.key2<tptr^.key2) THEN intb := TRUE;  
       Atrecbelowtheonetobeadded := intb;         
     END;        
     
  PROCEDURE Addtolinkedlist;          
   VAR intb : BOOLEAN;
   BEGIN        
    tptr := first; intb := TRUE;     
    WHILE (tptr<>NIL) AND intb DO    
    IF Atrecbelowtheonetobeadded THEN intb := FALSE
    ELSE 
     BEGIN
      hptr := tptr;  
      tptr := tptr^.link;    
     END;
    ptr^.link := tptr;  
    IF tptr = first THEN first := ptr
                    ELSE hptr^.link := ptr;
    tptr := first;
   END;     
   
  FUNCTION Inrightplace : BOOLEAN;        
   VAR intb : BOOLEAN;
   BEGIN  
    intb := TRUE ;   
    IF ptr^.recfrom <> rectoaddto THEN intb := FALSE;         
    Inrightplace := intb;   
   END;
   
  PROCEDURE Puttptratlinkedrecthatwillgototemp(temp : INTEGER);  
   VAR temp1 : INTEGER;        
   BEGIN  
    tptr := first; 
    temp1 := 1;
    WHILE (tptr<>NIL) AND (temp1<temp) DO    
     BEGIN
      temp1 := temp1 + 1;  
      tptr := tptr^.link;  
     END;
   END;   
   
  PROCEDURE Putinrightplace;        
   VAR temp2,temp  : INTEGER;  
   BEGIN 
    SEEK(disk,rectoaddto);
    GET(disk);
    WRITE('.');
    tfrecord := disk^;    
    temp := rectoaddto;  
    tptr := ptr;  
    WHILE tptr^.recfrom<>rectoaddto DO          
     BEGIN
      SEEK(disk,tptr^.recfrom);  
      GET(disk);
      WRITE('.');
      SEEK(disk,temp);           
      PUT(disk);
      WRITE('.');
      temp2 := tptr^.recfrom;      
      tptr^.recfrom := temp; 
      temp := temp2; 
      Puttptratlinkedrecthatwillgototemp(temp);     
     END; 
    tptr^.recfrom := temp;
    disk^ := tfrecord;        
    SEEK(disk,temp);  
    PUT(disk);
    WRITE('.');
   END;   
   
 PROCEDURE DoSort;
  BEGIN (* DoSort *)      
   temp := 0;   
   MARK(heaptr);
   first := nil;
   FOR recat := 1 TO numrecs DO                
    BEGIN
     Getkeys(recat); {assumes sortch set globally} 
     Addtolinkedlist;
    END;
   
   ptr := first; rectoaddto := 0;       
   
   REPEAT  
    rectoaddto := rectoaddto + 1;
    IF NOT Inrightplace THEN Putinrightplace; 
    ptr := ptr^.link;   
   UNTIL ptr=nil;  
    
   RELEASE(Heaptr);            
  END {of DoSort};
   
 PROCEDURE Getsortfield;
  BEGIN
   repeat
     SC_Clr_Screen;
     WRITELN('Sort: P)refix, F)name, mi(N)it, L)name, s(U)ffix, T)itle, C)mpny,');
     WRITE('      #)ph, A)ddress, c(I)ty, S)tate, cntr(Y), Z)ip, M)isc, Q)uit:');
     READ(KEYBOARD,sortch);
   until (sortch IN ['P','p','F','f','N','n','L','l','S','s','T','t','C','c',
              '#','A','a','I','i','Y','y','Z','z','M','m','u','U','Q','q']);
   write(sortch);
   if sortch in ['Q','q'] then EXIT(Sortit);
  END;      
    
   PROCEDURE Findnewnumrecs;
    BEGIN
     FOR temp := numrecs DOWNTO 1 DO
      BEGIN
       SEEK(disk,temp);
       GET(disk);
       WRITE('.');
       IF (disk^.code = 'Perm  ') OR (disk^.code = 'Add   ') THEN   
        BEGIN
         numrecs := temp;
         temp := 1; 
        END;
     END;
     Wnew0rec;      
    END;
    
   BEGIN {of sortit}
    Getsortfield; {sets sortch}
    Krunch;
    WRITELN;
    WRITE('Sorting '); 
    DoSort; 
    Findnewnumrecs;
    Init;
   END {of Sortit};


========================================================================================
DOCUMENT :usus Folder:VOL11:mail6.text
========================================================================================

{Mail6 - Add, Change}
{
19-Feb-82 AT
}
{      
** program    : MAIL - Text processing mailing label data manager.         **
** authors    : Patrick R. Horton, Associated Computer Industries          **
**              Austin Tate, Edinburgh Regional Computing Centre           **
** Copyright  : (C) 1982, Austin Tate, ERCC                                **
**              Permission to use this program for non-profit purposes     **
**              is hereby granted, provided that this note is included.    **
**              Enquiries concerning uses for other purposes should be     **
**              directed to the copyright owner.                           **
}

{SEGMENT except on II.0}  PROCEDURE Add;           
 var ch:char;
     oldladd:integer;
  
 PROCEDURE Findnextdel;
  BEGIN
   SEEK(disk,ladd);
   GET(disk);
   WHILE (ladd<numrecs) AND (      
         (disk^.code='Change')  
      OR (disk^.code='Add   ') 
      OR (disk^.code='Perm  ')) DO   
    BEGIN
     ladd := ladd + 1;  
     SEEK(disk,ladd);  
     GET(disk);
    END;
  IF (ladd=numrecs) AND (
     (disk^.code='Change') OR 
     (disk^.code='Add   ') OR 
     (disk^.code='Perm  ')  ) THEN 
    BEGIN
     numrecs := numrecs + 1;
     recnumber := numrecs;
     ladd := numrecs;
(*$I-*)
     disk^.code := 'Test  ';
     SEEK(disk,recnumber); 
     PUT(disk);
     temp := IORESULT;
     IF temp<>0 THEN        
      BEGIN
       SC_Clr_Screen;
       WRITELN('Caution: no more room in file, please krunch or reallocate.');  
       repeat
         gotoxy(0,1);
       until not space_wait(TRUE);
       numrecs := numrecs - 1;
       ladd := numrecs;
       recnumber := numrecs;
       EXIT(Add);
      END;
(*$I+*)
     Wnew0rec;
    END; 
  recnumber := ladd;
 END;  
 
 PROCEDURE Getadd; 
  
  procedure GAddPrompts;
  begin
    SC_Clr_Screen;                                         
    WRITELN;          
    WRITELN;
    WRITELN('prefix  :');
    WRITELN('f name  :');
    WRITELN('m init  :');
    WRITELN('l name  :');
    WRITELN('suffix  :');
    WRITELN('title   :');
    WRITELN('company :');
    WRITELN('phone   :');
    WRITELN('address :');
    WRITELN('city    :');
    WRITELN('state   :');
    WRITELN('country :');
    WRITELN('zip/post:');
    WRITELN('misc    :');
  end;
  
  BEGIN    
  WITH disk^ DO                                                 
   BEGIN   
    GAddPrompts;
    prefx := '     ';
    fname := '          ';
    minit := '  ';
    lname := '               '; {length 15}
    suffx := '      ';
    title := lname;
    coname := Spaces30; {constant string}
    phone := lname;
    address:= Spaces30;
    city  := lname;
    state := '  ';
    country := lname;
    zip := '        ';
    misc := CONCAT(Spaces30,Spaces30,Spaces30); {length 90}
    Rdata(0,9,2,5,prefx);
    Rdata(0,9,3,10,fname);   
    Rdata(0,9,4,2,minit);             
    Rdata(0,9,5,15,lname);  
    Rdata(0,9,6,6,suffx);
    Rdata(0,9,7,15,title);
    Rdata(0,9,8,30,coname);
    Rdata(0,9,9,15,phone);    
    Rdata(0,9,10,30,address);                                
    Rdata(0,9,11,15,city);   
    Rdata(0,9,12,2,state);      
    Rdata(0,9,13,15,country);        
    Rdata(0,9,14,8,zip); 
    Rdata(0,9,15,90,misc);    
           
    WITH format^ DO   
     BEGIN
      FOR temp := 1 TO 48 DO flags[temp] := FALSE;
      REPEAT
       column := 0;    
       temp1 := 0;
       SC_Clr_Screen; 
       FOR temp := 1 TO 48 DO   
        BEGIN
         temp1 := temp1 + 1;
         GOTOXY(27*column,temp1+5);  
         WRITE(temp:2,'.',meanings[temp]);         
         IF flags[temp] THEN     
          BEGIN  
           WRITE('........................':21-LENGTH(meanings[temp]));       
           WRITE('*');
          END;        
         IF temp1 = 16 THEN BEGIN temp1 := 0;column := column + 1;END;  
        END; 
       SC_Clr_Line(0);
       WRITE('Flag to set (0 to quit) :');                    
       temp:=-1; {return value if integer not legal}
       Getint(0,0,temp);
       IF (temp>0) AND (temp<=48) THEN flags[temp] := TRUE;      
      UNTIL temp = 0;            
     END (* WITH format^ *);        
   END; (* WITH disk^ *)         
  END (* Getadd *);
  
 BEGIN   
  oldladd:=ladd; {save in case of exit}
  Findnextdel; 
  Getadd;   
  outmode := ad;    
  Outrec; 
  SC_Clr_Line(1);
  SC_Clr_Line(0);
  writeln('N)o will abort this A)dd attempt. ',
          'N.B. you can A)dd now then C)hange fields.');
  WRITE('O.K. to A)dd (Y/N):');
  repeat
    READ(keyboard,ch);
  until ch in ['Y','y','N','n'];
  write(ch);
  IF (ch='N') or (ch='n') THEN    
   BEGIN
    IF recnumber = numrecs THEN numrecs := numrecs - 1;
    ladd:=oldladd;
    EXIT(Add);                              
   END;  
  disk^.code := 'Add   ';                  
  SEEK(disk,recnumber); 
  PUT(disk);
  NEW(ptr2);
  ptr2^.intpart := recnumber;
  ptr2^.lpart2 := first2;
  first2 := ptr2;
 END (* Add *);                     
  
  
{SEGMENT except on II.0}  PROCEDURE Change;               
   var ch:char;
   
 PROCEDURE Chgflg;
  var ch1:char;
  BEGIN
   REPEAT;
    WITH disk^,format^ DO
     BEGIN
      SC_Clr_Screen;
      column := 0;
      temp1 := 2;
      FOR temp := 1 TO 48 DO  
       BEGIN
        temp1 := temp1 + 1;              
        GOTOXY(column*27,temp1);    
        WRITE(temp:2,'.',meanings[temp]);       
        IF flags[temp] THEN   
         BEGIN  
          WRITE('........................':(21-LENGTH(meanings[temp])));
          WRITE('*');      
         END; 
        IF temp1 = 18 THEN BEGIN temp1 := 2;column := column + 1;END;
       END;        
      repeat
        SC_Clr_Line(0);
        WRITE('Chgflags for ',lname,': R)emove, S)et, Q)uit:');
        READ(KEYBOARD,ch1);  
      until ch1 in ['R','r','S','s','Q','q'];
      write(ch1);
      CASE ch1 OF
       'R','r' : BEGIN  
                  SC_Clr_Line(0);
                  WRITE('Enter flagnumber to be removed:');
                  temp:=-1; {return value if integer not legal}
                  Getint(0,0,temp);
                  IF (temp>0) AND (temp<=48) THEN          
                   flags[temp] := FALSE;     
                 END;
       'S','s' : BEGIN
                  SC_Clr_Line(0);                                  
                  WRITE('Enter flagnumber to be set:');
                  temp:=-1; {return value if integer not legal}
                  Getint(0,0,temp);
                  IF (temp>0) AND (temp<=48) THEN  
                   flags[temp] := TRUE;  
                 END;
      END (* CASE *)      
    END (* WITH *);          
   UNTIL ch1 IN ['Q','q']; 
  END (* Chgflg *);  
  
 PROCEDURE Chgcase(cch:char);    
  VAR tlname2 : STRING[15];   
  BEGIN     
   CASE cch OF      
    'G','g' : Chgflg;                  
    'P','p' : BEGIN     
               WRITE('Enter new prefix:');
               Rdata(0,19,0,5,disk^.prefx);
              END;
    'F','f' : BEGIN
               WRITE('Enter new forename:');
               Rdata(0,19,0,10,disk^.fname);
              END;
    'N','n' : BEGIN
               WRITE('Enter new middle initials:');
               Rdata(0,25,0,2,disk^.minit);
              END;
    'L','l' : BEGIN
               WRITE('Enter new last name:');
               Rdata(0,20,0,15,disk^.lname);
              END;
    'U','u' : BEGIN
               WRITE('Enter new suffix:');
               Rdata(0,17,0,6,disk^.suffx);
              END;
    'T','t' : BEGIN
               WRITE('Enter new title:');
               Rdata(0,16,0,15,disk^.title);
              END;
    'C','c' : BEGIN            
               WRITE('Enter new company:');
               Rdata(0,18,0,30,disk^.coname);
              END;
    '#'     : BEGIN
               WRITE('Enter new phone #:');
               Rdata(0,18,0,15,disk^.phone);
              END;
    'A','a' : BEGIN
               WRITE('Enter new address:');
               Rdata(0,18,0,30,disk^.address);
              END;
    'I','i' : BEGIN
               WRITE('Enter new city:');
               Rdata(0,15,0,15,disk^.city);
              END;
    'S','s' : BEGIN
               WRITE('Enter new state:');
               Rdata(0,16,0,2,disk^.state);
              END;
    'Y','y' : BEGIN
               WRITE('Enter new country:');
               Rdata(0,18,0,15,disk^.country);
              END;
    'Z','z' : BEGIN
               WRITE('Enter new ZIP/post code:');
               Rdata(0,24,0,8,disk^.zip);
              END;
    'M','m' : BEGIN
               WRITE('Enter new misc:');
               Rdata(0,15,0,90,disk^.misc);
              END;
    END (* CASE *);
   END;
 
 BEGIN        
  IF disk^.code = 'Perm  ' THEN
   BEGIN
    NEW(ptr);    
    NEW(ptr2);
    STR(recnumber,disk^.code);       
    ptr^.recpart := disk^;    
    ptr2^.intpart := recnumber;
    ptr^.lpart := first;  
    ptr2^.lpart2 := first2;
    first := ptr;
    first2 := ptr2;
    disk^.code := 'Change';    
    SEEK(disk,recnumber);           
    PUT(disk);            
   END (* IF *);       
  REPEAT       
   outmode := ad;         
   Outrec;     
   repeat
     SC_Clr_Line(1);
     SC_Clr_Line(0);      
     WRITELN('Change: P)refix, F)name, mi(N)it, L)name, s(U)ffix, T)itle, C)mpny,');
     WRITE('        #)ph, A)dd, c(I)ty, S)tate, cntr(Y), Z)ip, M)isc, fla(G)s, Q)uit:');
     READ(KEYBOARD,ch); 
   until ch in ['P','p','F','f','N','n','L','l','U','u','T','t','C','c',
                '#',    'A','a','I','i','S','s','Y','y','Z','z','M','m',
                'G','g','Q','q'];
   SC_Clr_Line(1);
   SC_Clr_Line(0);  
   Chgcase(ch);
  UNTIL ch IN ['Q','q'];   
  {top 2 lines already clear}
  WRITELN('N)o will leave the record in its original state.');
  WRITE('O.K. to C)hange (Y/N):');
  repeat
    READ(keyboard,ch);
  until ch in ['Y','y','N','n'];
  write(ch);
  IF (ch='Y') or (ch='y') THEN BEGIN SEEK(disk,recnumber);PUT(disk);END 
                          ELSE BEGIN SEEK(disk,recnumber);GET(disk);END;
 END; (* Change *) 
     


========================================================================================
DOCUMENT :usus Folder:VOL11:mail7.text
========================================================================================

{Mail7 - Chkfiles, Uppercase, Gtstdflgs, Val, Rdata, Getint, WNew0Rec,
         Wild1, Wild2, Wildok, Chkflgs, Outrec}
{
19-Feb-82 AT
}
{      
** program    : MAIL - Text processing mailing label data manager.         **
** authors    : Patrick R. Horton, Associated Computer Industries          **
**              Austin Tate, Edinburgh Regional Computing Centre           **
** Copyright  : (C) 1982, Austin Tate, ERCC                                **
**              Permission to use this program for non-profit purposes     **
**              is hereby granted, provided that this note is included.    **
**              Enquiries concerning uses for other purposes should be     **
**              directed to the copyright owner.                           **
}
 
(*$I-*)
FUNCTION Chkfiles{(s : STRING) : BOOLEAN};   
 BEGIN
  RESET(infile,s); 
  Chkfiles:=(IORESULT=0);
  CLOSE(infile);
 END;  
(*$I+*)
 
PROCEDURE Uppercase{(VAR s: STRING)};    
 VAR t : INTEGER;
 BEGIN
  FOR t := 1 TO LENGTH(s) DO
   IF s[t] IN ['a'..'z'] THEN s[t] := CHR(ORD(s[t])-32);  
 END;

PROCEDURE Gtstdflgs;   
 BEGIN
  FOR temp := 1 TO 5 DO stdflg[temp] := 0;
  FOR temp := 1 TO 48 DO
   BEGIN
    tmpstr := format^.meanings[temp];
    Uppercase(tmpstr);
    IF tmpstr='PREFX' THEN stdflg[1] := temp; 
    IF tmpstr='FNAME' THEN stdflg[2] := temp; 
    IF tmpstr='MINIT' THEN stdflg[3] := temp; 
    IF tmpstr='LNAME' THEN stdflg[4] := temp; 
    IF tmpstr='SUFFX' THEN stdflg[5] := temp; 
   END;
END;

FUNCTION Val{ (s : STRING) : INTEGER};                   
 VAR i,j,k: INTEGER;
     good,goodch: BOOLEAN;
 BEGIN   
  j := 0; k := 0; i := 1;
  good:=false; {good when at least one digit found}
  goodch:=true;{false when a non digit or non '-' found}
  IF LENGTH(s)<>0 THEN
   BEGIN
    IF (LENGTH(s)>1) AND (s[1] = '-') THEN BEGIN k := k + 1;i := -1;END;
    while (k<length(s)) and goodch do begin
      k := k + 1; 
      IF (s[k] IN ['0'..'9']) THEN    
       BEGIN
        good:=true; {number okay from now - bad ch terminates}
        j := j * 10; 
        j := j + ORD(s[k]) - 48;
       END
      ELSE goodch:=false; 
    end;
   END;
  if good then Val := i*j else Val:=-9999;   
 END (* Val *);      
      
PROCEDURE Rdata{(a,x,y,l : INTEGER; VAR s: STRING)};        
 var i:integer;
 BEGIN 
  REPEAT
   IF NOT ((x=0) AND (y=0)) THEN {altered from (x<>0) AND (y<>0) by BAT}
    BEGIN
     SC_Erase_to_EOL(x,y);
     GOTOXY(x,y);
     WRITE(' ':l,'<');    
     GOTOXY(x,y);
    END;    
   READLN(tmpstr);   
  UNTIL LENGTH(tmpstr)<=l;  
  {remove control characters}
  i:=1;
  while i<=length(tmpstr) do begin {tmpstr length alters in loop}
    if tmpstr[i]<' ' then delete(tmpstr,i,1)
    else i:=i+1;
  end;
  IF NOT((POS('^',tmpstr)=1) AND (length(tmpstr)=1)) THEN s := tmpstr;
  IF a<>0 THEN {write out field again}
   BEGIN 
     SC_Erase_to_EOL(x,y);
     GOTOXY(x,y);
     WRITE(s);  
   END;
 END;         
   
PROCEDURE Getint{(x,y : INTEGER; VAR t1 :INTEGER)};                    
 {read an integer from position x,y on screen}
 {if x=o and y=0 read from current position on screen}
 {if character illegal, return previous value of t1}
 VAR temp1,temp2,t3 : INTEGER;
     tmpstr : STRING;
 BEGIN   
  t3 := t1;
  tmpstr :='';   
  temp2 := 6; {max legal integer length - ie 999999}
  temp1 := 0; {no refresh after read}
  IF (x<>0) OR  (y<>0) THEN
    BEGIN
      temp2 := 3; {max legal integer length - ie 999}
      temp1 := 1; {and allow refresh of integer after read}
    END; 
  Rdata(temp1,x,y,temp2,tmpstr);     
  IF LENGTH(tmpstr) =  0 THEN t1 := t3 
  ELSE
    begin
      t1 := VAL(tmpstr); 
      if t1=-9999 then t1:=t3;
    end;
   IF NOT ((x=0) AND (y=0)) THEN {altered from (x<>0) AND (y<>0) by BAT}
   BEGIN  
     SC_Erase_to_EOL(x,y);
     GOTOXY(x,y);
     WRITE(t1);  
   END;
 END;

 
PROCEDURE Wnew0rec;        
 BEGIN
   disk^.code := 'Perm  ';
   STR(numrecs,disk^.zip);                            
   SEEK(disk,0);  
   PUT(disk);
 END (* wnew0rec *);               
   
PROCEDURE Wild1{(wch:char)};      
 BEGIN 
  CASE wch OF  
   'P','p' : BEGIN
              wfield := p;
              WRITE('Enter prefix:');   
              Rdata(0,13,0,5,wildcard);
             END;
   'F','f' : BEGIN
              wfield := f;
              WRITE('Enter forename:');
              Rdata(0,15,0,10,wildcard);
             END;
   'N','n' : BEGIN
              wfield := n;
              WRITE('Enter middle initials:');
              Rdata(0,22,0,2,wildcard);
             END;
   'L','l' : BEGIN
              wfield := l;
              WRITE('Enter last name:');
              Rdata(0,16,0,15,wildcard);
             END;
   'U','u' : BEGIN
              wfield := u;
              WRITE('Enter suffix:');
              Rdata(0,13,0,6,wildcard);
             END;
   'T','t' : BEGIN
              wfield := t;
              WRITE('Enter title:');
              Rdata(0,12,0,15,wildcard);
             END;
   'C','c' : BEGIN
              wfield := c;
              WRITE('Enter company name:');
              Rdata(0,19,0,30,wildcard);
             END;
   '#'     : BEGIN
              wfield := p;
              WRITE('Enter phone number:');
              Rdata(0,19,0,15,wildcard);
             END;
   'A','a' : BEGIN
              wfield := a;
              WRITE('Enter address:');
              Rdata(0,14,0,30,wildcard);
             END;
   'I','i' : BEGIN
              wfield := i;
              WRITE('Enter city:');
              Rdata(0,11,0,30,wildcard);
             END;
   'S','s' : BEGIN
              wfield := s;
              WRITE('Enter state:');
              Rdata(0,12,0,2,wildcard);
             END;
   'Y','y' : BEGIN
              wfield := y;
              WRITE('Enter country:');
              Rdata(0,14,0,30,wildcard);
             END;
   'Z','z' : BEGIN
              wfield := z;
              WRITE('Enter zip/post code:');
              Rdata(0,22,0,8,wildcard);
             END;
   'M','m' : BEGIN
              wfield := m;
              WRITE('Enter misc field:');
              Rdata(0,17,0,90,wildcard);
             END;
    END;
  END;

PROCEDURE Wild2;
 BEGIN
  CASE wfield OF
   p : field := disk^.prefx;    
   f : field := disk^.fname;      
   n : field := disk^.minit;
   l : field := disk^.lname;
   u : field := disk^.suffx;
   t : field := disk^.title;
   c : field := disk^.coname;               
   h : field := disk^.phone;
   a : field := disk^.address;
   i : field := disk^.city;
   s : field := disk^.state;
   y : field := disk^.country;
   z : field := disk^.zip;
   m : field := disk^.misc;
   END;
 END;

FUNCTION Wildok{ : BOOLEAN};     
 { $ as last ch of wildcard means match anything remaining in field}
 { added 29-June-81 by Austin Tate last changed 8 july 81}
 VAR intb : BOOLEAN;
     wlast:char;
     temp1,wlen,flen:integer;
 BEGIN  
  wlen:=length(wildcard);
  flen:=length(field);
  intb:=TRUE;
  {two null strings match - this ensures that null wildcard is not indexed}
  if wlen=0 then intb:=(flen=0)
  else
    begin
      wlast:=wildcard[wlen];
      IF LENGTH(field)>=LENGTH(wildcard) THEN          
       BEGIN
         temp1:=1;
         if flen>wlen then intb:=(wlast='$');
         {must be $ on end as wildcard shorter than field}
         while intb and (temp1<wlen) do begin {check all chs except last}
           if wildcard[temp1]<>'?' then intb:=(field[temp1]=wildcard[temp1]);
           temp1:=temp1+1;
         end;
         {assert temp1=wlen}
         if intb then {check wildcard end matches or is ? or was $}
                      {length checks for $ endings passed earlier }
           begin
             if (wlast<>'?') and (wlast<>'$') then intb:=(field[wlen]=wlast);
           end;
       END
      ELSE   
       BEGIN
         {assert flen<wlen}
         intb:=((flen=(wlen-1)) and (wlast='$'));
         {wildcard must be only 1 longer than field and end in $}
         temp1:=1;
         while intb and (temp1<=flen) do begin
           if wildcard[temp1]<>'?' then intb:=(field[temp1]=wildcard[temp1]);
           temp1:=temp1+1;
         end;
       END; 
    end;
  Wildok := intb;  
 END;   
 
FUNCTION Chkflgs{ : BOOLEAN};    
 VAR intb : BOOLEAN;      
 BEGIN
  intb := TRUE;
  FOR temp := 1 TO 48 DO
   IF format^.fflags[temp] THEN intb := FALSE; 
  IF NOT intb THEN
   BEGIN
    IF format^.option THEN intb := FALSE 
                      ELSE intb := TRUE;
    FOR temp := 1 TO 48 DO    
    BEGIN 
     IF format^.option THEN  
      BEGIN
      {any positive match}      
      IF format^.fflags[temp] AND disk^.flags[temp]               
       THEN intb := TRUE;     
     END   
    ELSE
     BEGIN  
      {exact matches only}        
      IF format^.fflags[temp] AND NOT disk^.flags[temp]
       THEN intb := FALSE;        
     END (* ELSE *);              
   END (* FOR *);                       
  END;
  Chkflgs := intb;      
 END;  

PROCEDURE Outrec;

procedure Outr1;
begin
  IF outmode <> ad THEN BEGIN SEEK(disk,recnumber);GET(disk);END;
  SC_Clr_Screen;                      
  gotoxy(0,2);
  WITH format^,disk^ DO  
   BEGIN  
    WRITELN('prefix  :',prefx);
    WRITELN('f name  :',fname);
    WRITELN('m init  :',minit);
    WRITELN('l name  :',lname);
    WRITELN('suffix  :',suffx);
    WRITELN('title   :',title);
    WRITELN('company :',coname);
    WRITELN('phone   :',phone);
    WRITELN('address :',address);
    WRITELN('city    :',city);
    WRITELN('state   :',state);
    WRITELN('country :',country);
    WRITELN('zip/post:',zip);
    WRITELN('misc    :',misc);
   end {of with format^,disk^};
end {of outr1};

procedure outr2;
begin
  with format^,disk^ do
   begin
    IF outmode <> ad THEN
     BEGIN
      GOTOXY(0,18);
      WRITE('code: ',code);    
      WRITE('      recnumber: ',recnumber);
      WRITE('      flags matching option: ');   
      IF format^.option THEN WRITELN('A)ny positive match')
                        ELSE WRITELN('E)xact matches only');
      WRITE('currently at column ',columat);   
      WRITELN(' will dump labels at ',mwide);  
      WRITE('match flags set : ');
      temp1 := 0;
      FOR temp := 1 TO 48 DO 
       IF fflags[temp] THEN
        BEGIN  
         temp1 := temp1 + 1;  
         WRITE(temp:2,' ');
         IF temp =12 THEN BEGIN temp1 := 0;WRITELN;END; 
         IF temp1 = 18 THEN BEGIN temp1 := 0;WRITELN;END;
        END;
     END; 
    GOTOXY(55,2);WRITE('record flags set:');  
    GOTOXY(55,3);WRITE('-----------------');
    temp1 := 0;
    column := 0;
    FOR temp := 1 TO 48  DO    
     IF flags[temp] THEN  
      BEGIN
       temp1 := temp1 + 1; 
       GOTOXY(57+column*3,temp1+3); 
       WRITE(temp:2);  
       IF temp1 = 10 THEN BEGIN column := column + 1;temp1 := 0;END;
      END; 
   END (* WITH format^,disk^ *);                             
 end {of outr2};
 
 BEGIN
   Outr1; {split for code size}
   Outr2;
 END (* Outrec *);



========================================================================================
DOCUMENT :usus Folder:VOL11:mail8.text
========================================================================================

{Mail8 - Delte, Find, Step, Zero, Restore}
{
19-Feb-82 AT
}
{      
** program    : MAIL - Text processing mailing label data manager.         **
** authors    : Patrick R. Horton, Associated Computer Industries          **
**              Austin Tate, Edinburgh Regional Computing Centre           **
** Copyright  : (C) 1982, Austin Tate, ERCC                                **
**              Permission to use this program for non-profit purposes     **
**              is hereby granted, provided that this note is included.    **
**              Enquiries concerning uses for other purposes should be     **
**              directed to the copyright owner.                           **
}

PROCEDURE Delte;                                           
 BEGIN    
  temp1 := increment;
  IF (recnumber<1) OR (recnumber>numrecs) THEN EXIT(Delte);
  IF recnumber <= ladd THEN ladd := recnumber - 1;
  IF disk^.code = 'Perm  ' THEN
   BEGIN
    NEW(ptr);   
    STR(recnumber,disk^.code);  
    ptr^.recpart := disk^;    
    ptr^.lpart := first;
    first := ptr;
   END;
  WITH disk^ DO          
   BEGIN
    code := '      '; 
   END;
  SEEK(disk,recnumber);    
  PUT(disk);    
  Step;
  IF (disk^.code<>'Add   ') AND (disk^.code<>'Change ') AND
     (disk^.code<>'Perm  ') THEN
   BEGIN
    increment := -increment;  
    Step;
   END;
  IF (disk^.code<>'Add   ') AND (disk^.code<>'Change ') AND
     (disk^.code<>'Perm  ') THEN
   SC_Clr_Screen;  
  increment := temp1;
 END; (* Delte *)                                             
  
     
PROCEDURE Find;                    
 VAR high,low:INTEGER;  
     ch2:char;
     tempwildok:BOOLEAN;
 
 PROCEDURE Findnext; 
  VAR oldrec : INTEGER;  
  BEGIN    
   SC_Clr_Screen;        
   WRITE('Searching ');
   temp := recnumber;
   REPEAT    
    WRITE('.');
    oldrec := recnumber;    
    Step; 
    Wild2;
    tempwildok:=Wildok;
   UNTIL (oldrec=recnumber) OR tempwildok OR (recnumber=numrecs)
         OR (recnumber=1);       
  if NOT tempwildok then
    begin
      writeln;
      writeln;
      write('Not Found ...');
      repeat until NOT Space_Wait(TRUE);
    end;
  IF (NOT tempwildok) OR (oldrec=recnumber) THEN recnumber := temp;       
  SEEK(disk,recnumber);  
  GET(disk);
  END;       
      
 BEGIN             
  repeat
   SC_Clr_Line(1);
   SC_Clr_Line(0);
   IF increment = 1 THEN WRITE('>') ELSE WRITE('<');
   WRITELN('Find: P)refix, F)name, mi(N)it, L)name, s(U)ffix, T)itle, C)mpny,');
   WRITE  ('       #)ph, A)dd, c(I)ty, S)tate, cntr(Y), Z)ip, M)isc,',
           ' (^), R)ec#, Q(uit:');
   READ(KEYBOARD,ch2);
  until ch2 in ['P','p','F','f','N','n','L','l','U','u','T','t','C','c',
                '#',    'A','a','I','i','S','s','Y','y','Z','z','M','m',
                '^','R','r','Q','q'];
  SC_Clr_Line(1);
  SC_Clr_Line(0); 
  IF ch2 IN ['r','R'] THEN
   BEGIN
    WRITE('Enter record number:');
    recnumber:=-1; {returned value if integer illegal}
    Getint(0,0,recnumber);
    IF recnumber < 1 THEN recnumber := 1; 
    IF recnumber > numrecs THEN recnumber := numrecs; 
    recnumber := recnumber - increment;  
    SEEK(disk,recnumber); 
    GET(disk);
    Step;
   END 
  ELSE
    begin
      IF not(ch2 in ['Q','q']) then
      BEGIN
       Wild1(ch2);
       Findnext;
      END 
    end;
 END (* Find *);              

PROCEDURE Step;                                  
 VAR temp : INTEGER;      
 BEGIN      
  temp := recnumber; 
  REPEAT
   temp := temp + increment;
   IF (temp>numrecs) THEN temp := numrecs;    
   IF (temp<1) THEN temp := 1;      
   SEEK(disk,temp);  
   GET(disk);
  UNTIL (disk^.code='Perm  ') OR (disk^.code='Add   ') OR
   (disk^.code='Change') OR 
   ((increment=-1) and (temp=1)) OR ((increment=1) and (temp=numrecs));    
  IF (disk^.code='Perm  ') OR (disk^.code='Add   ') OR    
     (disk^.code='Change')  THEN recnumber := temp;     
  SEEK(disk,recnumber);
  GET(disk); 
 END (* step *);         
 
PROCEDURE Zero;                            
 var tmpstr:string;
 BEGIN         
  WRITELN;  
  WRITE('Caution: Type YES if you mean to destroy ',
        'the present contents of the file:');
  READLN(tmpstr);  
  Uppercase(tmpstr);
  IF tmpstr<>'YES' THEN EXIT(Zero);     
  numrecs := 0;                                   
  ladd := 0;
  orignrecs := 0;
  SC_Clr_Screen; 
  Wnew0rec;        
 END (* zero *);       
  
PROCEDURE Restore;
 BEGIN
  IF disk^.code<>'Change' THEN EXIT(Restore); 
  ptr := first; 
  WHILE (ptr<>NIL) DO
   BEGIN
   IF Val(ptr^.recpart.code)=recnumber THEN   
    BEGIN
     disk^ := ptr^.recpart;
     ptr^.recpart.code := '000000'; 
     disk^.code := 'Perm  ';
     SEEK(disk,recnumber);  
     PUT(disk);
     ptr := NIL;
    END 
   ELSE
    ptr := ptr^.lpart; 
  END;
 END; 
 


========================================================================================
DOCUMENT :usus Folder:VOL11:mail9.text
========================================================================================

{Mail9 - ReportErr, Makefile, Abort, Upate, Quit, Krunch, Initialise}
{
19-Feb-82 AT
}
{      
** program    : MAIL - Text processing mailing label data manager.         **
** authors    : Patrick R. Horton, Associated Computer Industries          **
**              Austin Tate, Edinburgh Regional Computing Centre           **
** Copyright  : (C) 1982, Austin Tate, ERCC                                **
**              Permission to use this program for non-profit purposes     **
**              is hereby granted, provided that this note is included.    **
**              Enquiries concerning uses for other purposes should be     **
**              directed to the copyright owner.                           **
}

PROCEDURE Reporterr{(st1,st2:string; res:integer)};
begin
  SC_Clr_Line(1);
  SC_Clr_Line(0);
  write(st1,st2);
  gotoxy(60,0); write('IOResult=',res);
  repeat
    gotoxy(0,1);
  until not space_wait(TRUE);
end;

{$I-}
PROCEDURE Makefile{( s : STRING)};
 VAR  tafile : FILE; 
      tarry : packed array [1..512] of char;
      Res,num,blkasked,written,temp   : INTEGER;
 BEGIN
  WRITE('Making: ',s);
  REWRITE(tafile,s);  
  Res:=IORESULT;
  IF Res<>0 THEN
    begin
      Writeln;
      Writeln('Error making file ',s,' IOResult=',Res);
    end
  else
    begin
      fillchar(tarry,512,chr(0));
      temp := POS('[',s);
      {no block number if max area to be claimed}
      IF temp=0 THEN blkasked:=0
      else blkasked:=VAL(COPY(s,temp+1,LENGTH(s)-temp));
      {-9999 is fault return from VAL}
      if blkasked<0 then blkasked:=0;
      num:=0;
      REPEAT      
        if (num mod 10)=0 then WRITE('.');
        written:=BLOCKWRITE(tafile,tarry,1);     
        num:=num+written;
      UNTIL (num=blkasked) or (written=0) or (IORESULT<>0); 
      WRITELN;
      if (blkasked<>0) and (num<>blkasked) then
          WRITELN('Could only initialise ',num,' blocks.')
      else WRITELN(num,' blocks initialised.');
      CLOSE(tafile,lock); 
      Res:=IORESULT;
      IF Res<>0 THEN Writeln('Error closing file ',s,'IOResult=',Res);
    end;
 END; 
{$I+}
    
PROCEDURE Abort;        
 BEGIN  
  if (ptr<>NIL) or (ptr2<>NIL) then
    begin
      SC_Clr_Screen;
      WRITE('Restoring records ');
    end;
  ptr := first; 
  ptr2 := first2;
  WHILE ptr2 <> NIL DO
   BEGIN
    recnumber := ptr2^.intpart;
    SEEK(disk,recnumber);
    GET(disk);
    disk^.code := '      ';
    SEEK(disk,recnumber);
    PUT(disk);
    WRITE('.');
    ptr2 := ptr2^.lpart2;
   END;
  WHILE ptr<>NIL DO
   BEGIN
    disk^ := ptr^.recpart;
    recnumber := Val(disk^.code);
    disk^.code := 'Perm  ';
    WRITE('.');
    SEEK(disk,recnumber);
    PUT(disk);
    ptr := ptr^.lpart; 
   END; 
  numrecs := orignrecs;
  Wnew0rec;
  RELEASE(heaptr); 
 END (* Abort *);                
                 
PROCEDURE Update;            
 BEGIN      
  SC_Clr_Screen;
  WRITE('Updating ');
  temp := 0;
  ptr2 := first2;
  WHILE ptr2 <> NIL DO
   BEGIN
    recnumber := ptr2^.intpart;
    SEEK(disk,recnumber);  
    GET(disk);
    disk^.code := 'Perm  ';
    SEEK(disk,recnumber);
    PUT(disk);
    WRITE('.');
    ptr2 := ptr2^.lpart2;
   END;
 RELEASE(heaptr);  
END;            
  
FUNCTION Quit:BOOLEAN;         
 var ch:char;
 BEGIN       
  unitclear(2); {flush keyboard type ahead before allowing quit}
  repeat
    SC_Clr_Screen;          
    WRITE('Quit: E)xit without updating, R)eturn to Mail, U)pdate:');
    READ(KEYBOARD,ch); 
  UNTIL ch IN ['E','e','U','u','R','r'];
  WRITE(ch);         
  CASE ch OF            
    'a','A' : abort;                
    'u','U' : update;      
   END (* case *);      
  WRITELN;       
  Quit:=not ((ch='R') OR (ch='r'));
 END (* Quit *);               
          
PROCEDURE Krunch;
 BEGIN       
  Update;     
  Init;                      
 END;
        
PROCEDURE Initialize;
 BEGIN
  Abort;  
  Init;
 END;


========================================================================================
DOCUMENT :usus Folder:VOL11:mailiniteg.text
========================================================================================


Ann Macintosh
ERCC
59, George Square
Edinburgh





Ken Currie
ERCC
59, George Square
Edinburgh





Kathy Buckner
ERCC
59, George Square
Edinburgh





Austin Tate
ERCC
59 George Square
Edinburgh, EH8 9JU



========================================================================================
DOCUMENT :usus Folder:VOL11:screenopsa.text
========================================================================================

{$S+}
unit SCREENOPS;         {A restricted implementation of version IV's SCREENOPS.}
  
  {Al Hayden Aug 1981.  Last changed Austin Tate 19-Jan-82}
  
  {Apple version which picks up the syscom variables.  For version II.1}
  
  { This is defined for version IV on pages 127..131 of the UCSD architecture
    guide. If you have a version IV system, it should be used. This unit is
    intended for use by version II users who will upgrade later, to allow them
    to write compatable software.
    If you want to play with this lot or modify it, the source (it's very 
    simple) is available from ERCC Micro Support Unit.                         }
    
    
  interface
    
    type
      SC_Long_String = string[255];           {used to pass prompt-lines around}
      SC_ChSet       = set of char;        {holds a list of chars to match with}
    
    var SC_f:file;  {unfortunately has to be public - so different user interface}
    
    procedure SC_Clr_Line (Y :integer);
                        {Clears line number Y within the current text port.}
    
    procedure SC_Clr_Screen;
                        {Clears the screen.}
    
    procedure SC_Erase_to_EOL (X, Line :integer);
                        {Starting at position (X, Line) within the current text
                         port, everything to the end of the line is erased.}
    
    function  Space_Wait (Flush :boolean) :boolean;
                        {This repeatedly reads from the keyboard until a
                         <space> or the ESC character is recieved.
                         Before doing this it does a UNITCLEAR to 1 and 2
                         if Flush is true, and writes 'Type <space> to
                         continue'. It returns true if a <space> was not
                         read. Note: ESC replaces the ALTMODE character.    }
    
    function  SC_Prompt (Line :SC_Long_String;
                         X_Cursor, Y_Cursor, X_Pos, Where :integer;
                         Return_on_Match :SC_ChSet;
                         No_Char_Back :boolean;
                         Break_Char :char) :char;
                        {This function displays the prompt-line, Line, in the
                         current text-port at (X_pos, Where). The cursor is
                         placed at (X_Cursor, Y_Cursor) after the prompt is
                         printed. If X_Cursor is less than 0, the cursor is
                         placed at the end of the prompt. If a character is
                         being prompted for, No_Char_Back should be sent as
                         false. The keyboard is repeatedly read until the
                         character matches one within Return_on_Match.}
                                  
  implementation

    CONST NUL=0;
    
    TYPE CRTCommand=(ErasEOS,ErasEOL,LeadIn);
    
    VAR CRTInfo:  packed array [CRTCommand] of Char;
        Prefixed: array [CRTCommand] of Boolean;
    
    procedure GetCRTInfo;
    var buffer: packed array [0..511] of char;
        i,j,byte: integer;
    begin
      {$I-}
      Reset(SC_f,'*SYSTEM.MISCINFO');
      i:=IORESULT;
      j:=BLOCKREAD(SC_f,buffer,1);
      if (IORESULT<>0) or (i<>0) or (j<>1) then
        WRITELN('*SYSTEM.MISCINFO must be available.');
      close(SC_f);
      {$I+}
      {the following values got from APPLE3:DISKIO.TEXT}
      {in that there are also values for UP,DOWN,LEFT and RIGHT}
      byte:=ord(buffer[72]); {prefix info byte}
      CRTInfo[LeadIn ]:=buffer[62]; Prefixed[LeadIn ]:=FALSE;
      CRTInfo[ErasEOS]:=buffer[64]; Prefixed[ErasEOS]:=ODD(Byte DIV 8);
      CRTInfo[ErasEOL]:=buffer[65]; Prefixed[ErasEOL]:=ODD(Byte DIV 4);
    end;
    
    procedure CRT(C:CRTCommand);
    var nul:packed array [0..1] of char;
    begin
      if prefixed[C] then unitwrite(1,CRTInfo[LeadIn],1,0,12);
      unitwrite(1,CRTInfo[C],1,0,12);
      nul[0]:=chr(0);
      nul[1]:=chr(0);
      unitwrite(1,nul,2,0,12);
      {at least 2 fillers to allow for gotoxy using nuls}
    end;
    
    procedure SC_Clr_Line {Y :integer};
    begin
      gotoXY (0, Y);
      if CrtInfo[ErasEOL]=CHR(NUL) then
        begin
          write (' ':79);
          gotoXY (0, Y);
        end
      else CRT(ErasEOL);
    end; {of SC_Clr_Line}
    
    procedure SC_Clr_Screen;
    var COUNT :integer;
    begin
      if CrtInfo[ErasEOS]=CHR(NUL) then
        begin
          gotoXY (0, 23);                 { Slow but safe bit for screens    }
          for COUNT := 1 to 24 do writeln;{ which don't recognise form-feeds }
          gotoXY (0, 0);
        end
      else
        begin
          gotoXY(0,0);
          CRT(ErasEOS);
        end;
    end; {of SC_Clr_Screen}
    
    procedure SC_Erase_to_EOL {X, Line :integer};
    begin
      gotoXY (X, Line);
      if CrtInfo[ErasEOL]=CHR(NUL) then
        begin
          write (' ':(80 - X));
          gotoXY (X, Line);
        end
      else CRT(ErasEOL);
    end; {of SC_Erase_to_EOL}
    
    function  Space_Wait {Flush :boolean} {:boolean};
    const ESC = 27;
    var   CH :char;
    begin
      if Flush then
        begin
          unitclear (1);
          unitclear (2);
        end;
      write ('Type <space> to continue');
      repeat read (KEYBOARD, CH) until (CH = ' ') or (CH = chr (ESC));
      if CH = ' ' then
        Space_Wait := false
      else
        Space_Wait := true;
    end;
    
    function  SC_Prompt {Line :SC_long_String;.....; Break_Char :char}{ :char};
    const BS  = 8;                                                  {back-space}
          BEL = 7;                                                        {bell}
    var   CH  :char;                                         {command character}
    begin
      if No_Char_Back then                               {no command to be read}
        CH := chr (0)                                          {so nothing sent}
      else
        begin
          SC_Clr_Line (Where); write (LINE);                {put up prompt line}
          if X_Cursor >= 0 then gotoXY (X_Cursor, Y_Cursor);      {place cursor}
          repeat
            read (KEYBOARD, CH);                     {read character, invisibly}
            if CH in ['a'..'z'] then CH := chr (ord (CH) - 32);     {upper case}
            if CH >= ' ' then                    {if it's a printable character}
              begin
                write (CH); write (chr (BS));   {echo character, then sit on it}
              end
            else
              write (chr (BEL));                   {illegal character, so bleep}
          until CH in Return_on_Match;
        end;
        SC_Prompt := CH;                          {valid character now returned}
     end; {of SC_Prompt}
     
begin
  GetCRTInfo; {initialise SYSCOM variables}
end. {of unit SCREENOPS}

========================================================================================
DOCUMENT :usus Folder:VOL11:screenopsx.text
========================================================================================

{$S+}
unit SCREENOPS;         {A restricted implementation of version IV's SCREENOPS.}
  
  {Al Hayden Aug 1981.  Last changed Austin Tate 28-Sep-81}
  
  {Terak, SuperBrain, normal Apple monitor output, or any screen
   which accepots form feed as the clear and home character}
  
  { This is defined for version IV on pages 127..131 of the UCSD architecture
    guide. If you have a version IV system, it should be used. This unit is
    intended for use by version II users who will upgrade later, to allow them
    to write compatable software.
    If you want to play with this lot or modify it, the source (it's very 
    simple) is available from ERCC Micro Support Unit.                         }
    
    
  interface
    
    type
      SC_Long_String = string[255];           {used to pass prompt-lines around}
      SC_ChSet       = set of char;        {holds a list of chars to match with}
    
    procedure SC_Clr_Line (Y :integer);
                        {Clears line number Y within the current text port.}
    
    procedure SC_Clr_Screen;
                        {Clears the screen.}
    
    procedure SC_Erase_to_EOL (X, Line :integer);
                        {Starting at position (X, Line) within the current text
                         port, everything to the end of the line is erased.}
    
   function  Space_Wait (Flush :boolean) :boolean;
                        {This repeatedly reads from the keyboard until a
                         <space> or the ESC character is recieved.
                         Before doing this it does a UNITCLEAR to 1 and 2
                         if Flush is true, and writes 'Type <space> to
                         continue'. It returns true if a <space> was not
                         read. Note: ESC replaces the ALTMODE character.    }
    
    function  SC_Prompt (Line :SC_Long_String;
                         X_Cursor, Y_Cursor, X_Pos, Where :integer;
                         Return_on_Match :SC_ChSet;
                         No_Char_Back :boolean;
                         Break_Char :char) :char;
                        {This function displays the prompt-line, Line, in the
                         current text-port at (X_pos, Where). The cursor is
                         placed at (X_Cursor, Y_Cursor) after the prompt is
                         printed. If X_Cursor is less than 0, the cursor is
                         placed at the end of the prompt. If a character is
                         being prompted for, No_Char_Back should be sent as
                         false. The keyboard is repeatedly read until the
                         character matches one within Return_on_Match.}
                                  
  implementation
  
  { procedure SC_Clr_Screen requires modification to suit terminal used        }

                         
    procedure SC_Clr_Line {Y :integer};
    begin
      gotoXY (0, Y);
      write (' ':79);
      gotoXY (0, Y);
    end; {of SC_Clr_Line}
    
    procedure SC_Clr_Screen;  { "Comment out" the bit of code you don't want  }
    var COUNT :integer;
    begin
      {-----------------------------------------------------------------------}
                                           { This bit's for "normal" terminals}
        write (chr (12)); gotoXY (0,0);    { accepting the form-feed character}
                                           { (Ascii 12).                      }
      {-----------------------------------------------------------------------}
      { gotoXY (0, 23);                  } { Slow but safe bit for screens    }
      { for COUNT := 1 to 24 do writeln; } { which don't recognise form-feeds }
      { gotoXY (0, 0);                   }
      {-----------------------------------------------------------------------}
    end; {of SC_Clr_Screen}
    
    procedure SC_Erase_to_EOL {X, Line :integer};
    begin
      gotoXY (X, Line);
      write (' ':(80 - X));
      gotoXY (X, Line);
    end; {of SC_Erase_to_EOL}
    
    function  Space_Wait {Flush :boolean} {:boolean};
    const ESC = 27;
    var   CH :char;
    begin
      if Flush then
        begin
          unitclear (1);
          unitclear (2);
        end;
      write ('Type <space> to continue');
      repeat read (KEYBOARD, CH) until (CH = ' ') or (CH = chr (ESC));
      if CH = ' ' then
        Space_Wait := false
      else
        Space_Wait := true;
    end;
    
    function  SC_Prompt {Line :SC_long_String;.....; Break_Char :char}{ :char};
    const BS  = 8;                                                  {back-space}
          BEL = 7;                                                        {bell}
    var   CH  :char;                                         {command character}
    begin
      if No_Char_Back then                               {no command to be read}
        CH := chr (0)                                          {so nothing sent}
      else
        begin
          SC_Clr_Line (Where); write (LINE);                {put up prompt line}
          if X_Cursor >= 0 then gotoXY (X_Cursor, Y_Cursor);      {place cursor}
          repeat
            read (KEYBOARD, CH);                     {read character, invisibly}
            if CH in ['a'..'z'] then CH := chr (ord (CH) - 32);     {upper case}
            if CH >= ' ' then                    {if it's a printable character}
              begin
                write (CH); write (chr (BS));   {echo character, then sit on it}
              end
            else
              write (chr (BEL));                   {illegal character, so bleep}
          until CH in Return_on_Match;
        end;
        SC_Prompt := CH;                          {valid character now returned}
     end; {of SC_Prompt}
     
end. {of unit SCREENOPS}


========================================================================================
DOCUMENT :usus Folder:VOL11:vol11.doc.text
========================================================================================

                         Volume 11 of the USUS Library
           A sophisticated mailing list program from Austin Tate of
                         USUS(UK) and a couple of games

CONTENTS.TEXT      4  A little info about the UK submission 
MAIL.DOC.TEXT    100  Documentation for MAIL.
MAIL.E.G.TEXT     10  A sample source document
MAIL.LETT.TEXT     4  A sample form letter
MAIL.INFO.DATA     4  A sample form
SCREENOPSX.TEXT   12  A Screen Control unit for version II.0
SCREENOPSA.TEXT   14  A Screen Control unit for Apple
MAIL.TEXT         18  The main program
MAIL1.TEXT        16    an include file
MAIL2A.TEXT       32 
MAIL2B.TEXT       32 
MAIL3.TEXT        16 
MAIL4.TEXT        26 
MAIL5.TEXT        14 
MAIL6.TEXT        20 
MAIL7.TEXT        22 
MAIL8.TEXT        12 
MAIL9.TEXT        10 
MAILINITEG.TEXT    4  A sample data form
MAIL.FORM.TEXT     6  A sample form
MAIL.READ.TEXT    12  Documentation on the files in MAIL
MAIL.INIT.TEXT    32  Converts a text file into a MAIL data file 
CHASE.TEXT        22  A reworked version of the game on Volume 3
BLACKJACK.TEXT    22  A reworked version of the game on Volume 3.  This
BJACK.1.TEXT      16     one splits pairs, doubles down, and has insurance.
VOL11.DOC.TEXT     8  You're reading it.
26/26 files<listed/in-dir>, 494 blocks used, 0 unused, 0 in largest

Please transfer the text below to a disk label if you copy this volume.

    USUS Volume 11 -***- USUS Software Library
                         
   For not-for-profit use by USUS members only.
  May be used and distributed only according to 
      stated policy and the author's wishes.



This volume was assembled by George Schreyer from material collected by
the Library committee.

__________________________________________________________________________

Some notes from the editor:

                                     MAIL 

     See the file MAIL.READ.TEXT for detailed info.

     
                                   BLACKJACK

     I liked the blackjack program in the now withdrawn Volume 3 so much that 
I fixed many of its shortcomings and resubmitted it here.  It now acts like a 
real blackjack game instead of double dealing like it did before (or was that 
really more realistic?).  It now can handle insurance and doubledown and split 
pairs.  It isn't very clean, I was still learning Pascal when I hacked on it 
but it does work.  I can now play three hands in five seconds and usually win 
a little, but every so often the program takes me for a ride.  It's just 
telling me that I really shouldn't go to Vegas after all.

                                     CHASE

     This was also on volume 3.  Kids love it.  It has been modified to give a 
better game setup and fix some other minor bugs.  It also uses the H-19
keypad for motion control but any keypad will work.

regards - george schreyer


========================================================================================
DOCUMENT :usus Folder:VOL12:analyze.text
========================================================================================

{ ANALYZE:  Analyze and summarize execution time performance measurements
            from an AUGMENTed Pascal program.

        PROGRAM HISTORY:

  S. Matwin and M. Missala, 1975:
    Polish Academy of Sciences Computer Centre, Pkin, Warsaw, Poland.
  
  Modified, Generalized, and Renamed by:
    A. B. Mickel and H. U. Rubenstein, 1977.
    University of Minnesota Computer Center, Minneapolis, MN 55455 USA.
    
  Published in Pascal News, No. 12., 1978 June.
  
  Overhauled for UCSD Pascal and interactive environment by:
    James L. Gagne, September, 1981.
    Datamed Research, Inc., 1433 Roscomare Road, Los Angeles, CA 90077 USA.
    JLG's changes from the PUG version are denoted with empty comment braces.
    
  Patched by George Schreyer,  lines changed noted by gws    Oct 1981
  
  The names and organizations given here must not be deleted in any use of
    this program. (Note added 9/81: this program is not known to be copyright.)
    
Internal documentation:
  
    Analyze reads two files.  Inter2 (UCSD filename is fixed: "AUG.PROCNAMES")
  is the file containing the "module" (procedure/function) names which are used
  when the results are sorted and written out (up to 10 characters only).
  Timing (UCSD filename: "TIMING.DAT") is the file containing the execution
  trace of the program being monitored.  Both files are expected to be on the
  default disk.
  
    Within ANALYZE, the procedure named processbody does the actual analysis
  by determining every time interval:
        time interval = time of exit - time of entry

    Gotoexits were handled specially in the PUG version.  These features have
  been removed from the UCSD version, but for now special provisions for
  the EXIT procedure have not been installed.
}

PROGRAM Analyze;

CONST   AlfaLeng = 10;
        MaxNames = 1000;

TYPE    Alfa = PACKED ARRAY [1..AlfaLeng] OF Char;
        TagRange = 0..MaxNames;
        Measurement = PACKED RECORD
                        Tag: TagRange;
                        Mark: (Entry, ExitP, GotoEntry);
                        HiTime, LoTime: integer
                      END;
{}      DblInt = RECORD
                   Hi, Lo: integer
                 END;
        Counter = RECORD
                    Count, SubRtnCount: integer;
                    Name: Alfa;
{}                  TimeSpent: DblInt
                  END;

VAR     MaxTag: TagRange;
{}      LastDot: char;
{}      JustOne, TotalCalls, TotalTime, StartingTime:  DblInt;
        ch: char;
        FudgeFactor, TimeOverhead: real;
        Modules:  ARRAY [TagRange] OF Counter;
        Timing:  FILE OF Measurement;
{}      OutFile: text;


PROCEDURE Sort(min, max: tagrange);
{Quicksort with bounded recursion depth, used to alphebatize module names.
 Requires min < max.}
VAR     low, high: integer;
        MidKey: Alfa;
        Temp: Counter;

BEGIN
  REPEAT        {pick split point}
    MidKey := Modules[(min + max) DIV 2].Name;  low := min;  high := max;
    REPEAT      {partition}
      WHILE Modules[low].Name < MidKey DO low := low + 1;
      WHILE Modules[high].Name > MidKey DO high := high - 1;
      IF low <= high
        THEN BEGIN
          Temp := Modules[low];  Modules[low] := Modules[high];
          Modules[high] := Temp;  low := low + 1;  high := high - 1
        END
    UNTIL low > high;
{recursively sort shorter sub-segment}
    IF high - min < max - low
      THEN BEGIN IF min < high THEN Sort(min,high);  min := low END
      ELSE BEGIN IF low < max THEN Sort(low,max);  max := high END
  UNTIL max <= min
END;


PROCEDURE ConvertTime(VAR i: DblInt);  {convert time to signed dbl int'rs}
BEGIN
  WITH i, Timing^ DO IF Tag > 0
    THEN BEGIN
      Hi := HiTime*2;  Lo := LoTime;
      IF ((HiTime > 0) AND (Hi < 0)) OR ((HiTime < 0) AND (Hi > 0))
        THEN Hi := Hi + 32767 + 1;           {throw away sign bit if a carry}
      IF (Hi < 0) AND (Lo > 0)
        THEN BEGIN Lo := Lo + 32767 + 1;  Hi := Hi - 1 END
      ELSE IF (Hi > 0) AND (Lo < 0)
        THEN BEGIN Lo := Lo + 32767 + 1;  Hi := Hi + 1 END
    END
END;


PROCEDURE AddDblInt(VAR i1, i2: DblInt);   {add i1 and i2; sum in i1}
VAR     Sum: DblInt;
BEGIN
  WITH Sum DO
    BEGIN
      Hi := i1.Hi + i2.Hi;  Lo := i1.Lo + i2.Lo;
      IF (i1.Hi > 0) AND (i2.Hi > 0) AND (Hi < 0)
        THEN Hi := Hi + 32767 + 1;
      IF (i1.Lo > 0) AND (i2.Lo > 0) AND (Lo < 0)
        THEN BEGIN Lo := Lo + 32765 + 3;  Hi := Hi + 1 END
    END;
  i1 := Sum;
END;


PROCEDURE SubDblInt(VAR i1, i2: DblInt);   {subtract i2 from i1; diffrnc in i1}
VAR     Diff: DblInt;
BEGIN
  WITH Diff DO
    BEGIN
      Hi := i1.Hi - i2.Hi;  Lo := i1.Lo - i2.Lo;
      IF (i1.Hi < 0) AND (i2.Hi < 0) AND (Hi > 0) THEN Hi := Hi + 32767 + 1;
      IF (i1.Lo < 0) AND (i2.Lo < 0) AND (Lo > 0)
        THEN BEGIN Lo := Lo + 32765 + 3;  Hi := Hi - 1 END
    END;
  i1 := Diff
END;

{
PROCEDURE WriteTime(i: DblInt; Stop: boolean);
VAR     r: real;
BEGIN
  WITH i DO
    BEGIN
      Write(Hi, '/', Lo, ' = ');  r := (Lo/60) + Hi * (32768.0/60);
      Write(r, '; ');  IF Stop THEN Readln
    END
END;
}

PROCEDURE ProcessBody;
{process timing file of dynamic measurements.}
VAR     ModuleTag: TagRange;
        SubCnt: integer;
        NoGoto, SameModule: boolean;
{}      Temp1, Temp2, ModulTime: DblInt;

BEGIN
   ModuleTag := Timing^.Tag;  SubCnt := 0;
{} WITH ModulTime DO BEGIN Hi := 0;  Lo := 0 END;
   ConvertTime(Temp1);  Get(Timing);
   WHILE (Timing^.Mark = entry) AND (Timing^.Tag > 0) AND NOT EOF(Timing) DO
     BEGIN
{}     ConvertTime(Temp2);  AddDblInt(ModulTime,Temp2);
{}     SubDblInt(ModulTime, Temp1);  ProcessBody;
{}     ConvertTime(Temp1);  SubCnt := SubCnt + 1;
{}     NoGoto := Timing^.Mark <> GotoEntry;
{}     SameModule := Timing^.Tag = ModuleTag;
{gws}  {IF SameModule OR NoGoto THEN} Get(timing);
     END;
{} ConvertTime(Temp2);  AddDblInt(ModulTime,Temp2);
{} SubDblInt(ModulTime, Temp1);  AddDblInt(TotalCalls,JustOne);
{} IF TotalCalls.Lo MOD 50 = 0 THEN Write('.');
{} IF TotalCalls.Lo MOD 2500 = 0 THEN Writeln;
   WITH Modules[ModuleTag] DO
     BEGIN
       Count := Count + 1;  AddDblInt(TimeSpent, ModulTime);
       SubRtnCount := SubRtnCount + SubCnt;
     END
END;


PROCEDURE Initialize;           {initialization placed here: JLG}
VAR     Tag: TagRange;
        i: integer;
        s: string;
        Inter2: FILE OF Alfa;
BEGIN
{} Writeln('Welcome to ANALYZE, the program timing analyzer.');  Writeln;
{} Writeln(
'     You should be using this program only after having run Pascal source');
{} Writeln(
'text through AUGMENT to add the time-keeping function, then compiled and run');
{} Writeln(
'the new program.  The data files AUG.PROCNAMES and TIMING.DAT must both be');
{} Writeln(
'the default disk, or the program will die.');  Writeln;
{} Reset(Inter2, 'AUG.PROCNAMES');  Reset(Timing,'TIMING.DAT');
  IF EOF(Timing)
{}  THEN BEGIN Writeln('*FATAL ERROR* timing file empty');  Exit(Program) END;
{} Writeln(
'Please enter the destination of the timing analysis (e.g., "PRINTER:"):');
{} Write('--> ':12);  Readln(s);
{} FOR i := 1 TO Length(s) DO
{}  IF s[i] IN ['a'..'z'] THEN s[i] := CHR(ORD(s[i]) + ORD('A') - ORD('a'));
{} IF POS('.TEXT',s) = 0 THEN s := CONCAT(s,'.TEXT');
  Rewrite(OutFile, s);  Tag := 1;
  WHILE NOT EOF(Inter2) DO
    BEGIN
      WITH Modules[Tag] DO
        BEGIN
          Name := Inter2^;  Get(Inter2);  Count := 0;  SubRtnCount := 0;
          TimeSpent.Hi := 0;  TimeSpent.Lo := 0
        END;
      Tag := Tag + 1
    END;
  MaxTag := Tag - 1;
  Writeln (MaxTag,' module names found.');  Writeln;
  Write('How many msec overhead per timing record write?  ');
  Readln(TimeOverhead);  Writeln;  FudgeFactor := TimeOverhead * 60.0 / 1000.0;
{} TotalCalls.Hi := 0;  TotalCalls.Lo := 0;
{} JustOne.Hi := 0;  JustOne.Lo := 1;  ConvertTime(StartingTime);
{} Writeln('Reading timing data (one dot = 100 entries):');
END;


PROCEDURE PrintResults;         {all output pulled into this procedure: JLG}
VAR     Tag: TagRange;
        i, j: integer;
{}      TotalT, TCalls, TSpent, PerCent: Real;
BEGIN
  Writeln(OutFile,'      Performance Measurement Summary for Pascal Program:  ',
                  Modules[1].Name);
  Writeln(OutFile);
  Writeln(OutFile,'execution time':62);
  Writeln(OutFile,'calls':27, '(msec)':21, '(sec)':9);
  Writeln(OutFile,'module':9, 'times':13, 'percent':11, 'subroutn':12, 
                  'average':14,'module':10, 'percent':11);
  Writeln(OutFile,'name':8, 'called':15, 'of total':11, 'calls':11,
                  'per call':15,'total':8, 'of total': 13);
  Writeln(OutFile,' ----------', '------':12, '--------':11,'------':11,
                  '--------':15, '------':9, '--------':12);
{} WITH TotalCalls DO TCalls := 1.0 + Lo - 1.0 + (32768.0 * Hi);
{} WITH TotalTime DO
     TotalT := (Lo/60.0) + Hi*(32768.0/60.0) - (FudgeFactor * 2.0 * TCalls);
{} IF TotalCalls.Lo + TotalCalls.Hi = 0
{}   THEN Writeln(OutFile,'Program did not execute; no timing data.')
{} ELSE FOR Tag := 1 TO MaxTag DO WITH Modules[Tag] DO
     BEGIN
{}     PerCent := (Count / TCalls) * 100.0;
{}     Write(OutFile,Name:11, Count:12);
{}     IF Count = 0
         THEN Write(Outfile,'-----':11, '-----':11)
         ELSE Write(Outfile, PerCent:11:3, SubRtnCount:11);
{}     WITH TimeSpent DO
         TSpent := (Lo/60.0) + (Hi/60.0)*32768.0
           - FudgeFactor * (1.0 + SubRtnCount);
{}     IF Count = 0
         THEN Writeln(OutFile,'-----':15, '-----':9, '-----':12)
{}       ELSE BEGIN
           Write(OutFile,((TSpent/Count)*1000.0):15:2,TSpent:9:3);
           IF TotalT = 0 THEN Writeln(OutFile,'-----':12)
{}           ELSE Writeln(OutFile,((TSpent / TotalT) *100.0):12:3)
         END
     END;
   Writeln(OutFile,' ==========', '======':12, '========':11, '======':11,
                   '========':15, '======':9, '========':12);
   Writeln(OutFile,'TOTALS':9, TCalls:14:1, '100.000':11,
{}                 ((TotalT/TCalls)*1000.0):26:2, TotalT:9:3, '100.000':12)
END;


BEGIN {program}
{} Initialize;  ProcessBody;
{} ConvertTime(TotalTime);  SubDblInt(TotalTime, StartingTime);
   IF MaxTag > 1
     THEN BEGIN
       Writeln(CHR(7));
       Write('Do you want your report alphabetized by procedure name (Y/N)?  ');
       REPEAT READ(ch) UNTIL (ch IN ['y','Y','n','N']);
       IF (ch IN ['y','Y']) THEN Sort(1, MaxTag)
     END;
  PrintResults;  Close(OutFile, LOCK);
END.


========================================================================================
DOCUMENT :usus Folder:VOL12:augment.text
========================================================================================

{AUGMENT - AUGMENT PASCAL PROGRAMS WITH CODE TO GATHER EXECUTION TIME
           PERFORMANCE MEASUREMENTS.

        PROGRAM HISTORY:

 S. MATWIN AND M. MISSALA, 1975
 POLISH ACADEMY OF SCIENCES COMPUTER CENTRE, PKIN, WARSAW, POLAND. 
 
 REFERENCE:
   "A SIMPLE MACHINE INDEPENDENT TOOL FOR OBTAINING ROUGH MEASURES OF PASCAL
   PROGRAMS."  SIGPLAN NOTICES, 1976 AUGUST, 42-45.
 
 MODIFIED, GENERALIZED, AND RENAMED FROM "PROFILE" TO "AUGMENT" BY:
   A. B. MICKEL AND H. U. RUBENSTEIN, 1977. 
   UNIVERSITY OF MINNESOTA COMPUTER CENTER, MINNEAPOLIS, MN 55455 USA.
 
 PUBLISHED IN PASCAL NEWS, NO. 12, 1978 JUNE.
 
 MODIFIED FOR UCSD PASCAL BY: JAMES GAGNE, 1981.
   DATAMED RESEARCH, INC., 1433 ROSCOMARE ROAD, LOS ANGELES, CA 90077, USA.
   MODIFICATIONS MARKED WITH EMPTY COMMENT SIGNS.
 
 THE NAMES AND ORGANIZATIONS GIVEN HERE MUST NOT BE DELETED IN ANY USE OF THIS
 PROGRAM.  
 [NOTE ADDED 26 SEPT 1981:
   THIS PROGRAM IS NOT KNOWN TO BEAR ANY FORM OF COPYRIGHT. JLG]
 
 futher modification to allow include files, units and lower case identifiers
 and EXIT (somewhat kludged) by George Schreyer. changes marked by "gws".
 
 corrections to gws modifications by Jim Gagne, 12 Nov 81; marked by "|" in
 empty comment brackets.}
 
 PROGRAM AUGMENT;
 
 CONST
        BeginSy = 1;
        CaseSy = 2;
        EndSy = 3;
        ExternSy = 4;
{gws}   ExitSy = 5;
        FortranSy = 6;
        ForwardSy = 7;
        FuncSy = 8;
        GotoSy = 9;
        LabelSy = 10;
        ProcSy = 11;
        ProgramSy = 12;
        VarSy = 13;
        MaxModules = 2000;
        LLMax = 120;                    {line length max}
        LLMin = 72;                     {line length min}
        AlfaLeng = 10;

TYPE
        Alfa = PACKED ARRAY [1..AlfaLeng] OF char;
        CodeType = (Entry, ExitP, GotoEntry, Declare);
        Symbols = BeginSy..VarSy;
        NameNode = RECORD
                     Name: Alfa;
                     Link: ^ NameNode
                   END;
        ModuleCnt = 0..MaxModules;
        LabelPtr = ^ LabelNode;
        LabelNode = RECORD
                      Labl: 0..9999;
                      DeclaredIn: ModuleCnt;
                      Next: LabelPtr
                    END;

VAR
        IdLen, LastIdLen: 0..AlfaLeng;  {identifier length}
        Sy: Symbols;
        Number: 0..9999;
{|}     {BadNames,}ReadingLabels, InEOLN, InEOF, Trace, WantsComments: boolean;
{gws}   WantsInclude,TempInclude : boolean;  {indicates reading include file}
        LineLength, ColCnt, InBuffPtr, IncBuffPtr,
          LastInBuff, LastIncBuff: integer;
        ch: char;
        BadList: ^ NameNode;            {list of excepted module names}
        Count: ModuleCnt;               {running count of modules}
{|}     DotCount: integer;              {count of dots marking lines read}
        ChBuf: ARRAY [1..AlfaLeng] OF char;
        Identifier: Alfa;
        TimeVolume: string[10];
        Key: ARRAY [Symbols] OF Alfa;
        InBuff, IncBuff: PACKED ARRAY [0..1023] OF char;
{}      Infile,                         {input file: source program}
{Note: all references to "Input" have been changed to "Infile".  JLG}
{gws}   Incfile: file;                  {Include file}
        Inter,                          {output file: augmented program}
        Except: text;                   {file of excepted module names}
        Inter2: FILE OF Alfa;           {file of all module names}

PROCEDURE WriteFatalError(message: string);      {procedure added: JLG}
BEGIN
  Writeln;  Writeln(CHR(7), '*FATAL ERROR* -- ', message, '.');  
  close(Inter,lock); {gws   so we can see what blew up}
EXIT(Program) END;


PROCEDURE NextCh;       {|} {rewritten using block i/o for more speed...jlg}
VAR     GoodRead: boolean;
BEGIN
  IF WantsInclude
    THEN BEGIN
      IF IncBuffPtr > LastIncBuff
        THEN BEGIN
          GoodRead := BlockRead(IncFile, IncBuff, 2) = 2;
          IF GoodRead
            THEN BEGIN
              LastIncBuff := 1023 + SCAN(-1023,<>CHR(0),IncBuff[1023]);
              IncBuffPtr := 0;  IF LastIncBuff < 1 THEN GoodRead := false;
            END;
          IF NOT GoodRead
            THEN BEGIN
              WantsInclude := false;  LastIncBuff := 1023;  Close(IncFile);
              IncBuffPtr := 1024;  DotCount := 0;
              Writeln;  Writeln('  --> back to source file');
            END
        END;
      IF WantsInclude
        THEN BEGIN
          ch := IncBuff[IncBuffPtr];  IncBuffPtr := IncBuffPtr + 1;
          IF ch <> CHR(13) THEN InEOLN := false
            ELSE BEGIN
              ch := ' ';  InEOLN := true;  ColCnt := 0;
              IF DotCount >= 0
                THEN BEGIN Write('.');  Dotcount := Dotcount + 1 END;
              IF DotCount > 50 THEN BEGIN Writeln;  Dotcount := 0 END
            END
        END
    END;
  IF NOT WantsInclude
    THEN BEGIN
      IF InBuffPtr > LastInBuff
        THEN IF BlockRead(InFile, InBuff, 2) <> 2 THEN InEOF := true
          ELSE BEGIN
            LastInBuff := 1023 + SCAN(-1023,<>CHR(0),InBuff[1023]);
            InBuffPtr := 0;  IF LastInBuff < 1 THEN InEOF := true;
          END;
      IF NOT InEOF
        THEN BEGIN
          ch := InBuff[InBuffPtr];  InBuffPtr := InBuffPtr + 1;
          IF ch <> CHR(13) THEN InEOLN := false
            ELSE BEGIN
              ch := ' ';  InEOLN := true;  ColCnt := 0;
              IF DotCount >= 0
                THEN BEGIN Write('.');  Dotcount := Dotcount + 1 END;
              IF DotCount > 50 THEN BEGIN Writeln;  Dotcount := 0 END
            END
        END
    END;
END;


PROCEDURE Advance;
BEGIN
  IF InEOLN
    THEN BEGIN
      Writeln(Inter);  NextCh;
      IF ch = CHR(16)
        THEN BEGIN
          NextCh;
          IF ch = ' ' THEN NextCh
          ELSE IF ch = '!' THEN ch := ' '
          ELSE BEGIN Write(Inter, CHR(16), pred(ch));  ch := ' ' END
        END
    END
    ELSE BEGIN Write(Inter, ch);  NextCh END
END;


PROCEDURE ReadId;
{}      VAR     i: integer;
BEGIN
  IdLen := 0;
  REPEAT
    IF IdLen < AlfaLeng THEN BEGIN IdLen := IdLen + 1;  ChBuf[IdLen] := ch END;
    NextCh
{} UNTIL NOT (ch IN ['0'..'9', 'A'..'Z', '_', 'a'..'z']);
  IF IdLen >= LastIdLen
    THEN LastIdLen := IdLen
    ELSE REPEAT ChBuf[LastIdLen] := ' ';  LastIdLen := LastIdLen - 1
         UNTIL LastIdLen = IdLen;
{} {PACK(chbuf, 1, Identifier;}
{gws} FOR i := 1 TO AlfaLeng DO IF ChBuf[i] in ['a'..'z'] THEN
   Identifier[i] := chr(ord(ChBuf[i]) - 32) ELSE Identifier[i] := ChBuf[i]
END;


PROCEDURE WriteId;
VAR     i: integer;
BEGIN
{} FOR i := 1 TO IdLen DO Write(Inter, ChBuf[i])
END;


PROCEDURE Comment;
BEGIN
{gws} REPEAT WHILE ch <> '*' DO Advance;  Advance UNTIL ch = ')';  Advance
END;


PROCEDURE StdComment;
BEGIN {gws} WHILE ch <> '}' DO Advance; Advance END;


PROCEDURE DumpComment;
BEGIN
  REPEAT
    WHILE ch <> '*' DO BEGIN IF ch = CHR(16) THEN NextCh;  NextCh END;  NextCh
  UNTIL ch = ')';
  Write(Inter,'*)');  NextCh
END;

PROCEDURE DumpStdComment;
BEGIN
  WHILE ch <> '}' DO BEGIN IF ch = CHR(16) THEN NextCh;  NextCh END;  Advance
END;

PROCEDURE GetInclude;  {procedure added: GWS}
  VAR i: integer;
      Message,IncName : string;
      Strg : string;
BEGIN
   IncName := '';
   Strg := ' ';
{|} WHILE (ch IN [' ','#',':', '0'..'9','.','A'..'Z','a'..'z'])
       AND (Length(IncName) < 80) DO
     BEGIN
       IF ch IN ['a'..'z'] THEN ch := CHR(ORD(ch) + ORD('A') - ORD('a'));
       IF ch <> ' ' THEN 
         BEGIN Strg[1] := ch;  IncName := concat(Incname,Strg) END;
       NextCh;
     END;
{$I-}
   Reset(Incfile,IncName);
{|} IF (IORESULT > 0) AND (POS('.TEXT',IncName) = 0)
     THEN Reset(IncFile, CONCAT(IncName, '.TEXT'));
   i := IORESULT;
   IF i = 0 THEN i := BlockRead(IncFile, IncBuff, 2, 0) - 2;
{$I+}
   IF i = 0
     THEN BEGIN Writeln;  Writeln('  --> ',IncName);  TempInclude := true END
   ELSE WriteFatalError(concat('Include File ',IncName,' not found'))
END;{-}


FUNCTION CheckDirective: boolean;  {procedure added: GWS; rewritten: JLG}
VAR     GotDirective: boolean;
BEGIN
   Advance;  GotDirective := false;
   IF ch = '+' THEN Trace := true
   ELSE IF ch = '-' THEN Trace := false
   ELSE IF ch = '$' THEN
     BEGIN
       NextCh;  GotDirective := true;
{|}    IF ch <> 'I' THEN Write(Inter,'$')
{|}      ELSE BEGIN
{|}        NextCh;  IF ch IN ['-','+'] THEN Write(Inter,'$I') ELSE GetInclude
         END
     END;
   CheckDirective := GotDirective
END;


FUNCTION SkipComments: boolean;  {function added: JLG}
VAR     Found: boolean;
BEGIN
  Found := true;
  IF ch = '(' THEN 
     BEGIN 
        Advance;
{|}     IF ch <> '*' THEN Found := false
          ELSE IF CheckDirective OR WantsComments THEN Comment ELSE DumpComment
     END
  ELSE IF ch = '{'
    THEN IF CheckDirective OR WantsComments THEN StdComment ELSE DumpStdComment
  ELSE Found := false;
  SkipComments := found; 
  IF TempInclude THEN  {block added: gws}
    BEGIN
      TempInclude := false;  Writeln(Inter);  WantsInclude := true;
      NextCh
    END;
END;


FUNCTION NoKey(Id: alfa): boolean;   {binary search}
VAR  i, j: integer;
BEGIN
  i := BeginSy;  j := VarSy;
  REPEAT
    Sy := (i + j) DIV 2;
    IF Key[Sy] <= Id THEN i := Sy + 1;  IF Key[Sy] >= Id THEN j := Sy - 1
  UNTIL i > j;
  NoKey := Key[Sy] <> Id
END;


PROCEDURE SkipOver;             {renamed: JLG}
{Find next identifier (or number if reading labels).  Skip strings & comments.}
{}
BEGIN
  WHILE NOT InEOF DO
    BEGIN
      WHILE NOT InEOLN DO
{}      IF SkipComments THEN {ignore}
        ELSE IF ch = ' ' THEN BEGIN IF Trace THEN Write(' ');  Advance END
{|}     ELSE IF ch = CHR(16) THEN BEGIN Advance;  Advance END
        ELSE IF ch = ''''
          THEN BEGIN
            REPEAT Advance UNTIL ch = ''''; Advance;  IF Trace THEN Write('''')
          END
{}      ELSE IF ch IN ['A'..'Z', 'a'..'z']
          THEN BEGIN
            ReadId;  ReadingLabels := false;  IF Trace THEN Write(Identifier);
{}          IF NoKey(Identifier){AND NOT BadNames}
{}{|}         THEN BEGIN IF Trace THEN Writeln;  WriteId END
  {|}         ELSE BEGIN IF Trace THEN Writeln('(',Sy,')');  Exit(SkipOver) END
          END
        ELSE IF ch IN ['0'..'9']
          THEN IF ReadingLabels
{|}         THEN BEGIN NextCh;  EXIT(SkipOver) END
            ELSE REPEAT Advance
{}               UNTIL NOT (ch IN ['0'..'9', 'A'..'Z', '_', 'a'..'z'])
        ELSE Advance;
      Writeln(Inter);  NextCh
    END
END;


PROCEDURE ComplModule(LastL: LabelPtr);
{ Process the block of a program, procedure, or function to find the
  appropriate code insertion points.  LastL is the head of the list of labels
  whose scope applies to the block.  ComplModule must parse label, var, proce-
  dure, and function declarations, as well as goto statements and the compound
  statement forming the statement part of each module. }

VAR     Depth: integer;
        Params: boolean;
        L: LabelPtr;
        GotoLabel: 0..9999;
        Looking: boolean;
        Tag: ModuleCnt;
        Name: Alfa;

  PROCEDURE InsertNewText(Code: CodeType; ITag: integer);
  BEGIN                                  {modified for UCSD Time functn}
    CASE Code OF
      Entry:  BEGIN
                Write(Inter, 'WITH Timing^ DO BEGIN xi:=', ITag, ';');
{}              Writeln(Inter, 'Time(xh,xl);xm:=0 END;Put(Timing);')
              END;
      ExitP:  BEGIN
                Writeln(Inter,';');
                Write(Inter, 'WITH Timing^ DO BEGIN xi:=', ITag, ';');
{}              Writeln(Inter, 'Time(xh,xl);xm:=1 END;Put(Timing);');
{}              IF ITag = 1 THEN Writeln(Inter, 'Close(Timing,lock);')
              END;
      GotoEntry:
              BEGIN
                Write(Inter, 'WITH Timing^ DO BEGIN xi:=',L^.DeclaredIn,';');
{}              Writeln(Inter, 'Time(xh,xl);xm:=2 END;Put(Timing);')
              END;
      Declare:BEGIN
                Write(Inter, 'Timing:FILE OF PACKED RECORD ');
{}              Writeln(Inter, 'xi:0..2000;xm:0..2;xh,xl:integer END;');
{}              Writeln(Inter)
              END
      END
  END;


  FUNCTION NameOK: Boolean;
  { Check procedure or function name against list of names to be excluded.}
  
  VAR     n: ^NameNode;
          Looking: boolean;
  BEGIN
    n := BadList;  Looking := true;
    WHILE (n <> nil) AND Looking DO
      BEGIN Looking := n^.Name <> Name;  n := n^.Link END;
    NameOK := Looking
  END;


BEGIN {ComplModule}
{} WHILE NOT (ch IN ['A'..'Z','a'..'z']) DO IF NOT SkipComments THEN Advance;
   ReadId;  Name := Identifier;  WriteId;  Tag := Count;  Params := false;
   WHILE NOT Params AND (ch <> ';') DO IF ch = '('
     THEN BEGIN Advance;  IF ch = '*' THEN Comment ELSE Params := true END
     ELSE IF ch = '{' THEN StdComment ELSE Advance;
   IF Params THEN WHILE ch <> ')' DO        {read through parameter list)
{}   IF NOT SkipComments THEN Advance;
{} Write(Inter, ch);  NextCh;  SkipOver;  IF Trace THEN Write('!');
   IF Sy IN [ForwardSy, ExternSy, FortranSy] THEN WriteId
   ELSE BEGIN
     Count := Count + 1;
     IF Count = MaxModules
{}     THEN WriteFatalError('Too many procedures/functions to process');
{}   Inter2^ := Name;  Put(Inter2);
     IF Sy = LabelSy     {label declaration}
       THEN BEGIN        {read local labels}
         WriteId;  ReadingLabels := true;  SkipOver;
         REPEAT
           New(L);  L^.Labl := Number;  L^.DeclaredIn := Tag;
           Write(Inter, Number:4);  L^.Next := LastL;  LastL := L;  SkipOver
         UNTIL NOT ReadingLabels
       END;
     WHILE Sy IN [CaseSy, EndSy] DO      {type declaration}
       BEGIN WriteId;  SkipOver END;
     IF NOT (Sy IN [BeginSy, FuncSy, ProcSy]) THEN WriteId;
     IF Sy = VarSy
       THEN BEGIN
         SkipOver;  WHILE Sy IN [CaseSy, EndSy] DO BEGIN WriteId;  SkipOver END;
       END;
     IF Tag = 1 THEN InsertNewText(Declare,1);    {main program}
     WHILE Sy IN [FuncSy, ProcSy] DO
       BEGIN WriteId;  ComplModule(LastL) END;
     IF Sy = BeginSy                     {statement part}
       THEN BEGIN
         Depth := 1;  WriteID;  Writeln;  Write(Name,' <',Tag:4,' >');
{|}      DotCount := 0;
         IF Tag = 1
           THEN Writeln(Inter,' rewrite(Timing,''',TimeVolume,'TIMING.DAT'');')
           ELSE Writeln(Inter);
         IF NameOK THEN InsertNewText(Entry, Tag)
       END
{}   ELSE WriteFatalError('"BEGIN" expected');
     REPEAT                      {look for last EndSy}
       SkipOver;
       IF Sy = GotoSy
         THEN BEGIN              {check against local labels}
           ReadingLabels := true;  SkipOver;  GotoLabel := Number;
           ReadingLabels := false;  Looking := true;  L := LastL;
           WHILE (L <> nil) AND Looking DO
             IF L^.Labl = GotoLabel THEN Looking := false ELSE L := L^.Next;
{}         IF Looking THEN {WriteFatalError('undeclared label')}
           ELSE BEGIN      {modified for local labels only per UCSD: JLG}
{}         (* IF L^.DeclaredIn <> Tag
{}             THEN BEGIN                {exit goto}
{}               Writeln(Inter, 'BEGIN');
{}               IF NameOK THEN InsertNewText(GotoEntry,Tag)
{}             END;  *)
            Write(Inter, 'GOTO ', GotoLabel);
{}         { IF L^.DeclaredIn <> Tag THEN Writeln(Inter, ' END') }
           END
         END
{gws}  ELSE IF Sy = ExitSy
{gws}    THEN BEGIN
{|}        Write(Inter,' BEGIN ');  InsertNewText(ExitP,Tag);
{|}        REPEAT IF ch = CHR(16) THEN BEGIN NextCh;  NextCh END;  NextCh
{gws}      UNTIL NOT (ch IN ['(',' ']);  ReadId;
{gws}      IF NOT NoKey (Identifier) THEN
{|}          BEGIN  IF Sy = ProgramSy THEN
{gws}          BEGIN
{|}              InsertNewText(ExitP,1);  Writeln(Inter,'EXIT(PROGRAM)')
{gws}          END
{|}          END
{gws}        ELSE Writeln(Inter,'EXIT(',Identifier,')');
{gws}      Write(Inter,'END;');  NextCh;
{gws}    END
        ELSE IF Sy IN [BeginSy, CaseSy]
          THEN BEGIN
            Depth := Depth + 1;  WriteId;
            IF Trace THEN Write(Inter,'{',Depth,'}')
          END
        ELSE If Sy = EndSy
          THEN BEGIN
            Depth := Depth - 1;
            IF Depth <> 0
              THEN BEGIN WriteId;  IF Trace THEN Write(Inter,'{',Depth,'}') END
          END
{}      ELSE WriteFatalError('"END" expected')
     UNTIL Depth = 0;
     IF NameOK THEN InsertNewText(ExitP,Tag);
     Write(Inter, 'END');  IF Trace THEN Write(Inter,' {p/f}');
   END;
   SkipOver
END;


PROCEDURE Initialize;                   {all init moved here: JLG}


  FUNCTION Yes(prompt: string): boolean;   {added: JLG}
  VAR   ch: char;
  BEGIN
    Write(prompt, ' (Y/N)?  ');
    REPEAT Read(keyboard, ch) UNTIL ch IN ['y','Y','n','N'];
    IF ch IN ['y', 'Y'] THEN BEGIN Yes := true;  Writeln('Yes') END
    ELSE BEGIN Yes := false;  Writeln('No') END
  END;
  
  
  PROCEDURE AllCaps(VAR s: string);     {added: JLG}
  VAR   i: integer;
  BEGIN
    FOR i := 1 TO Length(s) DO IF s[i] IN ['a'..'z']
      THEN s[i] := CHR(ORD(s[i]) + ORD('A') - ORD('a'))
  END;


  FUNCTION GotFile(WantsInput: boolean;  prompt: string; VAR f: text): boolean;
  VAR   i: integer;                     {function added: JLG}
        s: string;
  BEGIN
    REPEAT
      Writeln('Please enter the name of ', prompt, ' (<ret> to skip):');
      Write('--> ':12);  Readln(s);  Allcaps(s);
      IF (s = '') OR (s = ' ') THEN s := ''
      ELSE IF WantsInput
        THEN BEGIN
{$I-}
          Reset(f,s);  i := IORESULT;
          IF (i > 0) AND (POS('.TEXT',s) = 0)
            THEN BEGIN
              s := CONCAT(s, '.TEXT');  Reset(f,s);  i := IORESULT
            END;
          IF i > 0 THEN BEGIN Reset(f, CONCAT('#5:',s));  i := IORESULT END;
          IF i > 0 THEN BEGIN Reset(f, CONCAT('#4:',s));  i := IORESULT END;
{$I+}
          IF i > 0
            THEN BEGIN s := '';  Write(CHR(7),'Can''t open input file...') END
        END
        ELSE BEGIN
{$I-}
          IF POS('.TEXT',s) = 0 THEN s := CONCAT(s, '.TEXT');
          Rewrite(f,s);  i := IORESULT;
{$I+}
          IF i > 0
            THEN BEGIN s := '';  Write(CHR(7),'Can''t open output file...') END
        END
    UNTIL (s = '') OR (i = 0);  GotFile := i = 0
  END;
  
  
  PROCEDURE GetBadNames;                {added: JLG}
  VAR   n: ^ NameNode;
        s: string;
          
  
    PROCEDURE PutName;                  {added: JLG}
    VAR i: integer;
    BEGIN
      IF (s <> '') AND (s <> ' ')
      THEN BEGIN
        New(n);
        FOR i := 1 TO AlfaLeng DO
          IF i > Length(s) THEN n^.Name[i] := ' ' ELSE n^.Name[i] := s[i];
        n^.Link := BadList;  BadList := n
      END
    END;
      
  
    PROCEDURE ReadBadNames;             {moved & rewritten: JLG}
    VAR   i: 1..AlfaLeng;
    BEGIN
      IF GotFile(true, 'the "exceptions" file', except)
        THEN BEGIN
          Writeln(
          'The following names will not be AUGMENTed with timing information:');
          Writeln;
          WHILE NOT EOF(except) DO
            BEGIN Readln(except, s);  Writeln(s:25);  PutName END
        END
    END;
  
  
  BEGIN
    BadList := nil;
    IF Yes('Do you wish to enter procedures/function names NOT to process')
      THEN IF Yes('Are these names in a disk-based file (1 per line)')
        THEN ReadBadNames
        ELSE BEGIN
          Writeln(
     'If you wish to skip over certain procedures or functions now,');
          Writeln(
           'Enter the one such procedure/function name per line (no blanks);');
          Writeln('Enter a blank line (ie, just type <ret>) when done:');
          REPEAT Write(' ':16);  Readln(s);  PutName
          UNTIL (s = '') OR (s = ' ')
        END
  END;


BEGIN {Initialize}
  IF NOT GotFile(true, 'the source file to be processed', Infile)
    THEN EXIT(Program);
  IF BlockRead(InFile, InBuff, 2) <> 2
    THEN WriteFatalError('can''t read source file');
  IF NOT GotFile(False, 'the destination of the Pascal source', Inter)
    THEN EXIT(Program);
{$I-}
  Rewrite(Inter2, 'AUG.PROCNAMES');
  IF IORESULT > 0 THEN Rewrite(Inter2, '#5:AUG.PROCNAMES');
  IF IORESULT > 0 THEN WriteFatalError('can''t open procedure name file');
{$I+}
{|} Writeln(
'To which volume do you wish to direct the timing file (<ret> for Prefix)?');
{|} Write('--> ':12);  Readln(TimeVolume);
{|} WantsComments := Yes('Want to keep ALL comments in AUGMENTed file');
{|} WHILE POS(' ', TimeVolume) > 0 DO DELETE(TimeVolume,POS(' ',TimeVolume),1);
{|} TempInclude := false;  WantsInclude := false;  {gws}
{|} InEOLN := false;  InEOF := false;  InBuffPtr := 1024;  LastInBuff := 1023;
{|} IncBuffPtr := 1024;  LastIncBuff := 1023;  DotCount := -1;
{|} NextCh;  Count := 1;  ColCnt := 1;  LineLength := LLMax;
{|} Trace := Yes('Want to trace AUGMENT''s scanner');
  LastIdLen := AlfaLeng;
  Key[BeginSy  ] := 'BEGIN     ';  Key[CaseSy   ] := 'CASE      ';
  Key[EndSy    ] := 'END       ';  Key[ExitSy   ] := 'EXIT      ';
  Key[ExternSy ] := 'EXTERNAL  ';
  Key[FortranSy] := 'FORTRAN   ';  Key[ForwardSy] := 'FORWARD   ';
  Key[FuncSy   ] := 'FUNCTION  ';  Key[GotoSy   ] := 'GOTO      ';
  Key[LabelSy  ] := 'LABEL     ';  Key[ProcSy   ] := 'PROCEDURE ';
  Key[ProgramSy] := 'PROGRAM   ';  Key[VarSy    ] := 'VAR       ';
  GetBadNames;  SkipOver;  ReadingLabels := false;  Writeln;
END;


PROCEDURE DoAugment;
BEGIN {DoAugment}
  Initialize;
  IF Sy = ProgramSy THEN BEGIN Write(Inter, 'PROGRAM');  ComplModule(nil) END
  ELSE WriteFatalError('"PROGRAM" expected')
END;


BEGIN {program}
  DoAugment;  Writeln;  Writeln;  Writeln('Process complete.');
  Close(Inter, lock);  Close(Inter2, lock)
END.


========================================================================================
DOCUMENT :usus Folder:VOL12:bench.byte.text
========================================================================================

{ L PRINTER:}
{$R-}
(* BYTE Benchmark - see issue Sept '81 for data on other machines/languages*)

(* Eratosthenes Sieve Prime Number Program in (UCSD) PASCAL *)

(*     With obvious UCSD optimisations, 
       eg make the main computation a procedure to get SSTLs,
          turn range checking off  *)

(*     Making such changes to a benchmark is clearly not in the spirit of
       comparative testing.  However, the changes shown do serve to show
       how you might speed up your own programs - or teach you to beware
       of benchmarks!!
       
       USUS(UK) Library Reviewer   *)

PROGRAM benchbyte;

CONST
  size = 8190;
  
VAR
  flags : ARRAY [0..size] OF BOOLEAN;
  
PROCEDURE do_it;

  VAR
    i,prime,k,count,iter : INTEGER;
  
  BEGIN
    WRITELN('10 iterations');
    FOR iter := 1 TO 10 DO BEGIN
      count := 0;
      FILLCHAR(flags,SIZEOF(flags),CHR(ORD(TRUE)));
      FOR i := 0 TO size DO
        IF flags[i] THEN BEGIN
          prime := i+i+3;
          k := i + prime;
          WHILE k <= size DO BEGIN
            flags[k] := FALSE;
            k := k + prime;
          END;
          count := count + 1;
        WRITELN(prime);
        END;
      END;
    WRITELN(count,' primes');
  END;

BEGIN
  do_it;
END.


========================================================================================
DOCUMENT :usus Folder:VOL12:bench.pcw.text
========================================================================================

  {$R-}
  program benchpcw;
  (* Personal Computer World Pascal Benchmark
  
     self timed version *)
  
  const num_loops = 10000;
  
  var
    j : integer;
    starth,startl,endh,endl : integer;
      
  procedure doneit;
  var t,s,e : real;
  begin
    s:=ABS(startl);
    e:=ABS(endl);
    t:=ABS(e-s)/60;
    writeln(': ',t:4,' seconds');
  end;
    
  procedure magnifier;
  var k : integer;
  begin
    write('Magnifier     ');
    time(starth,startl);
    for k := 1 to num_loops do ;
    time(endh,endl);
    doneit;
  end;

  procedure forloop;
  var j,k : integer;
  begin
    write('Forloop       ');
    time(starth,startl);
    for k := 1 to num_loops do
      for j := 1 to 10 do;
    time(endh,endl);
    doneit;
  end;

  procedure whileloop;
  var j,k : integer;
  begin
    write('Whileloop     ');
    time(starth,startl);
    for k := 1 to num_loops do
    begin
      j := 1;
      while j <= 10 do j:=j+1
    end;
    time(endh,endl);
    doneit;
  end;

  procedure repeatloop;
  var j,k : integer;
  begin
    write('Repeatloop    ');
    time(starth,startl);
    for k := 1 to num_loops do
    begin
      j := 1;
      repeat
        j:=j+1
      until j > 10;
    end;
    time(endh,endl);
    doneit;
  end;
  
  procedure literalassign;
  var j,k,l : integer;
  begin
    write('Literalassign ');
    time(starth,startl);
    for k := 1 to num_loops do
      for j := 1 to 10 do l:=0;
    time(endh,endl);
    doneit;
  end;
  
  procedure memoryaccess;
  var j,k,l : integer;
  begin
    write('Memoryaccess  ');
    time(starth,startl);
    for k := 1 to num_loops do
      for j := 1 to 10 do l:=j;
    time(endh,endl);
    doneit;
  end;
  
  procedure realarithmetic;
  var k : integer;
      x : real;
  begin
    write('Realarithmetic');
    time(starth,startl);
    for k := 1 to num_loops do
      x := k/2*3+4-5;
    time(endh,endl);
    doneit;
  end;
  
  procedure realalgebra;
  var k : integer;
      x : real;
  begin
    write('Realalgebra   ');
    time(starth,startl);
    for k := 1 to num_loops do
      x := k/k*k+k-k;
    time(endh,endl);
    doneit;
  end;

  procedure vector;
  var k,j : integer;
      matrix : array [0..10] of integer;
  begin
    write('Vector        ');
    time(starth,startl);
    matrix[0] := 1;
    for k := 1 to num_loops do
      for j := 1 to 10 do
        matrix[j] := matrix[j-1];
    time(endh,endl);
    doneit;
  end;

  procedure equalif;
  var j,k,l : integer;
  begin
    write('Equalif       ');
    time(starth,startl);
    for k := 1 to 10000 do
      for j := 1 to 10 do
        if j < 6 then l := 1
                 else l := 0;
    time(endh,endl);
    doneit;
  end;

  procedure unequalif;
  var j,k,l : integer;
  begin
    write('Unequalif     ');
    time(starth,startl);
    for k := 1 to 10000 do
      for j := 1 to 10 do
        if j < 2 then l := 1
                 else l := 0;
    time(endh,endl);
    doneit;
  end;
  
    procedure none5;
    begin
      j := 1
    end;
    procedure none4;
    begin
      none5
    end;
    procedure none3;
    begin
      none4
    end;
    procedure none2;
    begin
      none3
    end;
    procedure none1;
    begin
      none2
    end;

  procedure noparameters;
  var j,k : integer;
  begin
    write('Noparameters  ');
    j := 0;
    for k := 1 to num_loops do
      none1;
    time(endh,endl);
    doneit;
  end;

    procedure value5 (i : integer);
    begin
      i := 1
    end;
    procedure value4 (i : integer);
    begin
      value5(i)
    end;
    procedure value3 (i : integer);
    begin
      value4(i)
    end;
    procedure value2 (i : integer);
    begin
      value3(i)
    end;
    procedure value1 (i : integer);
    begin
      value2(i)
    end;
  
  procedure value;
  var j,k : integer;
  begin
    write('Value         ');
    j := 0;
    for k := 1 to num_loops do
      value1(j);
    time(endh,endl);
    doneit;
  end;

    procedure refer5 ( var i : integer);
    begin
      i := 1
    end;
    procedure refer4 ( var i : integer);
    begin
      refer5(i)
    end;
    procedure refer3 ( var i : integer);
    begin
      refer4(i)
    end;
    procedure refer2 ( var i : integer);
    begin
      refer3(i)
    end;
    procedure refer1 ( var i : integer);
    begin
      refer2(i)
    end;
  
  procedure reference;
  var j,k : integer;
  begin
    write('Reference     ');
    j := 0;
    for k := 1 to num_loops do
      refer1(j);
    time(endh,endl);
    doneit;
  end;

  procedure maths;
  var k : integer;
      x,y : real;
  begin
    write('Maths         ');
    time(starth,startl);
    for k := 1 to num_loops do
    begin
      x := sin(k);
      y := exp(x);
    end;
    time(endh,endl);
    doneit;
  end;

  begin
    writeln;
    writeln;
    writeln;
    magnifier;
    forloop;
    whileloop;
    repeatloop;
    literalassign;
    memoryaccess;
    realarithmetic;
    realalgebra;
    vector;
    equalif;
    unequalif;
    noparameters;
    value;
    reference;
    maths;
  end.

========================================================================================
DOCUMENT :usus Folder:VOL12:bench.swap.text
========================================================================================

PROGRAM benchswap;

(* Process swap benchmark - a VAX does >6000 swaps/sec *)

CONST nswap           =10000;
        
VAR sem1,sem2,main : SEMAPHORE;
    c : CHAR;
    pid : PROCESSID;
    t11,t12,t21,t22 : INTEGER;

PROCESS one;
VAR i : INTEGER;
BEGIN
  FOR i := 1 TO nswap DIV 2 DO BEGIN
    SIGNAL(sem2);
    WAIT(sem1);
  END;
  SIGNAL(main);
END;
  
PROCESS two;
VAR i : INTEGER;
BEGIN
  FOR i := 1 TO nswap DIV 2 DO BEGIN
    SIGNAL(sem1);
    WAIT(sem2);
  END;
  SIGNAL(main);
END;
  
BEGIN

  WRITELN('Type <space> to go');
  READ(c);
  
  TIME(t11,t12);
  SEMINIT(sem1,0);
  SEMINIT(sem2,0);
  SEMINIT(main,0);
  START(one,pid);
  START(two,pid);
  WAIT(main);
  WAIT(main);
  TIME(t21,t22);
  
  WRITELN('Done');
  t22:=t22-t12;
  IF t22 > 0 THEN
     WRITELN((t22+30)DIV 60 ,' seconds ',ROUND((60/t22)*nswap),' swaps/sec');
  
END.


========================================================================================
DOCUMENT :usus Folder:VOL12:bench.usus.text
========================================================================================

  program benchusus;
  (* Self timed version of Jon Bondy's benchmark
     See USUS News *)
  
  type
    rec2_type = record
      next : ^rec2_type;
      end;
  var
    num_loops : integer;
    i,j,k,l, test : integer;
    r,s,t : real;
    starth,startl,endh,endl : integer;
    a : array[1..100] of integer;
    b : array[1..100] of real;
    ch : char;
    rec1 : record
        firsti, secondi : integer;
        firstr, secondr : real;
      end;
    root, ptr : ^rec2_type;
    cset : set of char;
    (* printr : interactive; *)
    
    procedure prompt;
      procedure prompt1; { too big for 1200 bytes otherwise... }
        var line:integer;
        begin
        gotoxy(0,23);
        for line:=1 to 24 do writeln;
        gotoxy(0,0);
        writeln('Select a test or enter "0" for all tests.');
        writeln('Enter a negative number to quit.');
        writeln;
        end;
      begin
      prompt1;
      writeln(' 1. null for loops (to).           2. null for loops (downto).');
      writeln(' 3. integer increments (for loop). 4. null while loops.');
      writeln(' 5. null repeat loops.             6. integer adds.');
      writeln(' 7. integer multiplys.             8. integer divides.');
      writeln(' 9. real increments.              10. real adds.');
      writeln('11. real multiplies.              12. real divides.');
      writeln('13. integer transfers.            14. integer array transfers.');
      writeln('15. real transfers.               16. real array transfers.');
      writeln('17. integer record transfers.     18. real record transfers.');
      writeln('19. integer if comparisons.       20. real if comparisons.');
      writeln('21. case statements.              22. procedure calls.');
      writeln('23. proc calls with integer param.24. proc calls with real param.');
      writeln('25. proc calls with a local var.  26. set unions.');
      writeln('27. set differences.              28. set IN''s.');
      writeln('29. pointer transfers.            30. NOOP''s.');
      write('Test:');
      end; { prompt }
      
  procedure doneit;
  
  var t,s,e : real;
  
  begin
    writeln('Done.');
    s:=ABS(startl);
    e:=ABS(endl);
    t:=ABS(e-s)/60;
    writeln('Time = ',t:4,' seconds');
    (*writeln(printr,t);*)
  end;

  procedure dummy1;
    begin
    end;
    
  procedure dummy2(i : integer);
    begin
    end;
    
  procedure dummy3(r: real);
    begin
    end;
  
  procedure dummy4;
    var
      i : integer;
    begin
    end;
    
  procedure test1;
    begin
    write('1 . ',numloops,' null for loops (to).');
    time(starth,startl);
    for i := 1 to num_loops do begin end;
    time(endh,endl);
    doneit;
    end;
   
  procedure test2;
    begin
    write('2.  ',numloops,
      ' null for loops (downto).');
    time(starth,startl);
    for i := num_loops downto 1 do begin end;
    time(endh,endl);
    doneit;
    end;
   
  procedure test3;
    begin
    write('3.  ',numloops,
      ' integer increments (for loop).');
    time(starth,startl);
    for i := 1 to num_loops do begin j := j + 1; end;
    time(endh,endl);
    doneit;
    end;
   
  procedure test4;
    begin
    write('4.  ',numloops,' null while loops.');
    j := 0;
    time(starth,startl);
    while (j < num_loops) do begin j := j + 1; end;
    time(endh,endl);
    doneit;
    end;
   
  procedure test5;
    begin
    write('5.  ',numloops,' null repeat loops.');
    j := 0;
    time(starth,startl);
    repeat j := j + 1 until (j = num_loops);
    time(endh,endl);
    doneit;
    end;
   
  procedure test6;
    begin
    write('6.  ',numloops,' integer adds.');
    time(starth,startl);
    for i := 1 to num_loops do begin j := j + k; end;
    time(endh,endl);
    doneit;
    end;
   
  procedure test7;
    begin
    write('7.  ',numloops,' integer multiplys.');
    time(starth,startl);
    for i := 1 to num_loops do begin j := k * l; end;
    time(endh,endl);
    doneit;
    end;
  
  procedure test8;
    begin
    write('8.  ',numloops,' integer divides.');
    time(starth,startl);
    for i := 1 to num_loops do begin j := k div l; end;
    time(endh,endl);
    doneit;
    end;
   
  procedure test9;
    begin
    write('9.  ',numloops,' real increments.');
    time(starth,startl);
    for i := 1 to num_loops do begin r := r + 1.0 end;
    time(endh,endl);
    doneit;
    end;
   
  procedure test10;
    begin
    write('10.  ',numloops,' real adds.');
    time(starth,startl);
    for i := 1 to num_loops do begin r := r + s; end;
    time(endh,endl);
    doneit;
    end;
   
  procedure test11;
    begin
    write('11.  ',numloops,' real multiplies.');
    time(starth,startl);
    for i := 1 to num_loops do begin r := s * t; end;
    time(endh,endl);
    doneit;
    end;
   
  procedure test12;
    begin
    write('12.  ',numloops,' real divides.');
    time(starth,startl);
    for i := 1 to num_loops do begin r := s / t; end;
    time(endh,endl);
    doneit;
    end;
   
  procedure test13;
    begin
    write('13.  ',numloops,' integer transfers.');
    time(starth,startl);
    for i := 1 to num_loops do begin j := k; end;
    time(endh,endl);
    doneit;
    end;
   
  procedure test14;
    begin
    j := 5; k := 12;
    write('14.  ',numloops,
      ' integer array transfers.');
    time(starth,startl);
    for i := 1 to num_loops do begin a[j] := a[k]; end;
    time(endh,endl);
    doneit;
    end;
   
  procedure test15;
    begin
    write('15.  ',numloops,' real transfers.');
    time(starth,startl);
    for i := 1 to num_loops do begin r := s; end;
    time(endh,endl);
    doneit;
    end;
   
  procedure test16;
    begin
    j := 5; k := 12;
    write('16.  ',numloops,' real array transfers.');
    time(starth,startl);
    for i := 1 to num_loops do begin b[j] := b[k]; end;
    time(endh,endl);
    doneit;
    end;
   
  procedure test17;
    begin
    write('17.  ',numloops,
      ' integer record transfers.');
    time(starth,startl);
    for i := 1 to num_loops do begin rec1.firsti := rec1.secondi; end;
    time(endh,endl);
    doneit;
    end;
   
  procedure test18;
    begin
    write('18.  ',numloops,
      ' real record transfers.');
    time(starth,startl);
    for i := 1 to num_loops do begin rec1.firstr := rec1.secondr; end;
    time(endh,endl);
    doneit;
    end;
   
  procedure test19;
    begin
    j := 5; k := 12;
    write('19.  ',numloops,
      ' integer if comparisons.');
    time(starth,startl);
    for i := 1 to num_loops do if (j < k) then begin end;
    time(endh,endl);
    doneit;
    end;
   
  procedure test20;
    begin
    r := 5.0; s := 12.0;
    write('20.  ',numloops,' real if comparisons.');
    time(starth,startl);
    for i := 1 to num_loops do if (r < s) then begin end;
    time(endh,endl);
    doneit;
    end;
   
  procedure test21;
    begin
    j := 2;
    write('21.  ',numloops,' case statements.');
    time(starth,startl);
    for i := 1 to num_loops do
      case j of
        1 : begin end;
        2 : begin end;
        3 : begin end;
        4 : begin end;
        end;
    time(endh,endl);
    doneit;
    end;
   
  procedure test22;
    begin
    write('22.  ',numloops,' procedure calls.');
    time(starth,startl);
    for i := 1 to num_loops do dummy1;
    time(endh,endl);
    doneit;
    end;
   
  procedure test23;
    begin
    write('23.  ',numloops,
      ' procedure calls with integer parameter.');
    time(starth,startl);
    for i := 1 to num_loops do dummy2(i);
    time(endh,endl);
    doneit;
    end;
   
  procedure test24;
    begin
    write('24.  ',numloops,
      ' procedure calls with real parameter.');
    time(starth,startl);
    for i := 1 to num_loops do dummy3(r);
    time(endh,endl);
    doneit;
    end;
   
  procedure test25;
    begin
    write('25.  ',numloops,
      ' procedure calls with a local variable.');
    time(starth,startl);
    for i := 1 to num_loops do dummy4;
    time(endh,endl);
    doneit;
    end;
   
  procedure test26;
    begin
    write('26.  ',numloops,' set unions.');
    time(starth,startl);
    for i := 1 to num_loops do cset := cset + ['a','b'];
    time(endh,endl);
    doneit;
    end;

  procedure test27;
    begin
    write('27.  ',numloops,' set differences.');
    time(starth,startl);
    for i := 1 to num_loops do cset := cset - ['a','b'];
    time(endh,endl);
    doneit;
    end;
   
  procedure test28;
    begin
    write('28.  ',numloops,' set IN''s.');
    time(starth,startl);
    for i := 1 to num_loops do if (ch in cset) then begin end;
    time(endh,endl);
    doneit;
    end;
   
  procedure test29;
    begin
    new(root); { create a loop of list elements }
    new(root^.next);
    root^.next^.next := root;
    ptr := root;
    write('29.  ',numloops,' pointer transfers.');
    time(starth,startl);
    for i := 1 to num_loops do ptr := ptr^.next;
    time(endh,endl);
    doneit;
    end;
   
  procedure test30;
    begin
    write('30. ',numloops,' NOOP''s.');
    time(starth,startl);
    for i := 1 to num_loops do begin
      pmachine(156);
    end;
    time(endh,endl);
    doneit;
    end;
   
  begin { main }
   
  j := 100; k := 200; l := 300; r := 400; s := 500; t := 600;
  (*rewrite(printr,'printer:');*)
  write('Enter number of loops per test : ');
  readln(num_loops);
  
  repeat
    prompt; write('Enter test number : ');
    readln(test);
    if (test >= 0) then 
      case test of
        0 : begin
            test1; test2; test3; test4; test5; test6; test7; test8;
            test9; test10; test11; test12; test13; test14; test15;
            test16; test17; test18; test19; test20; test21; test22;
            test23; test24; test25; test26; test27; test28; test29;
            test30; end;
        1 : test1; 2 : test2; 3 : test3; 4 : test4;
        5 : test5; 6 : test6; 7 : test7; 8 : test8;
        9 : test9; 10 : test10; 11 : test11; 12 : test12;
        13 : test13; 14 : test14; 15 : test15; 16 : test16;
        17 : test17; 18 : test18; 19 : test19; 20 : test20;
        21 : test21; 22 : test22; 23 : test23; 24 : test24;
        25 : test25; 26 : test26; 27 : test27; 28 : test28;
        29 : test29; 30 : test30;
        end;
        if test>=0 then
          begin
            write('Type <return> to continue');
            readln;
          end;
    until (test < 0);
  end.

========================================================================================
DOCUMENT :usus Folder:VOL12:contents.text
========================================================================================

USUS(UK) SOFTWARE LIBRARY VOLUME 2                     23rd March 1982

Material submitted to the USUS(UK) Software Libary by Austin Tate, ERCC
25-Feb-82
-----------------------------------------------------------------------

Most of the material on this disk uses UCSD version IV.0 facilities
such as COMMANDIO, SCREENOPS and segments procedures in Units and won't work 
under II.0.

The files on this disk are as follows:-

Window Manager
--------------

WINDOWS.TEXT            The main file for the Window Manager Unit.
W.IMPLN.TEXT            The implementation part of the Unit.
W.SEGS.TEXT             The segment procedures for the Unit.
W.IO.TEXT               The I/O routines in the implementation of the Unit.

WFILER.TEXT             A simple Filer utility using window management.
                        This can act as a demonstration and source of ideas.

W.DOC.TEXT              A short paper about the window manager and WFiler.

OffLoad Office Workstation
--------------------------

The individual utilities in OffLoad are not present on the disk as they
are copyrighted by others.  However, the command interpreter and other
files may help to construct a suitable system for your own environment.
Other utilities may be obtained from the USUS Software Library and
commercial sources.

OFF.START.TEXT          The *SYSTEM.STARTUP program
OFFLOAD.TEXT            The command interpreter --> *OFFLOAD.CODE
OFF.INFO.TEXT           The information file for the workstation

MAKE.PAGE.TEXT          A trivial program to create NEW.PAGE.TEXt
                        containing a form feed character only.  The
                        NEW.TEXT and NEW.PAGE.TEXT files have then had
                        the following S(et E(nvironment options set.
                        F(illing False, A(uto indent False, R(ight margin
                        70, C(ommand Character is ".", T(oken searches is
                        False.

NEW.TEXT                A sample file to set up the editor "environment"
                        for an empty file with reasonable margins, etc.
NEW.PAGE.TEXT           A sample file to set up the editor "environment"
                        for a file with reasonable margins, etc. and a single
                        newpage (formfeed) character.
EDIT.E.G.TEXT           A sample editor file for practicing editing.

HELP.DISK.TEXT          Help texts used by the OffLoad startup program and
HELP.KEYS.TEXT          OffLoad Command Interpreter.
HELP.OFF.TEXT
HELP.UTIL.TEXT

OFF.READ.TEXT           A Read Me file about the creation of an OffLoad system.
OFF.DOC.TEXT            A summary of the way the OffLoad system is configured
                        at ERCC, the Utilities used, etc.
                        
______________________________________________________________________________



The following material was submitted by Chris Lee, INMOS  10-Feb-82:


CPROC.TEXT               A 'toy' command interpreter which may be used as
                         an example of how to use COMMANDIO facilities in
                         UCSD version IV.
VOLS.SMAC                A sample 'Monitor' file which can be used to
                         put a VOLS command into CPROC.

BENCH.BYTE.TEXT          Byte Benchmarks.
BENCH.PCW.TEXT           Personal Computer World Benchmarks.
BENCH.USUS.TEXT          Jon Bondy's USUS News Benchmarks.
BENCH.SWAP.TEXT          process swapping benchmark for version IV.

PRINT.MEM.TEXT           simple program to print memavail for USUS bench.
PRINT.HEAP.TEXT          program to print free space on heap.  Could be
                         used as a base for an algorithm to optimise
                         the use of heap space in a program.

CONTENTS.TEXT            This list.



========================================================================================
DOCUMENT :usus Folder:VOL12:cproc.text
========================================================================================

{ L cplist.text}
{$U-}
PROGRAM cproc;

(* Chris Lee, INMOS, 10-Feb-82  *)

(* A toy program whcih demonstrates how to use COMMANDIO routine
   to implement a user interface of your choice.
   
   This program builds a menu by searching all volumes online
   for files of name xxx.UTIL or xxx.SMAC.
   
   UTIL files should be renamed CODE files
   
   SMAC files should be renamed M(onitor or TEXT files
   
   The menu is drawn down the right side of the screen. To select an entry
   start typing it. As soon as enough has been typed to make the
   selection unambiguous the program types the rest. As soon as a
   definite error has occurred it is reported, and all input so far
   thrown away.
   
   Certain functions which are difficult to implement via UTIL or SMAC
   files are 'built in'. See Build_Menu to see how to add to the 
   built in commands
   
 *)
USES {$U  kernel.code}    kernel,
     {$U *screenops.code} screenops,
     {$U *commandio.code} commandio;

CONST   
  ESC                   =       27;
  max_token_length      =       15;
  sc_width              =       78;
  sc_height             =       23;
        
TYPE

  token                 =       STRING[max_token_length];
  
  cmd_types             =       (c_duff,c_menu,c_macro,c_prog,c_standard);
  
  vol_selector          =       STRING[10];
  
  token_table           =       RECORD
                                  table_size    :       INTEGER;
                                  values        :       ARRAY [1..20] OF
                                                          token;
                                END;
                                
  info_table            =       ARRAY [1..20] OF RECORD
                                  CASE cmd_type : cmd_types OF
                                    c_menu:( new_menu : char);
                                    c_prog:( vol      : vol_selector);
                                END;
VAR
  command   : token;
  table     : token_table;
  info      : info_table;
  ch        : char;
  cmd_no    : INTEGER;
  xstr      : STRING;

FUNCTION lookup ( target : token ; tokens : token_table) : INTEGER;

  VAR
    lo,hi,probe : integer;
    trial       : token;
    
BEGIN
WITH tokens DO
BEGIN
  lo:=1;
  hi:=table_size;
  WHILE lo<hi DO
  BEGIN
    probe:=((hi-lo) DIV 2)+lo;
    trial:=copy(values[probe],1,length(target));
    IF target>trial THEN lo:=probe+1
      ELSE hi:=probe;
  END;
  lookup:=lo;
  trial:=copy(values[lo],1,length(target));
  IF target<>trial THEN lookup:=-1;
  trial:=copy(values[lo+1],1,length(target));
  IF target=trial THEN lookup:=0
END;
END;


PROCEDURE insert_token ( value : token ; ctype : cmd_types ;
                         v_id: vol_selector;
                         VAR tokens : token_table ;
                         VAR info : info_table) ;

  VAR
    i,lo,hi,probe : integer;
    trial       : token;
    
BEGIN
WITH tokens DO
BEGIN
  lo:=1;
  hi:=table_size;
  WHILE lo<hi DO
  BEGIN
    probe:=((hi-lo) DIV 2)+lo;
    trial:=values[probe];
    IF value>trial THEN lo:=probe+1
      ELSE hi:=probe;
  END;
  IF table_size<>0 THEN BEGIN
    trial:=values[lo];
    IF value=trial THEN EXIT(insert_token);
    IF value>trial THEN lo:=lo+1;
  END;
  table_size:=table_size+1;
  FOR i:=table_size DOWNTO lo+1 DO
    values[i]:=values[i-1];
  FOR i:=table_size DOWNTO lo+1 DO
    info[i]:=info[i-1];
   CASE c_type OF
     c_menu:
       BEGIN
         values[lo]:=copy(value,1,length(value)-1);
         info[lo].new_menu:=value[length(value)];
       END;
     c_macro,
     c_prog,
     c_standard:
       BEGIN
         values[lo]:=copy(value,1,length(value));
         info[lo].vol:=v_id;
       END;
   END;
  info[lo].cmd_type:=c_type;
END;
END;


PROCEDURE build_menu(VAR table : token_table
                        VAR info : info_table);

  VAR
    sys_dir     :       directory;
    i,j         :       INTEGER;
    dot         :       INTEGER;
    ctype       :       token;
    cname       :       token;
    v_id        :       vol_selector;
    c_tipe      :       cmd_types;

BEGIN
WITH table DO
BEGIN
  table_size:=0;
  FOR j:=0 TO 12 DO
    IF j IN [4,5,9..12] THEN
      BEGIN
        v_id:='XXX';        {to set length}
        v_id[1]:='#';
        v_id[2]:=chr((j DIV 10)+ord('0'));
        v_id[3]:=chr((j MOD 10)+ord('0'));
        unitread(j,sys_dir,sizeof(directory),dirblk);
        FOR i:=1 TO sys_dir[0].dnumfiles DO
          WITH sys_dir[i] DO
            IF length(dtid)>6 THEN
              BEGIN
                dot:=length(dtid)-4;
                ctype:=copy(dtid,dot,5);
                ctipe:=c_duff;
                cname:=copy(dtid,1,dot-1);
                IF ctype='.SMAC' THEN c_tipe:=c_macro
                ELSE IF ctype='.UTIL' THEN c_tipe:=c_prog;
                IF ctipe<>c_duff THEN insert_token(cname,c_tipe,v_id,table,info);
              END;
      END;
  insert_token('FILER',          c_standard,'F',         table,info);
  insert_token('COMPILE',        c_standard,'C',         table,info);
  insert_token('EDIT',           c_standard,'E',         table,info);
  insert_token('EXECUTE',        c_standard,'X',         table,info);
  insert_token('RUN',            c_standard,'R',         table,info);
  insert_token('HALT',           c_standard,'I',         table,info);
END;
END;

PROCEDURE show_menu(table:token_table);

VAR
  i,x,y : INTEGER;
  
BEGIN
  y:=1;
  x:=0;
  sc_goto_xy(x,y);
  x:=sc_width-sizeof(token);
  WITH table DO
    FOR i:=1 TO table_size DO
      BEGIN
        sc_goto_xy(x,y);
        sc_erase_to_eol(x,y);
        write(values[i]);
        y:=y+1;
      END;
END;
  
BEGIN
WITH table DO
BEGIN
  {sc_init;
  sc_clr_screen;}
  sc_erase_to_eol(0,0);
  build_menu(table,info);
  show_menu(table);
  REPEAT
    exception(TRUE);
    sc_goto_xy(0,0);
    write('?');
    command:='';
    REPEAT
      read(keyboard,ch);
      IF ch IN ['a'..'z'] THEN ch:=chr(ord(ch)-ord('a')+ord('A'));
      
      IF ORD(ch)=ESC THEN 
        BEGIN
          sc_goto_xy(0,0);
          sc_clr_screen;
          exception(TRUE);
          EXIT(PROGRAM);
        END;
      
      write(ch);
      IF ord(command[0])=0 THEN sc_erase_to_eol(2,0);
      command[0]:=chr(ord(command[0])+1);
      command[ord(command[0])]:=ch;
      cmd_no:=lookup(command,table);
    UNTIL cmd_no<>0;
    IF cmd_no<0 THEN 
      BEGIN
        write(' - not found');
      END
    ELSE 
      BEGIN
        writeln(copy(values[cmd_no],length(command)+1,
                        length(values[cmd_no])-length(command)));
        CASE info[cmd_no].cmd_type OF
        
       c_macro: BEGIN
                   sc_eras_eos(0,1);
                   exception(TRUE);
                   chain(concat('I=',info[cmd_no].vol,':',
                                     values[cmd_no],'.SMAC'));
                   chain('CPROC');
                 END;
                 
        c_prog:  BEGIN
                   sc_eras_eos(0,1);
                   exception(TRUE);
                   chain(concat(info[cmd_no].vol,':',values[cmd_no],'.UTIL.'));
                   chain('CPROC');
                 END;

    c_standard:  BEGIN
                   sc_eras_eos(0,1);
                   exception(TRUE);
                   if info[cmd_no].vol='X' then
                     begin
                       gotoxy(0,0);
                       write('Execute what file? ');
                       readln(xstr);
                       {should check availability of code file now}
                       {otherwise the CPROC command interpreter may not}
                       {regain control after the exception}
                       chain(xstr);
                     end
                   else chain(concat('I="',info[cmd_no].vol,'"'));
                   {chain back to command interpreter unless HALTing}
                   if info[cmd_no].vol<>'I' then chain('CPROC');
                 END;
        END;
      END;
  UNTIL info[cmd_no].cmd_type IN [c_prog,c_macro,c_standard];
END;
END.

========================================================================================
DOCUMENT :usus Folder:VOL12:disk_copy.text
========================================================================================

(*$S+*)
(*$I-*)
(*$C Copyright 1982 (c) Great Western Software  all rights reserved *)
program disk_copy;
(*
    Copies disks with verification    George Schreyer
*)
var chk_buffer,buffer : packed array [0..15359] of char;
    ch : char;
    error : boolean;
    unitnum : integer;
    k2,blocks,block,k,k1,i : integer;
    diska,diskb : file;
    namea,nameb : string;

procedure clear_line;
begin
   write ( chr ( 27 ) , 'K' );  {H-19 dependant}
end;

procedure space_wait;
var ch : char;
begin
   write ( '   <space> to continue' );
   repeat
      read ( keyboard, ch );
   until ( ch = ' ' ) and ( not eoln ( keyboard ) );
end;

begin
   writeln;
   writeln ( '     disk_copy  version 2.12  5-Jun-82' );
   fillchar(buffer,sizeof(buffer),chr(0));
   fillchar(chk_buffer,sizeof(chk_buffer),chr(0));
   namea := '#4:';
   nameb := '#5:';
   writeln;
   writeln('Disk_copy copies a whole UCSD disk onto another.');
   writeln('The source disk is placed in drive 4 and the destination');
   writeln('disk is placed in drive 5.');
   repeat
      gotoxy ( 0, 15 );
      clear_line;
      write('type <space> to start the transfer, or <return> to quit ');
      repeat
         read(keyboard,ch);
      until ( ch = ' ' );
      if eoln(keyboard) then exit(program);
      blocks := sizeof(buffer) div 512;
      reset(diska,namea);
      rewrite(diskb,nameb);
      writeln;
      error := false;
      block := 0;
      repeat
         gotoxy ( 0, 15 );
         clear_line;
         write ( 'reading ...' );
         k := blockread(diska,buffer,blocks,block);
         if ( (k < blocks) and (not eof(diska)) ) or (ioresult <> 0 ) then
            begin
               gotoxy ( 0, 15 );
               clear_line;
               write(chr(7),'error reading #5');
               space_wait;
               error := true;
            end;
         gotoxy ( 0, 15 );
         clear_line;
         if not error then
            begin
               write ( 'writing ...' );
               k1 := blockwrite(diskb,buffer,k,block);
               if ioresult <> 0 then 
                  begin
                     gotoxy ( 0,15 );
                     clear_line;
                     write ( 'error writing #9:' );
                     space_wait;
                     error := true;
                  end;
            end;
         gotoxy ( 0, 15 );
         clear_line;
         if not error then
            begin
               write ( 'verifying ...' );
               k2 := blockread(diskb,chk_buffer,k,block);
               block := block + k;
               if ( buffer <> chk_buffer ) or ( ioresult <> 0 ) then 
                  begin
                     gotoxy ( 0, 15 );
                     clear_line;
                     write(chr(7),'verification error');
                     space_wait;
                     error := true;
                  end;
            end;
      until (k < blocks) or (k1 <> k) or error;
      close(diskb,lock);
      close(diska);
   until false;
end.
      

========================================================================================
DOCUMENT :usus Folder:VOL12:help.disk.text
========================================================================================

B(ackup #4          Make a backup copy of the Off-Load system disk in drive 4.
C(opy #5            Copy the user disk in drive #5.
N(ew #5             Create a formatted empty user disk in drive #5.
T(idy disks         Tidy up the disks in both drives to collect together
                    all unused space.
Q(uit               Return to Off-Load command level.


========================================================================================
DOCUMENT :usus Folder:VOL12:help.keys.text
========================================================================================

SuperBrain/UCSD p-System version IV.0 Keyboard Characters
--------------------------------------------------------------------------------
Editor Cursor moving keys                4 arrowed keys to right of keyboard
Editor Accept Key                        Ctrl/C
Editor Escape Key                        ESC
Editor X(change Insert Key               Ctrl/O    for "Open" up one space
Editor X(change Delete Key               Ctrl/Z    for "Zap" one character

Delete current line                      Ctrl/X
Delete last character                    BACKSPACE

Stop/Start Screen output key             CTRL/S
Flush Screen Output                      Ctrl/F
Reboot                                   depress two red keys at same time


========================================================================================
DOCUMENT :usus Folder:VOL12:help.off.text
========================================================================================

E(dit      enters the Off-Load text editor.
F(iler     enters the disk filing utility.
L(ist      starts the printing utility.
P(rose     starts the text formatting utility.
S(can      to list a document to the screen for review.
T(ty       starts up the communications utility.
D(iskaids  facilities to initialise new disks, copy disks and tidy disks.
           See H(elp D(iskaids for details.

X(ecute    is used to start up other utilities.
           See H(elp U(tilities for details.

Q(uit      is used to stop Off-Load.

Off-Load is based on the UCSD p-System version IV.0


========================================================================================
DOCUMENT :usus Folder:VOL12:help.util.text
========================================================================================

*CALC         desk top arithmetic calculator.
*MAIL         system to maintain records of mailing and other general
              information to allow the printing of mailing labels and
              the production of personalised letters.
*MAIL.INIT    utility to initialise MAIL records from a document.
*COMPARE      check for differences between two documents.
*CRACKUP      split up large files for editing and join them together again.
*COMPACT      reduce disk storage space occupied by a document.
*SORTMERGE    sort a document according to fields of each line.
*CONFIGURE    utility to alter the operating environment of Off-Load.

FUND (cashflow analysis),ENUF(database),etc are available as separate systems.
-------------------------------------------------------------------------------
The following two utilities are normally executed using the D(isk-aid commands:
              B(ackup-#4, C(opy-#5 or N(ew-#5.
              However, they are directly available.
*BOOTER       copy the system disk bootstrap.
*FORMATDISK   initialise a new disk for use on Off-Load.


========================================================================================
DOCUMENT :usus Folder:VOL12:lmformat.text
========================================================================================


{$   l-printer:}

PROGRAM lmformat;

{$copyright (c) 1981 by Lee Meador, Arlington, TX 76010 }

{ Program formats Pascal programs by capitalizing keywords and }
{  making everthing else lower case. This makes a nice listing }
{ LMFORMAT was run on itself at one time                       }
{ You can add any more words you want capitalized to the list  }
{  but be sure to keep it in alphabetical order                }
{                                                              }
{ Problems: words in comments should be left alone completely  }
{  and single quotes in comments will throw it all off         }
{  a nice feature would change any bracket comments to (**)    }
{   or vice versa but should check for close comment inside    }
{  it could be speeded up with BLOCKREAD and WRITE             }
{  a lot more keywords should be added to these common ones    }

VAR fin         : text;         { input file variable       }
    fout        : text;         { output file variable      }
    line        : STRING;       { keep the input line here  }
    inname,                     { input file name from user }
    outname     : STRING;       { output file name, too     }
    debug       : BOOLEAN;      { true to trace program     }
    lineno      : INTEGER;      { counts the lines of text  }
    
PROCEDURE process(VAR line:STRING);

{ process one line to change SPECIAL words to caps      }

VAR i           : INTEGER;      { count chars in the line   }
    inquotes    : BOOLEAN;      { true when inside quotes   }

PROCEDURE tryem;

{ try to change the word beginning at 'I' if its special    }

PROCEDURE trymatch(trystring:STRING);

{ try to match (and change to caps) the word in trystring   }

PROCEDURE changeit;

{ IT matches! so change the word to all caps                }

VAR j           : INTEGER;      { counts chars in the word  }

BEGIN
   IF debug THEN WRITELN('ENTERING CHANGEIT',
      copy(line,i,length(trystring)));
   
   FOR j := 0 TO length(trystring)-1 DO
      IF line[i+j] IN ['a'..'z'] THEN
         line[i+j] := chr(ord(line[i+j])-32);
   EXIT(tryem);  { dont try to match any more cause we already did }
   
END;

BEGIN
   
   IF debug THEN WRITELN('ENTERING TRYMATCH -> ',trystring);
   
   { if the line is too short, dont bother }
   
   IF i+length(trystring)-1 > length(line) THEN EXIT(trymatch);
   
   { it has to match and have the next char (after the word) be }
   {  either an non-alphanumberic or off the end of the string  }
   
   IF (copy(line,i,length(trystring)) = trystring)  
      THEN IF length(line) > i+length(trystring) 
         THEN IF NOT (line[i+length(trystring)] 
                     IN ['a'..'z','A'..'Z','0'..'9']) 
            THEN changeit { non-alphanumeric after word }
            ELSE { null }
         ELSE changeit;   { end of line after word      }
   
   { maybe we didnt match -- so dont try to match any more if the }
   {  word we are trying is alphbetically after the word in the   }
   {  line. The keywords are alphabetized by first letter.        }
   
   IF line[i] < trystring[1] THEN EXIT(tryem);
   
END; { trymatch }

BEGIN
   IF debug THEN WRITELN('ENTERING TRYEM --> ',
      copy(line,i,length(line)-(i-1)));
   
   { try to match each of these keywords - in alphabetic order    }
   
   trymatch('and');
   trymatch('array');
   trymatch('begin');
   trymatch('boolean');
   trymatch('case');
   trymatch('char');
   trymatch('close');
   trymatch('const');
   trymatch('div');
   trymatch('downto');
   trymatch('do');
   trymatch('else');
   trymatch('end');
   trymatch('exit');
   trymatch('external');
   trymatch('false');
   trymatch('file');
   trymatch('forward');
   trymatch('for');
   trymatch('function');
   trymatch('get');
   trymatch('gotoxy');
   trymatch('goto');
   trymatch('if');
   trymatch('implementation');
   trymatch('integer');
   trymatch('interface');
   trymatch('in');
   trymatch('label');
   trymatch('mod');
   trymatch('nil');
   trymatch('not');
   trymatch('of');
   trymatch('or');
   trymatch('packed');
   trymatch('page');
   trymatch('procedure');
   trymatch('program');
   trymatch('put');
   trymatch('readln');
   trymatch('read');
   trymatch('real');
   trymatch('record');
   trymatch('repeat');
   trymatch('reset');
   trymatch('rewrite');
   trymatch('seek');
   trymatch('segment');
   trymatch('separate');
   trymatch('set');
   trymatch('string');
   trymatch('then');
   trymatch('to');
   trymatch('true');
   trymatch('type');
   trymatch('unit');
   trymatch('until');
   trymatch('uses');
   trymatch('var');
   trymatch('while');
   trymatch('with');
   trymatch('writeln');
   trymatch('write');
END; { tryem }

BEGIN { process }

   IF debug THEN WRITELN('ENTERING PROCESS ->');
   IF debug THEN WRITELN('   ',line);
   
   { change all the letters that arent in quotes to lower case first }
   
   inquotes := FALSE;
   
   FOR i := 1 TO length(line) DO 
      IF NOT inquotes 
         THEN IF line[i] = '''' 
            THEN inquotes := TRUE
            ELSE IF line[i] IN ['A'..'Z'] 
                 THEN line[i] := chr(ord(line[i])+32)
                 ELSE { null }
         ELSE IF line[i] = ''''
            THEN inquotes := FALSE
            ELSE { null };
   
   { try all the keywords beginning at every position of the line }
   { we do save a little time by not bothering if the char at a   }
   {  position isnt alphabetic -- which all keywords begin with   }
   {  then when we finish trying a word we skip to the next       }
   {  possible place a match could occur -- next non-alphanum     }
   { Oh yes, dont try to match inside quotes                      }
   
   inquotes := FALSE;
   
   FOR i := 1 TO length(line) DO
      IF NOT inquotes
         THEN IF line[i] = ''''
            THEN inquotes := TRUE
            ELSE IF line[i] IN ['a'..'z'] { dont try non-lc chars }
               THEN BEGIN
                  tryem; { a possible place -- try it }
                  IF i < length(line) THEN 
                     WHILE (line[i+1] IN ['a'..'z','A'..'Z','0'..'9']) AND
                           (i < length(line)-1) DO 
                        i := succ(i) { skip alphanums after try }
                 END
               ELSE { null }
         ELSE IF line[i]= ''''
            THEN inquotes := FALSE
            ELSE { null }  { no trying inside quotes }
   
END; { process }

BEGIN
   
   debug := FALSE; { set to true to print out a trace on console }
   
   { open input file }
   
   PAGE(output);
   GOTOXY(0,5);
   WRITE('Input File name: ');
   READLN(inname);
   IF length(inname)=0 THEN inname := 'SYSTEM.WRK.TEXT';
   
   RESET(fin,inname);
   
   { then open output file }
   
   GOTOXY(0,7);
   WRITE('Output File name: ');
   READLN(outname);
   IF length(outname)=0 THEN outname := 'SYSTEM.WRK.TEXT';
   
   REWRITE(fout,outname);
   
   { now read, change and write each line }
   
   lineno := 0;
   
   WHILE NOT eof(fin) DO BEGIN
      IF lineno MOD 50 = 0 THEN BEGIN
         WRITELN;
         WRITE('<',lineno:4,'> ');
        END;
      WRITE('.');
      lineno := succ(lineno);
      READLN(fin,line);
      process(line);
      WRITELN(fout,line);
     END;
     
   { finally save the output ... thats it }
   
   CLOSE(fout,lock);
   
   WRITELN('Your output is on ',outname);
   
END.


========================================================================================
DOCUMENT :usus Folder:VOL12:make.page.text
========================================================================================

PROGRAM MAKEPAGE;
VAR X:TEXT;
BEGIN
  REWRITE(X,'#5:NEW.PAGE.TEXT');
  WRITE(X,CHR(12));
  CLOSE(X,LOCK)
END.


========================================================================================
DOCUMENT :usus Folder:VOL12:new.page.text
========================================================================================



========================================================================================
DOCUMENT :usus Folder:VOL12:new.text
========================================================================================



========================================================================================
DOCUMENT :usus Folder:VOL12:off.doc.text
========================================================================================

~Overview~

OffLoad is a collection of administrative aids which are
made available on a microcomputer.  The system is intended
for those users who require a general purpose microcomputer
system for some aspect of their work and who wish to use
the system for additional administrative functions.

The individual components of the OffLoad system have been
made as compatible as possible to provide a
straightforward, uniform set of facilities to the user. 
Extensive use is made of "menus" from which choices of
action may be made and help information is provided by the
system.

         +-------------+
         |   Computer  |
         |   Network   |
         +-------------+
                ^
                |
                v
         +-------------+         +-----------+
         |   OffLoad   | ------> |  Printer  |
         | workstation |         +-----------+
         +-------------+
                ^
                |
                v
               user
                            
The design of the OffLoad workstation allows
straightforward integration with facilities available over
a computer network. This will enable interpersonal
communication facilities (such as electronic mail, viewdata
and document transfers) as well as access to more powerful
computer based facilities, document archives, printing,
etc.

~System Requirements~

The full OffLoad system will run on the UCSD p-System
Version IV and it has initially been provided on the
Intertec SuperBrain QD microcomputer. Many of the
individual components of OffLoad are available as part of
the WORDSET Word Processing Facilities or other packages
available from the ERCC for UCSD based microcomputers. 








~OffLoad Command Level~

The components of the OffLoad system are arranged in a
hierarchy. At all levels you are presented with a prompt
line giving the options available to you and inviting you
to press a key to select one of them.  Options are
indicated by a form such as E(dit or S(et.  Type the letter
to the left of the parenthesis to make the appropriate
selection. You may return to a higher choice level by
typing Q to Q(uit.

~OffLoad Components~

E(ditor        to create and modify documents
F(iler         to examine disk contents, manipulate disks
L(ist          to print out documents
P(rose         to format documents
S(can          to list a document to the screen for review
T(ty           to communicate with other computers
D(iskAids      to copy and tidy disks
H(elp          to provide assistance in the use of OffLoad
X(ecute        to execute other utilities and programs
               Crackup       splits up large documents and 
                             rejoins parts
               Compact       reduce space used by document
               Calc          Desktop arithmetic calculator
               Compare       two documents
               Sort/Merge
               Mail          Mailing label manager and
                             form letters
               Configure     workstation environment
               Fund,Enuf,etc Cashflow analysis,
                             Data base management system, etc
               + others

~OffLoad Parameter Text~

Instead of making arbitrary choices for the default action
of the various components of OffLoad, the system will check
for the presence of setup information in a text file held
on the system disk (*PARAM.INFO).  This is set to general,
useful values but may be altered by the user with the
Editor. An appendix to this document describes the various
features which may be set up.  Suitable general purpose
defaults have already been chosen for the OffLoad system as
it is distributed.









~Help~

The OffLoad workstation provides help on several topics. 
You can get a summary of the OffLoad commands, recall the
special keystrokes needed for editor functions, get a list
of the Utilities available, etc.

A document *HELP.HINT may be created by a user of OffLoad
to hold any useful information and this can be recalled in
the OffLoad Help facility at any time.


~Editor~

A screen oriented editor is used for the entry of text to
the system and for its subsequent modification.  The editor
displays a screen image which shows a "window" onto the
text being edited.  The screen image is as close as
possible to the current state of the part of the text being
entered or modified.  Cursor moving keys may be used to
move to any position on the screen or to move through the
text to cause a different "window" to be shown on the
screen.

~DiskAids~

A set of commonly needed disk operations has been provided
in an easy to use manner via the DiskAids component of
OffLoad.  These simplify the copying of entire disks and
the setting up of new user disks.  Normally these
operations would each consist of several steps and
necessitate otherwise unnecessary background knowledge of
the computer system being used.  The DiskAid facilities
are:

B(ackup-#4    create a backup of the OffLoad System Disk
C(opy-#5      create a copy of the User Disk
N(ew-#5       create a new, formatted, blank, User Disk
T(idy         compact unused space on the disks in drives


~Filer~

The Filer is a collection of facilities to examine the list
of documents or files on disks (known as disk directories),
to copy files, remove files, change the names of files,
copy entire disks, etc. Floppy disks are prone to damage
from dust, grease, etc, so there are aids for checking
disks are sound and recovering parts of disks found to be
faulty (see the appendix on handling floppy disks for more
information on disk handling and recovering from errors).

The "DiskAids" facilities in OffLoad are intended to
provide a straightforward method of manipulating entire
disks, to take back-up copies of disks, etc.

~LIST~

LIST is a utility for listing text to a printer.  Simple
paginated output is possible using a format which you may
specify in the OffLoad parameter information text. However,
the OffLoad workstation is set up so that, by default, A4
paginated output will be produced. The document to be
listed may consist of several separate parts.  These can be
given to LIST by separating them by commas.

Text may be underlined and characters printed in an
alternative font using the LIST utility.


~PROSE - Text Formatter~

More sophisticated text formatting is possible using the
text formatter PROSE.  Directives may be placed in the text
to produce a wide variety of output styles.  Without
directives PROSE will attempt to produce a reasonably
formatted document according to a default description.

Sample directive texts for PROSE are provided with the
OffLoad System.


~Scan - review a long text~

The S(can) option of OffLoad is a simple method of
reviewing a text file which is too long to edit.  It lists
the document on the screen.


~TTY - Communications~

TTY can be used to enable the microcomputer to act as a
video terminal to a host computer.  The microcomputer is
connected to the network via a Terminal Control Processor,
either directly or via an accoustic coupler and telephone
to the host computer. The normal conventions for logging on
to and using the host computer should then be followed.

It is possible to enter a "local mode" of the TTY program
and to P(ut documents to the host computer from the micro-
computer's disks or to G(et documents back from the host
computer to the microcomputer's disks. The F(iler option
allows the microcomputer's disk directories to be examined,
documents removed, etc. from within TTY.

TTY forms a part of the ERCC X-Talk communication
facilities.



~X(execute)~

Less commonly used components of the OffLoad system do not
appear on the main options menu list.  These can be used by
typing X and giving the component name.

~CRACKUP~

CRACKUP can be used to break up a large document into
several manageable pieces suitable for editing.  This may
be necessary where a document is brought onto the
workstation from elsewhere (e.g., from another computer).

In addition, should it ever be desirable to put together
all the separate sections of a large document (e.g., for
sending to someone on a different computer) CRACKUP will
also perform that operation.


~COMPACT~

The Editor and some other OffLoad utilities represent
documents in a reduced form.  In some cases, such as
receipt of documents from a host computer via the G(et
document) facilities of the TTY communication package, the
document created will be larger than strictly necessary. 
If this causes inconvenience, such as making the document
too large to edit, perform a COMPACT operation on the
document and the leading spaces will be converted to their
reduced form, and all trailing spaces on lines will be
removed.

~CALC~

CALC enables simple arithmetic calculations to be
performed. A display can be maintained showing the current
values of a set of "variables" which can be used to hold
intermediate results.  Help information is available in the
utility.

~COMPARE~

This is a utility to compare 2 similar documents and to
produce a report of the differences between them.  It is
normally used to compare a revision of a document against
an original.

~SORT/MERGE~

SORT/MERGE is a general package which is able to perform a
number of operations on lines of text (usually in some
fixed format or list) or on other types of files.  The
OffLoad system includes one version of this facility which
allows a document consisting of single line records to be
sorted according to up to 6 'keys' or ordering fields.
     
~MAIL~

MAIL is a utility to manage a data base of name, address
and other information.  The data base may be added to,
changed and entries deleted.  It is possible to search
through the data base for records satisfying certain
criteria.  Mailing labels may be produced and record
entries merged into standard letters to produce "form"
letters.


~CONFIGURE~

CONFIGURE can be used to set characteristics of the OffLoad
workstation hardware.  Normally, information for the ports
for connection to a printer and to other computers can be
set in CONFIGURE. See the manual for the particular
hardware in use for details.


~FUND (Cash Flow Analysis), ENUF (database), etc.~

FUND, ENUF, etc. are systems provided on the UCSD p-System
in which OffLoad operates.  They are not provided directly
in OffLoad due to limitations on disk space.  However, they
may be used as separate systems.

FUND is a utility to maintain a list of transactions by
Cost Centres (e.g., grants or departmental groupings) and
Cost Codes (e.g., expenditure headings).  Transactions may
be entered and later examined. Reports may be generated to
the screen or to a printer giving income, expenditure, cash
balances and committed expenditure for various cost centres
or cost codes.

ENUF - the Edinburgh User Friendly Data Base Management
System - is a flexible, easy to use, general purpose data
base management system.  It may be used in many situations
where record processing is required.

~FORMATDISK, BOOTER, etc~

These utilities are normally called via the OffLoad
DiskAids component.  However, they can be called
separately if required to format disks or to copy the
bootstrap area of disks.

~User Provided Programs~

There are several general purpose tools to aid in providing
programs suitable for administrative functions. In
particular, there are facilities to provide ISAM (Indexed
Sequential Access Method) file support and "electronic
form" oriented front ends to programs.


========================================================================================
DOCUMENT :usus Folder:VOL12:off.info.text
========================================================================================

SuperBrain QD OffLoad Info Text.  23-July-81
1
*FORMATDISK PI="FD,Q"
*BOOTER PI="4,5,,"

690
690
4
<ctrl/S>
-1



========================================================================================
DOCUMENT :usus Folder:VOL12:off.read.text
========================================================================================

OffLoad Command Interpreter - 19-Feb-82 - Austin Tate
-----------------------------------------------------

The following files are on the disk:

OFF.START.TEXT          The *SYSTEM.STARTUP program
OFFLOAD.TEXT            The command interpreter --> *OFFLOAD.CODE
-------------------------
OFF.INFO.TEXT           The information file for the workstation
-------------------------
NEW.TEXT                A sample file to set up the editor "environment"
                        for an empty file with reasonable margins, etc.
NEW.PAGE.TEXT           A sample file to set up the editor "environment"
                        for a file with reasonable margins, etc. and a single
                        newpage (formfeed) character.
EDIT.E.G.TEXT           A sample editor file for practicing editing.
-------------------------
HELP.DISK.TEXT          Help texts used by the OffLoad startup program and
HELP.KEYS.TEXT          OffLoad Command Interpreter.
HELP.OFF.TEXT
HELP.UTIL.TEXT
-------------------------
OFF.READ.TEXT           This document.
OFF.DOC.TEXT            A summary of the OffLoad System as configures at
                        ERCC, the utilities used, etc.

Preparation
-----------
_______________________________________________________________________

Notes from the reviewer:

     Offload REQUIRES a version IV.0 system with CHAIN (found in the system
unit COMMANDIO).  It also uses ScreenOps, which is distributed with your IV.0
system, to operate properly. I couldn't find the documentation for setting up
OFF.INFO.TEXT, but the program fumbles around and more or less works without it.

     If you really want to have some some fun, set up the window manager F(iler
utility (found on this disk as WINDOWS and WFILER) first and call it
*FILER.CODE.  - gws

________________________________________________________________________

     
     
1. Compile the OFF.START program and rename it *SYSTEM.STARTUP.

2. Compile OFFLOAD to *OFFLOAD.CODE.

3. Put all the other text files on the Boot Disk.

4. Edit the *OFF.INFO.TEXT information file to hold the relevant
   parameters for your workstation - disk size in blocks, command
   sequences to copy disks, copy bootstraps, format disks, etc.
   Change the version number at the top and bottom of this file
   whenever you change the *OFF.INFO.TEXT file and it will be
   reloaded the next time *OFFLOAD runs.
   
5. Rename or copy *SYSTEM.EDITOR to *EDITOR.CODE and
   *SYSTEM.FILER to *FILER.CODE.

6. Reboot and watch the fun.


========================================================================================
DOCUMENT :usus Folder:VOL12:off.start.text
========================================================================================

program offstart;
USES {$U *screenops.code} SCREENOPS,
     {$U *commandio.code} COMMANDIO;

{Off-Load Office Workstation startup program}
{Copyright  Austin Tate  18-Aug-81}

{User may provide a code file *STARTUP.CODE to be run after}
{this program but before the main Off-Load command interpreter}

const bel=7;
var ch:char;
    xstr:string;
    SCInfo:sc_info_type;

procedure line(Y:integer);
var i:integer;
begin
  if Y>=0 then GOTOXY(0,Y); {else put line on end of present text}
  for i:=1 to 4 do write('--------------------');
end;

function exists(fname,suffix:string):boolean;
var g:file;
begin
  if (length(fname)=0) then exists:=false
  else
    begin
      {$I-}
      reset(g,concat(fname,suffix));
      exists:=(IORESULT=0);
      {$I+}
    end;
end;

procedure help(fname:string);
var f:text;
    st:string[255];
begin
  if (length(fname)=0) then
    writeln(fname,' is an illegal help text file name.')
  else
    begin
      {$I-}
      reset(f,concat(fname,'.TEXT'));
      if (IORESULT<>0) then writeln(fname,' help text is not on disk.')
      else
        begin
          while not eof(f) do begin
            readln(f,st);
            if IORESULT=0 then writeln(st);
          end;
        end;
      {$I+}
    end;
end;

procedure title;
begin
  line(0);
  writeln('O  F  F - L  O  A  D  -  Office Workstation');
  line(2);
end;

procedure getdate;
var xstr:string;
begin
  {get date}
  SC_Use_Info(SC_Get,SC_Info);
  xstr:='   ';
  with SC_Info.SC_Date do begin
    case Month of
        1: xstr:='Jan';
        2: xstr:='Feb';
        3: xstr:='Mar';
        4: xstr:='Apr';
        5: xstr:='May';
        6: xstr:='Jun';
        7: xstr:='Jul';
        8: xstr:='Aug';
        9: xstr:='Sep';
       10: xstr:='Oct';
       11: xstr:='Nov';
       12: xstr:='Dec';
      end;
    gotoxy(56,21);
    write('Date is set to ');
    write(Day:2,'-',xstr,'-',Year:2);
  end;
end;

begin
  sc_clr_screen;
  xstr:='';
  title;
  help('*Help.Off');
  line(-1);
  title;
  SC_Eras_EOS(0,21);
  gotoxy(0,21);
  if Redirect('P=#5') then Write('The default volume is drive #5.')
  else
    begin
      exception(TRUE);
      write('The volume prefix could not be set.');
    end;
  
  if exists('*STARTUP','.CODE') then chain('*STARTUP'); {user provided startup}
  getdate;
  SC_Clr_Line(22);
  write('Type ''D'' to set date, <space> to continue');
  SC_GetC_Ch(ch,['D',' ']);
  if ch='D' then
    begin
      write(' ........ Date will be set within Filer');
      chain('*FILER PI="D"');
    end;
  Chain('*OFFLOAD');
end.





========================================================================================
DOCUMENT :usus Folder:VOL12:offload.text
========================================================================================

program offload;
USES {$U *screenops.code} SCREENOPS,
     {$U *commandio.code} COMMANDIO;

{Off-Load Office Workstation command interpreter}
{Copyright  Austin Tate  20-Aug-81}

{user may provide a file *Help.Hint.Text containing any items}
{desired as H(elp H(ints text                                }

const bel=7;
      paramrevision=1; {revision number of parameter file *OFF.INFO.TEXT}
type paramrec=record
        headrevision:integer;
        formatstr:string;
        bootstr:string;
        quitstr:string;
        SDiskBlocks:string[7]; {string version of diskblocks}
        diskblocks:integer;
        usercopyto:integer; {volume to copy user disk to}
                            {4 on a 2 disk dsystem}
        sstoggle:string[15];
        endrevision:integer; {-ve of headrevision as a check}
      end;
var param:paramrec;
    ch,esc:char;
    xstr:string;
    terminal:boolean;

procedure loadparams;
var ok:boolean;
    f:file of paramrec;
    g:text;
    ires1,ires2:integer;
begin
  {$I-}
  ok:=false;
  reset(f,'*OFF.INFO.DATA');
  if ioresult=0 then
    begin
      {get done by reset}
      param:=f^;
      with param do begin
        ok:=((headrevision=paramrevision) and
             (endrevision=-paramrevision));
      end;
    end;
  if not ok then close(f,purge) else close(f);
  if not ok then
    begin
      SC_Clr_Screen;
      Write('Reading *OFF.INFO.....');
      reset(g,'*OFF.INFO.TEXT');
      if ioresult=0 then
        begin
          with param do begin
            readln(g,xstr);  {initial comment line}
            readln(g,headrevision);
            readln(g,formatstr);
            readln(g,bootstr);
            readln(g,quitstr);
            readln(g,Sdiskblocks);
            readln(g,diskblocks);
            ires1:=ioresult;
            readln(g,usercopyto);
            ires2:=ioresult;
            readln(g,sstoggle);
            readln(g,endrevision);
            close(g);
          end;
          if ((param.headrevision=paramrevision) and
              (param.endrevision=-paramrevision) and
              (ires1=0) and (ires2=0)) then
            begin
              rewrite(f,'*OFF.INFO.DATA');
              f^:=param;
              put(f);
              close(f,lock);
              ok:=true;
            end;
        end;
      if not ok then
        begin
          Writeln('  but it was was unavailable or out of date.');
          repeat
          until not space_wait(TRUE);
        end;
    end;
  {$I+}
end;

procedure line(Y:integer);
var i:integer;
begin
  if Y>=0 then GOTOXY(0,Y); {else put line on end of present text}
  for i:=1 to 4 do write('--------------------');
end;

function exists(fname,suffix:string):boolean;
var g:file;
begin
  if (length(fname)=0) then exists:=false
  else
    begin
      {$I-}
      reset(g,concat(fname,suffix));
      exists:=(IORESULT=0);
      {$I+}
    end;
end;

procedure help(fname:string);
var f:text;
    st:string[255];
begin
  line(2);
  if (length(fname)=0) then
    writeln(fname,' is an illegal help text file name.')
  else
    begin
      {$I-}
      reset(f,concat(fname,'.TEXT'));
      if (IORESULT<>0) then writeln(fname,' text is not on disk.')
      else
        begin
          while not eof(f) do begin
            readln(f,st);
            if IORESULT=0 then writeln(st);
          end;
        end;
      {$I+}
    end;
  line(-1); {line on end of text}
  line(2);  {repeated in case of scroll}
end;
             
PROCEDURE CopyDisk;
CONST
   FromVol=5;
   ToVol=4;
   INC1=10;
   {TRANSFER THIS MANY BLOCK AT A TIME - MAKE AS LARGE AS SPACE ALLOWS}
VAR
   I,ERRORS,SECTOR,BLOCK,INCR,LGTH,MAX1:INTEGER;
   ARR:PACKED ARRAY[0..INC1,1..512] OF CHAR;
   CH:CHAR;
   MaxBlocks:integer;
BEGIN
  {DiskBlocks is global} {TRANSFER BLOCKS 0..(DiskBlocks-1)}
  MaxBlocks:=param.DiskBlocks;
  WRITELN;
  WRITELN('Copy will copy the entire contents of the User Disk in drive #',
          FromVol);
  WRITELN('     to a disk which has previously been N(ew-#5 ed in drive #',
          ToVol);
  WRITELN;
  IF ToVol=4 THEN 
     WRITELN('You should remove the OFFLOAD System Disk from drive #4.');
  WRITELN;
  WRITELN('Put a disk which has already been N(ew-#5 ed in drive #',ToVol);
  WRITELN('Note that the entire contents of this disk will be overwritten');
  REPEAT
    GotoXY(0,8);
    WRITE('Type <space> to continue, <esc> to abort');
    READ(KEYBOARD,CH);
  UNTIL Ch in [ESC,' '];
  IF Ch=ESC then EXIT(CopyDisk);
  GOTOXY(0,10);
  WRITELN('Copy starting..');
  
  {$I-}
  BLOCK:=0;
  INCR:=INC1;
  LGTH:=512*INCR;
  MAX1:=MaxBlocks-INCR;
  REPEAT
     UNITREAD(FromVol,ARR,LGTH,BLOCK,0);
     IF IORESULT<>0 THEN
        {try again - block at a time}
        FOR I:=1 TO INCR DO BEGIN
        UNITREAD(FromVol,ARR[I],512,BLOCK+I-1,0); {BLOCK BY BLOCK}
        IF IORESULT<>0 THEN BEGIN
           WRITELN('Failed to read from disk in drive ',FromVol,
                   ' Block=',BLOCK+I-1,' IOResult=',IORESULT);
           ERRORS:=ERRORS+1;
        END;
     END;
     UNITWRITE(ToVol,ARR,LGTH,BLOCK,0);
     IF IORESULT<>0 THEN
        {try again - block at a time}
        FOR I:=1 TO INCR DO BEGIN
        UNITWRITE(ToVol,ARR[I],512,BLOCK+I-1,0);
        IF IORESULT<>0 THEN BEGIN
           WRITELN('Failed to write to disk in drive ',ToVol,
                   ' Block=',BLOCK+I-1,' IOResult=',IORESULT);
           ERRORS:=ERRORS+1;
        END;
     END;
     BLOCK:=BLOCK+INCR;
     IF BLOCK>MAX1 THEN BEGIN
        INCR:=MaxBlocks-BLOCK; {PART TRANSFER AT END}
        LGTH:=512*INCR;
     END;
  UNTIL BLOCK=MaxBlocks;
  {$I+}
  
  WRITELN;
  WRITE('Copy Complete');
  IF ERRORS>0 then WRITE('..number of errors detected=',ERRORS);
  WRITELN;
  IF ToVol=4 THEN
    begin
      Line(21);
      SC_Eras_EOS(0,22);
      WRITE('Return the OFFLOAD System Disk to drive #4.');
      REPEAT
        GotoXY(0,23);
      UNTIL NOT Space_Wait(TRUE);
    end;
END;

procedure Disker;
var ch:char;
    terminal:boolean;
    i:integer;
begin
  Terminal:=false;
  xstr:='';
  SC_Clr_Screen;
  Repeat
    SC_Clr_Line(1);
    SC_Clr_Line(0);
    ch:=SC_Prompt('Disk aids: B(ackup-#4 C(opy-#5 N(ew-#5 T(idy H(elp Q(uit:',
                  -1,0,0,0,
                  ['B','C','N','T','H','Q'],
                  FALSE,' ');
    SC_Clr_Screen;
    case ch of
      'B':begin
            writeln;
            writeln('Backup will copy the Off-Load system disk in drive #4');
            writeln('                         to a disk placed in drive #5.');
            writeln;
            write('The operation will take several minutes.   ');
            writeln('Insert a blank disk in drive #5.');
            write('Type <space> to continue, <esc> to abort');
            SC_GetC_Ch(ch,[' ',esc]);
            if ch=' ' then
              begin
                with param do begin
                  if formatstr<>'' then chain(formatstr);
                      {eg, *FORMATDISK PI="FD,Q"}
                  if bootstr<>'' then chain(bootstr);
                      {eg, *BOOTER PI="4,5,,"}
                end;
                xstr:='*FILER PI="T#4,#5,YQ"';
              end;
          end;
      'C':CopyDisk;
      'N':begin
            writeln;
            writeln('New will initialise a blank user disk in drive #5.');
            writeln;
            repeat
              gotoxy(0,3);
              write('Give new volume name (7 characters max.):');
              readln(xstr);
              while pos(' ',xstr)<>0 do delete(xstr,pos(' ',xstr),1);
              i:=pos(':',xstr);
              if i<>0 then delete(xstr,i,(length(xstr)-i)+1);
              if xstr[1]=esc then xstr:='';
            until (length(xstr)=0) or (length(xstr)<=8);
            if length(xstr)>0 then
              begin
                writeln;
                write('The operation will take about one minute.     ');
                writeln('Insert a blank disk in drive #5.');
                write('Type <space> to continue, <esc> to abort');
                SC_GetC_Ch(ch,[' ',esc]);
                if ch=' ' then
                  begin
                    with param do begin
                      if formatstr<>'' then chain(formatstr);
                      xstr:=concat('*FILER PI="Z#5,N',SDiskBlocks,
                                   ',',xstr,':,YQ"');
                    end;
                  end
                else xstr:='';
              end;
          end;
      'T':begin
            writeln;
            write('Tidy will compact unused space on the disks in');
            writeln(' drives #4 and #5.');
            writeln;
            write('Type <space> to continue, <esc> to abort');
            SC_GetC_Ch(ch,[' ',esc]);
            if ch=' ' then xstr:='*FILER PI="K#4,YK#5,YQ"';
          end;
      'H':help('*help.disk');
      'Q':terminal:=true;
    end;
    if (ch<>'H') and (length(xstr)=0) then SC_Clr_Screen;
  until (length(xstr)>0) or (terminal);
end;


procedure Scanner;
var i:integer;
    tempstr:string;
begin
  {To S(can document use T(ransfer from file to CONSOLE: in F(iler }
  SC_Clr_Screen;
  WRITELN;
  WRITELN('Scan will display the document to the screen - it goes quite fast.');
  WRITELN('     You may stop and start the display by using the stop/start');
  WRITELN('     toggle key - ',param.sstoggle);
  WRITELN;
  GotoXY(0,5);
  WRITE('Give name of document to be scanned:');
  READLN(tempstr);
  IF length(tempstr)>0 then
    begin
      if tempstr[1]=ESC then tempstr:='';
    end;
  if length(tempstr)>0 then
    begin
      {check file exists}
      for i:= 1 to length(tempstr) do begin
        if (tempstr[i]>='a') and (tempstr[i]<='z') then
           tempstr[i]:=CHR((ORD(tempstr[i])-ORD('a'))+ORD('A'));
      end;
      if not exists(tempstr,'') then
        begin
          if exists(tempstr,'.TEXT') then tempstr:=concat(tempstr,'.TEXT')
          else
            begin
              tempstr:='';
              WRITELN('File specified cannot be found on disk.');
            end;
        end
      else
        begin
          if (length(tempstr)<6) or
             (pos('.TEXT',tempstr)<>length(tempstr)-4) then
             begin
               tempstr:='';
               WRITELN('File specified is not a Text Document.');
             end;
        end;
      {if tempstr<>'' we have a text file which exists}
      if tempstr<>'' then xstr:=concat('*FILER PI="T',tempstr,',CONSOLE:,Q"');
    end;
end;

procedure Helper;
var ch:char;
    terminal:boolean;
begin
  Terminal:=false;
  SC_Clr_Screen;
  Repeat
    SC_Clr_Line(1);
    ch:=SC_Prompt('Help: C(ommands H(ints K(eystrokes U(tilities Q(uit:',
                  -1,0,0,0,
                  ['C','H','K','U','Q'],
                  FALSE,' ');
    if ch<>'Q' then SC_Clr_Screen;
    case ch of
      'C': help('*Help.Off');
      'H': help('*Help.Hint'); {for any user provided text}
      'K': help('*Help.Keys');
      'U': help('*Help.Util');
      'Q': terminal:=true;
    end;
  until terminal;
end;

begin
  exception(TRUE); {turn off all redirection and chaining to clear buffers}
                   {also prevents a build up of *OFFLOAD calls by user    }
  esc:=chr(27);
  Loadparams;
  sc_clr_screen;
  terminal:=false;
  repeat
     xstr:='';
     sc_clr_line(1); {in case of abortive X(ecute}
     ch:=sc_prompt(concat('Off-Load: E(dit F(ile L(ist P(rose S(can ',
                          'T(ty X(ecute D(iskaids H(elp Q(uit [1.0]'),
                   -1,0, {place cursor at end of prompt}
                    0,0, {place prompt at top of textport}
                    ['E','F','L','P','S','T','D','H','Q','X'],
                    FALSE, {character is being prompted}
                    ' ');  {break ch in prompt is space}
     write(ch);
     case ch of
       'E':xstr:='*EDITOR';
       'F':xstr:='*FILER';
       'L':xstr:='*LIST';
       'P':xstr:='*PROSE';
       'S':Scanner;
       'T':xstr:='*TTY';
       'D':Disker;
       'H':Helper;
       'X':begin
             writeln;
             write('Execute what file:');
             readln(xstr);
             if xstr<>'' then
               begin
                 {now check that the .CODE file exists}
                 {to save return to UCSD outer level}
                 if not exists(xstr,'.CODE') then
                   begin
                     SC_Clr_Line(0);
                     Write(Xstr,' is not an executable file.');
                     repeat
                       SC_Clr_Line(1);
                     until NOT Space_Wait(TRUE);
                     Xstr:='';
                   end;
               end;
           end;
       'Q':terminal:=true;
     end;
  until (terminal) or (xstr<>'');
  if not terminal then
    begin
      chain(xstr);
      Chain('*OFFLOAD');
      sc_clr_screen;
    end
  else chain(param.Quitstr);
end.





========================================================================================
DOCUMENT :usus Folder:VOL12:param.info.text
========================================================================================

LST CHANNEL =6
LST FORMAT  =[A4]
LST OPTIONS =[O12]
PROSE.OUTPUT=(S12)



========================================================================================
DOCUMENT :usus Folder:VOL12:print.heap.text
========================================================================================

program printheap;
(* Noddy program to print a summary of free heap space.
   Could be turned into a routine for use in tuning/debugging
   programs which make intensive use of the heap
   
   Version IV.0 specific*)
   

uses {$U KERNEL.CODE} kernel;

type dummy = array [0..100] of integer;

var
  cur_ptr : mem_ptr;
  avail_ptr : mem_ptr;
  empty : integer;
  junkk1,
  junkk2,
  junkk3,
  junkk4,
  junkk5: ^dummy;

begin
  (*new(junkk1);
  new(junkk2);
  new(junkk3);
  new(junkk4);
  new(junkk5);
  dispose(junkk2);
  dispose(junkk4);
  dispose(junkk3);
  dispose(junkk1);
  dispose(junkk5);*)
  moveleft(emptyheap,empty,2);
  cur_ptr:=heap_info.top_mark;
  writeln;
  writeln('Heap Top = ',heap_info.heap_top.t,' Empty Heap = ',empty);
  while cur_ptr.m <> NIL do begin
    writeln('Heap Mark At - ',cur_ptr.t,' Size - ',cur_ptr.m^.n_words);
    writeln('Last Avail = ',cur_ptr.m^.last_avail.t);
    avail_ptr:=cur_ptr.m^.avail_list;
    while avail_ptr.m <> NIL do begin
      writeln('   Block At - ',avail_ptr.t,' Size - ',avail_ptr.m^.n_words);
      avail_ptr:=avail_ptr.m^.avail_list;
    end;
    cur_ptr:=cur_ptr.m^.prev_mark;
  end;
  writeln;
  writeln('Permanent Heap');
  if permlist.m = NIL then writeln('Null')
  else
    begin
      cur_ptr:=permlist;
      while cur_ptr.m <> NIL do begin
        writeln('Block At - ',cur_ptr.t,' Size - ',cur_ptr.m^.n_words);
        cur_ptr:=cur_ptr.m^.avail_list;
      end;
    end;
end.

========================================================================================
DOCUMENT :usus Folder:VOL12:print.mem.text
========================================================================================

program printmem;
  (* Noddy program for use with Jon Bondy's benchmark
     See USUS News*)
     
  var
    ptr : ^integer;
  begin
    new(ptr); dispose(ptr);
    writeln(memavail ,' words of memory available');
    writeln(varavail('') ,' words really available');
  end.


========================================================================================
DOCUMENT :usus Folder:VOL12:r.analyze.text
========================================================================================

{ ANALYZE:  Analyze and summarize execution time performance measurements
            from an AUGMENTed Pascal program.

        PROGRAM HISTORY:

  S. Matwin and M. Missala, 1975:
    Polish Academy of Sciences Computer Centre, Pkin, Warsaw, Poland.
  
  Modified, Generalized, and Renamed by:
    A. B. Mickel and H. U. Rubenstein, 1977.
    University of Minnesota Computer Center, Minneapolis, MN 55455 USA.
    
  Published in Pascal News, No. 12., 1978 June.
  
  Overhauled for UCSD Pascal and interactive environment by:
    James L. Gagne, September, 1981.
    Datamed Research, Inc., 1433 Roscomare Road, Los Angeles, CA 90077 USA.
    JLG's changes from the PUG version are denoted with empty comment braces.
    
  Patched by George Schreyer,  lines changed noted by gws    Oct 1981
  
  The names and organizations given here must not be deleted in any use of
    this program. (Note added 9/81: this program is not known to be copyright.)
    
Internal documentation:
  
    Analyze reads two files.  Inter2 (UCSD filename is fixed: "AUG.PROCNAMES")
  is the file containing the "module" (procedure/function) names which are used
  when the results are sorted and written out (up to 10 characters only).
  Timing (UCSD filename: "TIMING.DAT") is the file containing the execution
  trace of the program being monitored.  Both files are expected to be on the
  default disk.
  
    Within ANALYZE, the procedure named processbody does the actual analysis
  by determining every time interval:
        time interval = time of exit - time of entry

    Gotoexits were handled specially in the PUG version.  These features have
  been removed from the UCSD version, but for now special provisions for
  the EXIT procedure have not been installed.
}

PROGRAM Analyze;

CONST   AlfaLeng = 10;
        MaxNames = 1000;
        TicksPerSec = 60.0;     {clock increments ("ticks") per second}
        PrinterName = '#8:';    {name of standard printer}

TYPE    Alfa = PACKED ARRAY [1..AlfaLeng] OF Char;
        TagRange = 0..MaxNames;
        Measurement = PACKED RECORD
                        Tag: TagRange;
                        Mark: (Entry, ExitP, GotoEntry);
                        HiTime, LoTime: integer
                      END;
{}      DblInt = RECORD
                   Hi, Lo: integer
                 END;
        Counter = RECORD
                    Count, SubRtnCount: integer;
                    Name: Alfa;
{}                  TimeSpent: Real
                  END;

VAR     MaxTag: TagRange;
{}      LastDot: char;
{}      JustOne, TotalCalls:  DblInt;
        ch: char;
        TotalTime, StartingTime, FudgeFactor: real;
        TimeOverhead: real;       {sec's req'd to write each timing datum}
        Modules:  ARRAY [TagRange] OF Counter;
        Timing:  FILE OF Measurement;
{}      OutFile: text;


PROCEDURE Sort(min, max: tagrange);
{Quicksort with bounded recursion depth, used to alphebatize module names.
 Requires min < max.}
VAR     low, high: integer;
        MidKey: Alfa;
        Temp: Counter;

BEGIN
                       REPEAT        {pick split point}
    MidKey := Modules[(min + max) DIV 2].Name;  low := min;  high := max;
    REPEAT      {partition}
      WHILE Modules[low].Name < MidKey DO low := low + 1;
      WHILE Modules[high].Name > MidKey DO high := high - 1;
      IF low <= high
        THEN BEGIN
          Temp := Modules[low];  Modules[low] := Modules[high];
          Modules[high] := Temp;  low := low + 1;  high := high - 1
        END
    UNTIL low > high;            {recursively sort shorter sub-segment}
    IF high - min < max - low
      THEN BEGIN IF min < high THEN Sort(min,high);  min := low END
      ELSE BEGIN IF low < max THEN Sort(low,max);  max := high END
  UNTIL max <= min
END;


  FUNCTION RealTime: Real;  {convert time to real number}
VAR     Hi, Lo: integer;
BEGIN
  WITH Timing^ DO IF Tag <= 0 THEN Realtime := 0
  ELSE BEGIN
    Hi := HiTime*2;  Lo := LoTime;
    IF Hi < 0 THEN Hi := Hi + 32767 + 1; {throw away sign bit if a carry}
    IF Lo < 0
      THEN BEGIN Lo := Lo + 32767 + 1;  Hi := Hi + 1 END;
    IF Hi < 0 THEN Hi := 0;
    RealTime := Lo + 32768.0 * Hi
  END
END;


PROCEDURE AddDblInt(VAR i1, i2: DblInt);   {add i1 and i2; sum in i1}
VAR     Sum: DblInt;
BEGIN
  WITH Sum DO
    BEGIN
      Hi := i1.Hi + i2.Hi;  Lo := i1.Lo + i2.Lo;
      IF (i1.Hi > 0) AND (i2.Hi > 0) AND (Hi < 0)
        THEN Hi := Hi + 32767 + 1;
      IF (i1.Lo > 0) AND (i2.Lo > 0) AND (Lo < 0)
        THEN BEGIN Lo := Lo + 32765 + 3;  Hi := Hi + 1 END
    END;
  i1 := Sum;
END;


PROCEDURE SubDblInt(VAR i1, i2: DblInt);   {subtract i2 from i1; diffrnc in i1}
VAR     Diff: DblInt;
BEGIN
  WITH Diff DO
    BEGIN
      Hi := i1.Hi - i2.Hi;  Lo := i1.Lo - i2.Lo;
      IF (i1.Hi < 0) AND (i2.Hi < 0) AND (Hi > 0) THEN Hi := Hi + 32767 + 1;
      IF (i1.Lo < 0) AND (i2.Lo < 0) AND (Lo > 0)
        THEN BEGIN Lo := Lo + 32765 + 3;  Hi := Hi - 1 END
    END;
  i1 := Diff
END;


PROCEDURE ProcessBody;
{process timing file of dynamic measurements.}
VAR     ModuleTag: TagRange;
        NoGoto, SameModule: boolean;
        SubCnt: integer;
{}      Temp1, Temp2, ModulTime: Real;

BEGIN
   ModuleTag := Timing^.Tag;  ModulTime := 0.0;  SubCnt := 0;
   Temp1 := RealTime + FudgeFactor;  Get(Timing);
   WHILE (Timing^.Mark = entry) AND (Timing^.Tag > 0) AND NOT EOF(Timing) DO
     BEGIN
{}     Temp2 := RealTime;  ModulTime := ModulTime + Temp2 - Temp1 - FudgeFactor;
{}     ProcessBody;  Temp1 := RealTime;  SubCnt := SubCnt + 1;
{}     NoGoto := Timing^.Mark <> GotoEntry;
{}     SameModule := Timing^.Tag = ModuleTag;
{gws}  {IF SameModule OR NoGoto THEN} Get(timing);
     END;
{} Temp2 := RealTime;  ModulTime := ModulTime + Temp2 - Temp1;
{} AddDblInt(TotalCalls,JustOne);
{} IF TotalCalls.Lo MOD 50 = 0 THEN Write('.');
{} IF TotalCalls.Lo MOD 2500 = 0 THEN Writeln;
   WITH Modules[ModuleTag] DO
     BEGIN
       Count := Count + 1;  TimeSpent := TimeSpent + ModulTime;
       SubRtnCount := SubRtnCount + SubCnt;
     END
END;


PROCEDURE Initialize;           {initialization placed here: JLG}
VAR     Tag: TagRange;
        i: integer;
        s: string;
        Inter2: FILE OF Alfa;
BEGIN
{} Writeln('Welcome to ANALYZE, the program timing analyzer.');  Writeln;
{} Writeln(
'     You should be using this program only after having run Pascal source');
{} Writeln(
'text through AUGMENT to add the time-keeping function, then compiled and run');
{} Writeln(
'the new program.  The data files AUG.PROCNAMES and TIMING.DAT must both be');
{} Writeln(
'on the default disk, or the program will die.');  Writeln;
{} Reset(Inter2, 'AUG.PROCNAMES');  Reset(Timing,'TIMING.DAT');
  IF EOF(Timing)
{}  THEN BEGIN Writeln('*FATAL ERROR* timing file empty');  Exit(Program) END;
{} Writeln(
'Please enter the destination of the timing analysis (<ret> for printer):');
{} Write('--> ':12);  Readln(s);
{} WHILE POS(' ',s) > 0 DO DELETE(s,POS(' ',s),1);
{} FOR i := 1 TO Length(s) DO
         
{} IF s[i] IN ['a'..'z'] THEN s[i] := CHR(ORD(s[i]) + ORD('A') - ORD('a'));
{} IF s = '' THEN s := PrinterName
{}   ELSE IF POS('.TEXT',s) = 0 THEN s := CONCAT(s,'.TEXT');
  Rewrite(OutFile, s);  Tag := 1;
  WHILE NOT EOF(Inter2) DO
    BEGIN
      WITH Modules[Tag] DO
        BEGIN
          Name := Inter2^;  Get(Inter2);  Count := 0;  SubRtnCount := 0;
          TimeSpent := 0.0
        END;
      Tag := Tag + 1
    END;
  MaxTag := Tag - 1;
{} Writeln (MaxTag,' module names found.');
{} Writeln(
'The timing process slows down actual program execution because of the');
{} Writeln('overhead required to record timing information.');
{} Writeln(
      'Please enter the avg # of milliseconds overhead per timing datum: ');
{} Readln(TimeOverhead);  FudgeFactor := TimeOverhead * TicksPerSec / 1000.0;
{} TotalCalls.Hi := 0;  TotalCalls.Lo := 0;
{} JustOne.Hi := 0;  JustOne.Lo := 1;  StartingTime := RealTime;
{} Writeln('Reading timing data (one dot = 100 entries):');  Writeln;
END;


PROCEDURE PrintResults;  {all output pulled into this procedure: JLG}
{ procedure overhauled 15 Nov 81}
VAR     Tag: TagRange;
        i, j: integer;
        TCalls, TSpent, PerCent, MSCnvt: Real;
BEGIN
  Writeln(OutFile,' ':9,'Performance Measurement Summary for Pascal Program:  ',
                  Modules[1].Name);
  Writeln(Outfile, ' ':9, '(Assumes ',
              TimeOverhead:5:2, ' milliseconds of overhead per time measure)');
  Writeln(OutFile);
  Writeln(OutFile,'execution time':69);
  Writeln(OutFile,'calls':31, '(msec)':40, '(sec)':9);
  Writeln(OutFile,'module':9, 'times':9, 'percent':11,'subroutine':14,
                  'average':12, 'module':10, 'percent':11);
  Writeln(OutFile,'name':8, 'called':11, 'of total':11, 'calls':11,
                  'per call':15, 'total':8, 'of total': 13);
  Writeln(OutFile,' ----------', '------':8, '--------':11,'------':11,
                  '--------':15, '------':9, '--------':12);
  MSCnvt := 1000.0 / TicksPerSec;    {millisec per 60hz clock tick}
  TCalls := 1.0 + TotalCalls.Lo - 1.0 + (32768.0 * TotalCalls.Hi);
  TotalTime := 0.0;
  FOR Tag := 1 TO MaxTag DO WITH Modules[Tag] DO IF Count > 0
    THEN IF TimeSpent < 0.0
      THEN TimeSpent := 0.0 ELSE TotalTime := TotalTime + TimeSpent;
  IF TotalCalls.Lo + TotalCalls.Hi = 0
    THEN Writeln(Outfile,'Program did not execute; no timing data.')
  ELSE FOR Tag := 1 TO MaxTag DO WITH Modules[Tag] DO
    BEGIN
      PerCent := (Count / TCalls) * 100.0;
      Write(OutFile,Name:11, Count:8);
      IF Count = 0
        THEN Writeln(Outfile,'-----':11, '-----':11,
                             '-----':15, '-----':9, '-----':12)
        ELSE BEGIN
          Write(Outfile, PerCent:11:3, SubRtnCount:11);
          Write(OutFile,((TimeSpent/Count)*MSCnvt):15:2,
                        TimeSpent/TicksPerSec:9:3);
          IF TotalTime = 0 THEN Writeln(OutFile,'-----':12)
            ELSE Writeln(OutFile,((TimeSpent / TotalTime) *100.0):12:3)
        END
    END;
  Writeln(OutFile,' ==========', '======':8, '========':11, '======':11,
                  '========':15, '======':9, '========':12);
  Writeln(OutFile,'TOTALS':9, TCalls:10:1, '100.000':11,
    ((TotalTime/TCalls)*MSCnvt):26:2, TotalTime/TicksPerSec:9:3, '100.000':12)
END;


BEGIN {program}
  Initialize;  ProcessBody;
  IF MaxTag > 1
    THEN BEGIN
      Writeln(CHR(7));
      Write('Do you want your report alphabetized by procedure name (Y/N)?  ');
      REPEAT READ(ch) UNTIL (ch IN ['y','Y','n','N']);  Writeln;
      IF (ch IN ['y','Y']) THEN Sort(1, MaxTag)
    END;
  PrintResults;  Close(OutFile, LOCK);
END.


========================================================================================
DOCUMENT :usus Folder:VOL12:startup.text
========================================================================================

(*$S+*)
(*$C Copyright (c) 1982 Great Western Software  all rights reserved*)

(* This is a startup program which will run under version IV.0 only.
   It uses KERNEL to access SYSCOMREC where great and wonderous things
   can be done.  KERNEL is distributed as KERNEL.CODE with the IV.0 
   system.
   
   The program allows you to set the date just like with the F(iler,
   preset the prefix (with the help of COMMANDIO) and displays a somewhat
   silly salutation message.  The message is H-19 dependant as it uses
   the graphics character set of the H-19.
   
   Install this program as SYSTEM.STARTUP and you're in business.
   
   George Schreyer
   
*)
   
program put_date;
uses kernel, commandio;
const prompt_line = 21;

type date_string = string [ 10 ];
     
var  datex      : daterec;
     x,y : integer;
     day_string,
     month_string,
     year_string : string;
     temp_date,date       : string;
     iday,
     imonth,
     iyear      : integer;
     k          : integer;
     file_length: integer;
     dirx       : directory;
     dum_buff   : packed array [ 0..23 ] of char;
       {this array fills up 24 bytes of memory just above the allocation
        for dirx so that the blockread of exactly four blocks will not
        overwrite something important.}
     disk       : file;
     done,quit       : boolean;
     volid : string;
     
procedure eeol;
begin
  with syscom^ do
     begin
        if crtctrl.prefixed[2] then write ( crtinfo.prefix );
        write ( crtctrl.eraseeol );
     end;
end;

procedure eeos;
begin
  with syscom^ do
     begin
        if crtctrl.prefixed[3] then write ( crtinfo.prefix );
        write ( crtctrl.eraseeos );
     end;
end;

procedure get_date (var date : daterec );
begin
   date := thedate;
end;

procedure p_date (date : daterec  );
begin
 thedate := date;
end;

procedure int_to_str ( number : integer;
                     var strg : string );
var ch : char;
    neg : boolean;
    i : integer;
begin
   strg := '00000';
   neg := false;
   if number < 0 then
      begin
         neg := true;
         number := number * ( -1 );
      end;
   for i := 1 to 5 do
      begin
         ch := chr ( ( number mod 10 ) + ( ord ( '0' ) ) );
         number := number div 10;
         strg [ 6 - i ] := ch;
      end;
   while pos( '0', strg ) = 1 do delete ( strg, 1, 1 );
   if strg = '' then strg := '0'
   else if neg then strg := concat ( '-',strg );
end;

procedure decode_date(day,month,year:integer);
   begin
    case month of
      1: month_string:='Jan';
      2: month_string:='Feb';
      3: month_string:='Mar';
      4: month_string:='Apr';
      5: month_string:='May';
      6: month_string:='Jun';
      7: month_string:='Jul';
      8: month_string:='Aug';
      9: month_string:='Sep';
      10:month_string:='Oct';
      11:month_string:='Nov';
      12:month_string:='Dec'
    end;
    daystring := '';
    yearstring := '';
    int_to_str(day,daystring);
    int_to_str(year,yearstring);
 end;

procedure str_to_int( var data : string;
                    var number : integer;
                    var was_integer: boolean);
{converts input string to a positive integer}
var i : integer;

begin
   was_integer := true;
   number := 0;
   i := 0;
   if data <> '' then
      repeat
           i := i + 1;
           if data [i] in ['0'..'9'] then
              number := 10 * number + (ord(data[i]) - ord('0'))
           else was_integer := false;
      until ( not was_integer ) or ( i = length(data))
   else was_integer := false;
end;

procedure check_month ( month_string : string;
                        var month    : integer );
var i : integer;
begin
   month := 0;
   if length ( month_string ) > 0 then
      begin
         for i := 1 to length ( month_string ) do
           if month_string [ i ] in [ 'a'..'z' ] then
              month_string [ i ] := chr ( ord ( month_string [ i ] ) - 32 );
         if month_string = 'JAN' then month := 1;
         if month_string = 'FEB' then month := 2;
         if month_string = 'MAR' then month := 3;
         if month_string = 'APR' then month := 4;
         if month_string = 'MAY' then month := 5;
         if month_string = 'JUN' then month := 6;
         if month_string = 'JUL' then month := 7;
         if month_string = 'AUG' then month := 8;
         if month_string = 'SEP' then month := 9;
         if month_string = 'OCT' then month := 10;
         if month_string = 'NOV' then month := 11;
         if month_string = 'DEC' then month := 12;
      end;
end;
              
procedure space_wait;
var ch : char;
begin
   write ( ' <space> to continue ' );
   repeat
      read ( keyboard, ch );
   until ( ch = ' ' ) and ( not eoln ( keyboard ) );
   gotoxy ( 0, prompt_line + 1 );
   eeol;
end;

function take_apart_date ( var date    : date_string;
                            var day     : integer;
                            var month   : integer;
                            var year    : integer ): boolean;
var i : integer;
    day_ok, month_ok, year_ok : boolean;
    temp : string [ 1 ];

begin
   year_ok := true;
   day_ok := true;
   monthok := true;
   take_apart_date := true;
   day_string := '';
   month_string := '';
   year_string := '';
   temp := ' ';
   i := 1;
   repeat
      temp [ 1 ] := date [ i ];
      if i in [ 1, 2 ] then
         begin
            if ( i = 2 ) and 
               ( not ( ord ( temp [ 1 ] ) in 
                  [ ord ( '0' )..ord ( '9' ) ] ) ) then
               begin
                  day_string := concat ( '0', day_string );
                  date := concat ( '0', date );
               end
            else
               day_string := concat ( day_string, temp );
         end;
      if i in [ 4, 5, 6 ] then
         month_string := concat ( month_string , temp );
      if i in [ 8, 9, 10 ] then 
         year_string := concat ( year_string, temp );
      i := succ ( i );
   until i > length ( date );
   if length ( day_string ) > 0 then
      str_to_int ( day_string, day, day_ok );
   if ( day_ok ) and ( day in [ 1..31 ] ) then
      begin
         if length ( month_string ) > 0 then 
            check_month ( month_string, month );
         if month in [ 1..12 ] then
            begin
               if length ( year_string ) > 0 then
                  str_to_int ( year_string, year, year_ok );
               if ( not ( year in [ 0..99 ] ) ) or
                  ( not year_ok ) then 
                  begin
                     write ( 'year invalid ' );
                     space_wait;
                     take_apart_date := false;
                     date := '';
                     year := 100;
                  end;
            end
         else  
            begin
               write ( ' month invalid ' );
               space_wait;
               take_apart_date := false;
               date := '';
               month := 0;
            end;
      end
   else
      begin
         write ( 'day invalid ' );
         space_wait;
         take_apart_date := false;
         date := '';
         day := 0;
      end;
end;

procedure banner;  {just a silly message using H-19 graphics,
                        delete this whole procedure or write your
                        own if you don't have an H-19}

PROCEDURE FINISH;
BEGIN
GOTOXY( x + 16, y + 3 );
WRITE('W e l c o m e');
GOTOXY( x + 21, y + 5 );
WRITE('t o');
GOTOXY( x + 10, y + 7 );
WRITE('George''s Computer Center');
GOTOXY( x , y + 12 );
WRITE('UCSD Pascal p-system version IV.01 presiding');
END;

procedure write_a ( x, y, n : integer );
var j : integer;
begin
   gotoxy ( x, y );
   for j := 1 to n do write ( 'a' );
end;

procedure write_bar ( x, y, n : integer );
var j : integer;
begin
gotoxy ( x, y );
for j := 1 to n do 
   begin
      write ( chr ( 96 ), chr ( 10 ), chr ( 8 ) );
   end;
end;

BEGIN
WRITELN(CHR(27),'t');  {sets keypad shifted mode}
WRITELN(CHR(27),'x5'); 
WRITELN(CHR(27),'F');
x := 17;
y := 3;
gotoxy ( x, y );
write ( 'f' );
write_a ( x + 1, y, 42 );
write ( 'c' );
gotoxy ( x + 2, y + 1 );
write ( 'f' );
write_a ( x + 3, y + 1, 38 );
write ( 'c' );
write_a ( x + 1, y + 10, 42 );
write ( 'd' );
write_a ( x + 3, y + 9, 38 );
write ( 'd' );
write_bar ( x, y + 1, 9 );
write ( 'e' );
write_bar ( x + 2, y + 2, 7 );
write ( 'e' );
write_bar ( x + 43, y + 1, 9 );
write_bar ( x + 41, y + 2, 7 );
WRITE(CHR(27),'G');
FINISH;
WRITE(CHR(27),'y5');
volid := '#5';
done := redirect ( concat ( 'P=',volid ) );
gotoxy ( x + 15 , y + 14 );
write ( 'Prefix is ', volid, ':' );
END;

procedure write_date_to_disk;
begin
   reset ( disk, '*' );
   k := blockread ( disk, dirx, 4, 2 );
   dirx[0].dlastboot := datex;
   k := blockwrite ( disk, dirx, 4, 2 );
   close ( disk, lock );
end;

begin
   gotoxy ( 0, 0 );
   eeos;
   banner;
   quit := false;
   file_length := 0;
   get_date ( datex );
   with datex do
      begin
         iday := day;
         imonth := month;
         iyear := year;
         decode_date ( iday, imonth, iyear );
      end;
   date := concat ( day_string, '-', month_string, '-', year_string );
   if pos ( '-', date ) = 2 then date := concat ( '0', date );
   with datex do
      begin
         if not take_apart_date ( date, iday, imonth, iyear ) then
            begin
               write ( 'date in memory invalid' );
               exit ( program );
            end;
         gotoxy ( 0,prompt_line -1 );
         writeln ( 'Today is ', date );
         write ( imonth, '  ', iday, '  ', iyear );
         repeat
            gotoxy ( 0, prompt_line );
            eeol;
            write ( 'New date ? ' );
            readln ( temp_date );
            if length ( temp_date ) = 0 then exit ( program );
            if take_apart_date ( temp_date, iday, imonth, iyear ) then
               begin
                  day := iday;
                  month := imonth;
                  year := iyear;
                  p_date ( datex );
                  quit := true;
                  write_date_to_disk;
               end;
         until quit;
      end;
end.



========================================================================================
DOCUMENT :usus Folder:VOL12:vol12.doc.text
========================================================================================

                         Volume 12 of the USUS Library
                 Contributions from the UK and some other stuff
         A lot of these programs require version IV.0 or timer support

WINDOWS.TEXT      20  A screen window unit.  Slow but nice.  Needs IV.0. 
W.SEGS.TEXT       28    an include file
W.IO.TEXT         20    ditto
W.IMPLN.TEXT      32    ditto
WFILER.TEXT       26  A demonstration program for WINDOWS.  Acts like the Filer 
W.DOC.TEXT        22  Documentation for WINDOWS.
OFFLOAD.TEXT      24  A command line interpreter which replaces the USCD c
                        command prompt.  Needs IV.0
OFF.INFO.TEXT      4     an include file for OFFLOAD
OFF.START.TEXT     8     ditto
OFF.READ.TEXT      8     instructions for using OFFLOAD
OFF.DOC.TEXT      26  Documentation for OFFLOAD
HELP.DISK.TEXT     4  A help file for OFFLOAD
HELP.KEYS.TEXT     4     ditto
HELP.OFF.TEXT      4     ditto
HELP.UTIL.TEXT     6     ditto
NEW.PAGE.TEXT      4  A data file for OFFLOAD
NEW.TEXT           4     ditto
PARAM.INFO.TEXT    4     ditto 
MAKE.PAGE.TEXT     4  A utility for OFFLOAD
PRINT.MEM.TEXT     4  Part of the benchmarks.  Displays memory available.
PRINT.HEAP.TEXT    6  Analyzes heap usage.  Needs IV.0 and timer support.
BENCH.USUS.TEXT   22  Jon Bondy's benchmark with some added goodies.
BENCH.PCW.TEXT    12  Personal Computer World benchmark.  Needs timer support.
BENCH.SWAP.TEXT    4  Segment swap benchmark.  Needs IV.0 and timer support.
BENCH.BYTE.TEXT    6  The infamous Byte benchmark
CPROC.TEXT        16  Another command line interpreter.  Needs IV.0
CONTENTS.TEXT     10  More info about the stuff from the UK
VOLS.SMAC          4  Data for CPROC
STARTUP.TEXT      20  A startup program which sets the prefix and date.
AUGMENT.TEXT      42  A program which adds timing info to a Pascal source 
                         file so that timing data can be obtained.  
ANALYZE.TEXT      24  Analyzes the results of AUGMENT.  Needs timer support.
R.ANALYZE.TEXT    24  Ditto except uses reals.
DISK_COPY.TEXT     8  A disk copy and verification program.
LMFORMAT.TEXT     18  A simple Pascal source formatter.
VOL12.DOC.TEXT     8  You're reading it.
35/35 files<listed/in-dir>, 492 blocks used, 2 unused, 2 in largest

     
Please transfer the text below to a disk label if you copy this volume.

    USUS Volume 12 -***- USUS Software Library
                         
   For not-for-profit use by USUS members only.
  May be used and distributed only according to 
      stated policy and the author's wishes.



This volume was assembled by George Schreyer from material collected by
the Library committee.

__________________________________________________________________________

Some notes from the editor:

                                The WINDOW unit

     Austin Tate of USUS(UK) sent us this window manager unit.  It is well 
documented and it works pretty well if not a little slowly.  The demo program 
which (sort of) acts like the F(iler has a few problems, but it gets the point 
across.  You MUST have version IV.0 for this stuff to work.

                                    OFFLOAD

     Many business systems don't need the UCSD command prompt (after all, how 
much A(ssembling does a retailer do anyway?).  OFFLOAD shows how the standard 
prompt can be supressed and replaced by custom command prompts which do more 
closely what is necessary in a given application.  I found the documentation
on how to set up some of the cryptic data files somewhat lacking, but I got 
most of it to work.

                                   BENCHMARKS

     There are copies of some benchmark programs on this disk.  It would be 
nice if we could collect data taken from many systems to see how well each 
works, but alas, even the benchmarks are not standardized.  The infamous Byte 
benchmark is so prone to "tuning" that its data is almost meaningless.  This 
version has range checking disabled.  Some of the other benchmarks require 
IV.0 or timer support so that many systems cannot run them.  The "USUS" 
benchmark (by Jon Bondy) has been augmented with several new tests and 
requires only a stopwatch.

                              AUGMENT and ANALYZE
 
     These programs allow you to which part of your program is taking so much 
time, as if you didn't know already.  AUGMENT processes your source and 
inserts instructions at the beginning and end of each procedure to cause your 
program to time itself.  ANALYZE then processes the timing information and 
displays a report of how many times each procedure was accessed and how long 
it took.  You need timer support.  The program has been extensively hacked
by myself and Jim Gagne and still doesn't support units but at least now it 
handles (ugh) GOTO's and EXIT's and include files.  To get valid timing data 
you may find it necessary to separate user interface and data crunching into
separate routines, which you really should do anyway.

                                   DISK_COPY

     I copy USUS disks with this program and it hasn't failed me yet.  It 
reads a buffer full and then writes the buffer to disk.  It then re-reads the 
destination disk to see if the data is correct.  It won't correct for a bad 
master disk unless there is a CRC error nor will it discover some occurances 
of bad memory but it catches almost all of the typical problems (new disks are 
getting worse and worse, even "good" brands will have bad blocks right out of 
the box).

                                     CPROC

     I couldn't get this to work, it immediatly crashes my system (trap to 
location 4 on an LSI-11/23) when it is executed, but I suspect my IV.0 system 
as it has a tendency to crash.

                                    STARTUP

     This is a startup program which allows the prefix and date to be set.  It 
is IV.0 specific.  There is a II.0 version on volume 13.

                                    LMFORMAT

     This program processes a Pascal source file and translates everything to 
lower case EXCEPT reserved words.  It makes things look a little nicer.

     
     regards - george schreyer


========================================================================================
DOCUMENT :usus Folder:VOL12:vols.smac
========================================================================================

fv

========================================================================================
DOCUMENT :usus Folder:VOL12:w.doc.text
========================================================================================

This document describes an early version of the Window Manager and Window
Filer (March 1981).  At the end is a note of the Window Functions available
in the most recent version (February 1982).

__________________________________________________________________________

A note by the reviewer:

     The window manager unit uses SEGMENT procedures WITHIN a UNIT which is
forbidden in UCSD version II.0.  You MUST use version IV.0 or another version
which allows this construct to even compile the window manager.

     A UNIT, ScreenOps, is used by the window manager.  Your version IV.0
system came with a file, ScreenOps.code, which you should install in your
SYSTEM.LIBRARY before WINDOWS is compiled.   - gws
__________________________________________________________________________

~A Window Manager for the UCSD p-System~

                                        Austin Tate
                                        Microcomputer Support Unit
                                        Edinburgh Regional Computing Centre
                                        


1.  ~Introduction~

     There has been a great deal of interest recently in the use of
computer displays which allow a screen to be divided into a number of
separate areas or 'windows' such as are used in the Xerox environment
(Alto, 1979). Examples of software environments based on the Alto using
windows include Smalltalk (a summary of several environments is given
in Goldberg, 1979) and the Lisp Programmer's Assistant (Teitelman,
1977). In these systems, separate windows are often 'attached' to
separate, possibly concurrent, processes.

     As part of the development of course materials for a series of
seminars on Electronic Office Systems, the author has developed a
demonstration Window Manager package for the portable UCSD p-System for
microcomputers (Softech).  Although the hardware on which this system
is being used is too slow for this software to be used in a production
environment it does provide a realistic demonstration of the types of
facilities we can expect to be available on future personal computers.
For example, the Three Rivers Computer Corporation's 'PERQ' computer
(Three Rivers) includes a 'Raster Op' microcoded instruction to
facilitate various windows on the screen.

     The window manager package has been used in a demonstration
program which provides some of the facilities of the UCSD Filer
utility.


2.  ~Structure of the Package~

     The Window Manager is written as a UCSD Pascal Unit.  A Unit
provides a publically available set of constants, variables,
procedures, etc. and gives implementation details of how these
'interfaces' are provided. The listing of the window manager interface
section is provided in Appendix I.

     The structure of the implementation relies heavily on an internal
data structure for individual windows not visible to the user.  This
includes the following items:

     a) position of top left corner of window in screen coordinates

     b) size of window in horizontal and vertical directions

     c) position of current input or output portion in the window in
        window coordinates (i.e. position of ~this~ windows' cursor).

     d) a data structure for lines of text in the window.   These are
        allocated from a heap of lines.

     e) a list structure pointer to show order in which windows were
        displayed to ensure they currectly overlap if moved, killed,
        etc.

     f) flags to show various characteristics of the window.   E.g. if
        horizontal scrolling is allowed, whether the window has a
        'heading' line, etc.

     Given this data structure and a carefully chosen interface, the
package itself is straightforward to write.  The actual implementation
and testing took less than 40 man/hours.  The Window Manager is about
1000 lines of commented Pascal code.  It is straightforward to build
the implementation gradually providing the more estoteric procedures
later.


3.  ~Window Frames~

     Due to the different capabilities of video displays, it was found
desirable to write the Window Manager in such a way that window frames
were handled in a separately implemented Unit.  The interface section
for this FRAMES unit is provided in Appendix II.  A straightforward,
but rather unimpressive looking, character framing capability is
possible on normal character displays.  However, where graphics
facilities can be used, e.g. on the Terak 8510a microcomputer (Terak),
these can be exploited to provide quite impressive looking frames and
header backgrounds.  The Terak frames package was generated in a few
hours by Ken Currie of ERCC. The frame unit for the Terak is
approximately 120 lines of commented Pascal code.

4.  ~The 'Window' Filer~

     The Window Filer is a demonstration utility which provides a
subset of the facilities available in the UCSD p-System Filer
component.

     It employs the window manager package for all input and output. It
was generated in a few hours by adding simple window initialisation
code and altering the (already localised) input and output instruction
in on existing program which provided the subset of UCSD filer
facilities.
              
     There are facilities to view the volumes on-line or the
directories of floppy disk volumes in brief or detailed forms, to
remove files from disk, to create text files on disk, to view the
system date, etc.  Displays are created in separate areas of the screen
known as 'windows'.

     The window filer is entered by X(executing) WFILER at the UCSD
command (outer) level.
     
     Several standard windows will appear.  A 'message' window at the
top of the screen where prompts to a user will normally appear, a list
of commands and a 'typescript' window in which user input is normally
solicited.  There is a 'window cursor' (@ sign) on the screen
(initially in the centre of the screen.

     The system expects a single character command as detailed in the
commands list (e.g.  "V" to get a list of volumes on-line).

     At any time, the four cursor control (arrowed) keyed can be used
to move the window cursor to a new position.  In addition, CTRL/0 (for
"Over") can be used to bring the window area in which the window cursor
currently resides into full view. Windows may be M(oved) and K(illed)
within WFILER.

     The use of screen windows to simulate moving sheets of paper on a
desk to access information needed for some work can be shown by using a
(create file) function.  While input is being typed to a file, the
window manager can be directed to bring windows of interest on top.

5.  ~Availability~

     The window manager unit is not considered to be a potential tool
at present.  However, for demonstration purposes it is being submitted
to the UCSD p-System Users Society Software Library.  If it passes the
relevant review procedure it will subsequently become available to
members of USUS.

6.  ~References~

     Alto          Thacker, C.P., McGeight, E.M., Lampson, B.W.,
                   Sproull, R.F. and Boggs, D.R. (1979)
                   Alto: a personal computer.  In Siewiorek, D.,
                   Bell, C.G., and Newell, A., Computer Structures,
                   Readings and Examples. Second Edition, McGraw-Hill.

     Goldberg      Goldberg, A. (1979) Educational uses of a Dynabook.
                   Computers and Education Vol.8 pp 247-266.
                   
     Softech       UCSD p-System User's Manual.  Softech Microsystems Inc.
                   9494, Black Mountain Road, San Diego, California 92126.

     Teitelman     Teitelman, W. (1977) A display oriented programmer's
                   assistant.  Proceedings of the 5th International Joint
                   Conference on Artificial Intelligence, pp 905-915.
     
     Terak         Terak 8510/a brochure. Terak Corporation,
                   14151, North 76th Street, Scottsdale, Arizona 85260.
     
     Three Rivers  PERQ brochure. Three Rivers Computer Corporation.
                   160, North Craig Street, Pittsburg, Pennsylvania 15213.
     

Current Release - Window Manager Functions
------------------------------------------
Enter Window Manager Mode using ESC.
In this mode you can type:
ESC or <space> to leave this Mode or
       to make a 'mark'
<arrow keys> move cursor
1..9   move cursor over screen
S(how  window under cursor
K(ill  window under cursor
H(ide  window under cursor
M(ove  window under cursor to 'mark'
A(lter window under cursor to fit
within next two 'marks'
?      give this help window


========================================================================================
DOCUMENT :usus Folder:VOL12:w.impln.text
========================================================================================

{w.impln - Implementation part of Window Manager}
{Copyright 22-Feb-82 Austin Tate, ERCC}

  USES  SCREENOPS;
  
  CONST CONSOLE=1;
        SYSTERM=2;
        MaxLine=72;     {<<<<< reduce this if you have stack overflow problems}
        ScreenWidth=78;
        XScreenWidth=79;
        ScreenHeight=24;
        Bel=7;
        Bs=8;
        Cr=13;
        {for bottom corners, if quote slopes on your VDU,}
        {a reasonable alternative is +                   }
        TLChr='.';TRChr='.';BLChr='''';BRChr='''';
        TEChr='_';REChr='|';LEChr='|';BEChr='-';

  TYPE  ScreenPos=0..255;
        LineId=0..MaxLine;
    
  {all cursor values have a base of 0}
  
    WFormat=PACKED RECORD
      CurrY,CurrX:ScreenPos;   {cursor position for this window}
                               {scroll when CurrY is incremented to SizeY}
                               {Cursor sits at position of NEXT ch output}
                               {to the window will be written}
      SizeY,SizeX:ScreenPos;   {Size of window - 1 to N}
      StartLine:LineId;        {index to first line of text in window}
                               {window always has 1 line minimum, 2 if headed}
      AtX,AtY:ScreenPos;       {top left corner of window}
      CurrPan,OldPan:ScreenPos;{amount window 'panned' by}
      OldSizeY,OldSizeX,
      OldAtY,OldAtX:ScreenPos;
      Cleared:BOOLEAN;
      Options:WindowAttributes;{what user can do, does it have a heading}
      OldPrevWindow,
      PrevWindow:Window;       {index to window array to give the previous}
                               {window in show order - NoWindow at end}
                               {Also used prechained to hold free window list}
  END;
  
  LINEREC=RECORD
      Contents:STRING[ScreenWidth];
      NextLine:LineId;
  END;
  
VAR
  OldXMin,OldXMax,
  CurrLine,
  OldWSequence,
  WSequence:INTEGER; {Start of list of shown windows - last shown at head}
                     {NoWindow at end}
  FreeLine,FreeWindow:INTEGER;
                     {Free lists - 0 at end of line list}
                     {             NoWindow at end of window list}
  WX,WY:INTEGER;     {Current Window Manager Cursor Coords - screen coord}
  RealX,RealY:INTEGER;{Actual Cursor Position - -ve implies not known}
  
  WCursPlaced:BOOLEAN;{true if window cursor is on the screen}
  ScreenValid:BOOLEAN;{true if no Hides or Shows since last RePaint}
  
  WCursor:CHAR;      {window manager cursor character}
  SCursBuff:CHAR;    {Character underneath the Window Cursor position}
  SCursIn:Window;    {Window in which cursor currently resides}
  
  Windows:ARRAY [1..MaxWindow] OF WFormat;
  
  Lines:ARRAY[1..MaxLine] OF LineRec;
  ClearLine:STRING[ScreenWidth]; {line containing spaces for clearances,etc}

{all forward declarations needed for Window Manager}

PROCEDURE SaveSequence; FORWARD;

PROCEDURE PlaceCursor; FORWARD;

PROCEDURE RemoveCursor; FORWARD;

PROCEDURE FGOTOXY(X,Y:INTEGER); FORWARD;

{$I w.segs}
{end of SEGMENT PROCEDURES}

PROCEDURE SaveSequence;
VAR WTemp:Window;
BEGIN
  WTemp:=WSequence;
  OldWsequence:=WSequence;
  WHILE (WTemp<>NoWindow) DO BEGIN
    WITH Windows[WTemp] DO BEGIN
      OldAtX:=AtX;
      OldAtY:=AtY;
      OldSizeX:=SizeX;
      OldSizeY:=SizeY;
      OldPan:=CurrPan;
      OldPrevWindow:=PrevWindow;
      Cleared:=FALSE;
      WTemp:=Windows[WTemp].PrevWindow;
    END;
  END;
END;

PROCEDURE WStartUp;
BEGIN
  WMStartUp;
END;

PROCEDURE WInit;
BEGIN
  WMInit;
END;

FUNCTION WNew{(WatX,WatY,WSizeX,WSizeY:INTEGER;
               WControls:WindowAttributes;
               WHeading:STRING):Window}; {Get new window}
VAR W:Window;
    Offset,Top,i:INTEGER;
BEGIN
  IF (FreeWindow=NoWindow) OR (FreeLine=0) OR
     ((HasHeading IN WControls) AND (WSizeY=1)) OR
     (WSizeY<1) OR (WSizeX<1) OR
     (WatY<0) OR (WatY>=ScreenHeight) OR
     (WatX<0) OR (WatX>=ScreenWidth) THEN 
    WNew:=NoWindow
  ELSE BEGIN
    W:=FreeWindow;
    FreeWindow:=Windows[FreeWindow].PrevWindow;
    WITH Windows[W] DO BEGIN
      IF WSizeX>ScreenWidth THEN SizeX:=ScreenWidth ELSE SizeX:=WSizeX;
      IF WSizeY>ScreenHeight THEN SizeY:=ScreenHeight ELSE SizeY:=WSizeY;
      AtX:=WatX; AtY:=WatY;
      {Move so whole window on screen if necessary}
      IF AtX+SizeX>ScreenWidth THEN AtX:=ScreenWidth-SizeX;
      IF AtY+SizeY>ScreenHeight THEN AtY:=ScreenHeight-SizeY;
      CurrX:=0; CurrY:=0; CurrPan:=0;
      PrevWindow:=NoWindow;
      {Get one blank line for initial text buffer}
      StartLine:=FreeLine;
      FreeLine:=Lines[FreeLine].NextLine;
      Lines[Startline].NextLine:=0; {end of chain}
      Lines[StartLine].Contents:=ClearLine;
      Options:=WControls-[HasHeading];
      IF (HasHeading IN WControls) AND (WHeading<>'') AND 
         (FreeLine<>0) AND (SizeY>1) THEN BEGIN
        Options:=Options+[HasHeading];
        CurrY:=1;
        {Get line for Heading - chain on front of first text line}
        i:=FreeLine;
        FreeLine:=Lines[FreeLine].NextLine;
        Lines[i].NextLine:=StartLine;
        StartLine:=i;
        WITH Lines[StartLine] DO BEGIN
          Contents:=ClearLine;
          IF CanPan IN Options THEN Offset:=1 ELSE Offset:=0;
          Top:=LENGTH(WHeading);
          IF Top>(ScreenWidth-Offset) THEN Top:=ScreenWidth-Offset;
          FOR i:=1 TO Top DO Contents[Offset+i]:=WHeading[i];
        END;
      END;
    END;
    WNew:=W;
  END;
END;
               
PROCEDURE AddToFree(LineNo:INTEGER);
          {restore to Free Line List all lines chained to LineNo}
VAR Next,i:INTEGER;
BEGIN
  Next:=LineNo;
  WHILE Next<>0 DO BEGIN
    i:=Lines[Next].NextLine;
    Lines[Next].NextLine:=FreeLine;
    FreeLine:=Next;
    Next:=i;
  END;
END;

FUNCTION InShow(W:Window):BOOLEAN;
VAR WTemp:Window;
    Seen:BOOLEAN;
BEGIN
  WTemp:=WSequence;
  Seen:=FALSE;
  WHILE (WTemp<>NoWindow) AND NOT Seen DO BEGIN
    Seen:=(WTemp=W);
    WTemp:=Windows[WTemp].PrevWindow;
  END;
  InShow:=Seen;
END;

PROCEDURE LinesClear(W:Window);
VAR LineNo:INTEGER;
BEGIN
  WITH Windows[W] DO BEGIN
    CurrX:=0; CurrPan:=0; 
    IF HasHeading IN Options THEN BEGIN
      LineNo:=Lines[StartLine].NextLine;
      CurrY:=1;
    END
    ELSE BEGIN
      LineNo:=StartLine;
      CurrY:=0;
    END;
    WITH Lines[LineNo] DO BEGIN
      AddToFree(NextLine);
      NextLine:=0; {End of chain}
      Contents:=ClearLine;
    END;
    Cleared:=TRUE;
  END;
END;

PROCEDURE WAlter{(W:Window;
               WatX,WatY,WSizeX,WSizeY:INTEGER;
               WControls:WindowAttributes;
               WHeading:STRING)}; {Get new window}
VAR Offset,Top,i:INTEGER;
BEGIN
  {Window must not be in show when WAlter called}
  IF (W<>NoWindow) AND NOT InShow(W) THEN
    WITH Windows[W] DO BEGIN
      Options:=(Options*[HasHeading])+(WControls-[HasHeading]);
      IF (WSizeX>0) THEN SizeX:=WSizeX;
      IF (SizeX>ScreenWidth) THEN SizeX:=ScreenWidth;
      IF (WSizeY>0) THEN SizeY:=WSizeY;
      IF (SizeY>ScreenHeight) THEN SizeY:=ScreenHeight;
      IF (HasHeading IN Options) and (SizeY<2) THEN SizeY:=2;
      IF (WatX>=0) AND (WatX<ScreenWidth) THEN
        BEGIN
          IF (WatX+SizeX)<=ScreenWidth THEN AtX:=WatX
          ELSE AtX:=ScreenWidth-SizeX;
        END;
      IF (WatY>=0) AND (WatY<ScreenHeight) THEN
        BEGIN
          IF (WatY+SizeY)<=ScreenHeight THEN AtY:=WatY
          ELSE AtY:=ScreenHeight-SizeY;
        END;
      {check CurrX and CurrY are in Window}
      IF NOT(CanPan in Options) AND (CurrX>=SizeX) THEN CurrX:=SizeX-1;
      {Zero pan position if possible}
      IF (CurrX<SizeX) THEN CurrPan:=0;
      {check 2 lines available if heading present}
      IF (Hasheading IN Options) AND (Lines[StartLine].NextLine=0) THEN
        BEGIN
          IF (FreeLine=0) THEN Options:=Options-[HasHeading]
          ELSE
            BEGIN
              i:=FreeLine;
              FreeLine:=Lines[FreeLine].NextLine;
              Lines[i].NextLine:=StartLine;
            END;
        END;
      IF CurrY>=SizeY THEN
        BEGIN
          CurrY:=SizeY-1;
          IF CanScroll IN Options THEN LinesClear(W);
        END;
      IF (HasHeading IN Options) AND (HasHeading IN WControls) AND
                                     (WHeading<>'') THEN
        BEGIN
          WITH Lines[StartLine] DO BEGIN
            Contents:=ClearLine;
            {allow for Pan indicator on heading}
            IF CanPan IN Options THEN Offset:=1 ELSE Offset:=0;
            Top:=LENGTH(WHeading);
            IF Top>(ScreenWidth-Offset) THEN Top:=ScreenWidth-Offset;
            FOR i:=1 TO Top DO Contents[Offset+i]:=WHeading[i];
          END;
        END;
    END;
END;

FUNCTION XYOverWindow(X,Y:INTEGER; W:Window):BOOLEAN;
BEGIN
  IF W=NoWindow THEN XYOverWindow:=FALSE
  ELSE
    WITH Windows[W] DO BEGIN
      XYOverWindow:=((X>=AtX-1) AND (X<=AtX+SizeX) AND
                     (Y>=AtY-1) AND (Y<=AtY+SizeY));
    END;
END;

FUNCTION WInWindow{(X,Y:INTEGER):Window};
VAR W:Window;
    Found:BOOLEAN;
BEGIN
  {returns window in which position X,Y occurs - NoWindow if none}
  {X,Y in screen coordinates}
  Found:=FALSE;
  W:=WSequence; {Start of show list}
  WHILE (W<>NoWindow) AND NOT Found DO BEGIN
    Found:=XYOverWindow(X,Y,W);
    IF NOT Found THEN W:=Windows[W].PrevWindow;
  END;
  WInWindow:=W;
END;

FUNCTION WChAtXY{(X,Y:INTEGER; W:Window):CHAR};
VAR LineNo,Xindex,i:INTEGER;
BEGIN
  {return Ch under screen position X,Y in W}
  {space returned if X,Y not in Window, or NoWindow}
  {Ch need not be in view at the time of call}
  IF (W=NoWindow) OR NOT XYOverWindow(X,Y,W) THEN WChAtXY:=' '
  ELSE
    WITH Windows[W] DO BEGIN
      IF Y=AtY-1 THEN
        BEGIN
          IF X=AtX-1 THEN WChAtXY:=TLChr
          ELSE IF X=AtX+SizeX THEN WChAtXY:=TRChr
          ELSE WChAtXY:=TEChr;
        END
      ELSE IF Y=AtY+SizeY THEN
        BEGIN
          IF X=AtX-1 THEN WChAtXY:=BLChr
          ELSE IF X=AtX+SizeX THEN WChAtXY:=BRChr
          ELSE WChAtXY:=BEChr;
        END
      ELSE IF X=AtX-1 THEN WChAtXY:=LEChr
      ELSE IF X=AtX+SizeX THEN WChAtXY:=REChr
      ELSE
        BEGIN
          i:=Y-AtY;
          IF i>=0 THEN LineNo:=StartLine 
          ELSE LineNo:=0;
          WHILE (LineNo<>0) AND (i>0) DO BEGIN
            LineNo:=Lines[LineNo].NextLine;
            i:=i-1;
          END;
          IF LineNo=0 THEN WChAtXY:=' '
          ELSE
            BEGIN
              IF (X<0) OR (X>(ScreenWidth-1)) OR
                 (X<AtX) OR (X>=AtX+SizeX) THEN WChAtXY:=' '
              ELSE
                IF (LineNo<>StartLine) OR
                   NOT(HasHeading IN Options) OR
                   NOT(CanPan IN Options) THEN
                     WChAtXY:=Lines[LineNo].Contents[(X-AtX+CurrPan)+1]
              ELSE
                BEGIN
                  IF (X=AtX) AND (CurrPan<>0) THEN {more to left} WChAtXY:='<'
                  ELSE IF (X=AtX+SizeX-1) AND (CurrPan+SizeX<ScreenWidth) THEN
                          {more to right} WChAtXY:='>'
                  ELSE WChAtXY:=Lines[LineNo].Contents[(X-AtX)+1];
                END;
            END;
        END;
  END;
END;

PROCEDURE WXY{(VAR X,Y:INTEGER)}; {Give Coordinates of window manager cursor}
BEGIN
  X:=WX; Y:=WY;
END;

PROCEDURE WCursorXY {(X,Y:INTEGER)}; {Set Coordinates of window manager cursor}
BEGIN
  IF X<0 THEN WX:=0 ELSE WX:=X;
  IF WX>(ScreenWidth-1) THEN WX:=ScreenWidth-1;
  IF Y<0 THEN WY:=0 ELSE WY:=Y;
  IF WY>(ScreenHeight-1) THEN WY:=ScreenHeight-1;
END;

PROCEDURE FGOTOXY{X,Y:INTEGER};
BEGIN
  {This is here to allow experimentation with
   asynchronous gotoxy's, without having to
   modify *SYSTEM.PASCAL}
  GOTOXY(X,Y);
END;
  
PROCEDURE WMGoToXY(X,Y:INTEGER);
BEGIN
  IF (RealX<>X) OR (RealY<>Y) THEN BEGIN
    FGOTOXY(X,Y);
    RealX:=X; RealY:=Y;
  END;
END;

PROCEDURE RemoveCursor;
BEGIN
  IF WCursPlaced THEN BEGIN
    {Replace position WX,WY on Screen by SCursBuff}
    WMGoToXY(WX,WY);
    WRITE(SCursBuff,CHR(Bs));
    WCursPlaced:=FALSE;
  END;
END;

PROCEDURE PlaceCursor;
VAR W:Window;
BEGIN
  IF NOT WCursPlaced THEN BEGIN
    {Cursor was last in window SCursIn.  It is likely it is still there}
    {Check if WX,WY are still in the same window range}
    SCursIn:=WInWindow(WX,WY);
    IF SCursIn=NoWindow THEN SCursBuff:=' '
    ELSE SCursBuff:=WChAtXY(WX,WY,SCursIn);
    WMGoToXY(WX,WY);
    WRITE(WCursor,CHR(Bs));
    WCursPlaced:=TRUE;
  END;
END;

PROCEDURE GetLine;
{Get CurrY line of current window}
VAR LineNo,i,nl:INTEGER;
BEGIN
  IF WSequence=NoWindow THEN EXIT(GetLine);
  WITH Windows[WSequence] DO BEGIN
    LineNo:=Startline; i:=CurrY;
    OldXMin:=CurrX; OldXMax:=CurrX;
  END;
  WHILE i>0 DO BEGIN
    nl:=Lines[LineNo].NextLine;
    IF nl=0 THEN BEGIN {get a blank line to extend text}
      IF FreeLine=0 THEN
        BEGIN {Stay on last real line}
          nl:=LineNo;
          WITH Windows[WSequence] DO CurrY:=CurrY-i;
          i:=0; {to terminate loop}
        END
      ELSE
        BEGIN {new line really available}
          nl:=FreeLine;
          WITH Lines[nl] DO BEGIN
            Contents:=ClearLine;
            FreeLine:=NextLine;
            NextLine:=0;
          END;
          Lines[LineNo].NextLine:=nl;
        END;
    END;
    LineNo:=nl; i:=i-1;
  END;
  CurrLine:=LineNo;
END;
  
PROCEDURE FlushOutput;
VAR RightX,LeftX,LineNo:INTEGER;
BEGIN
  IF WSequence=NoWindow THEN EXIT(FlushOutput);
  WITH Windows[WSequence] DO BEGIN
    IF (OldXMin<>OldXMax) AND
       (OldXMax>=CurrPan) AND
       (OldXMin<=CurrPan+SizeX-1) THEN BEGIN
      LeftX:=OldXMin; RightX:=OldXMax;
      IF LeftX<CurrPan THEN LeftX:=CurrPan;
      IF RightX-CurrPan>=SizeX THEN RightX:=SizeX+CurrPan;
      WMGoToXY(AtX+LeftX-CurrPan,AtY+CurrY);
      UNITWRITE(CONSOLE,Lines[CurrLine].Contents[LeftX+1],
                RightX-LeftX,,1);
      RealX:=AtX+RightX-CurrPan; OldXMin:=CurrX; OldXMax:=CurrX;
    END;
  END;
END;

PROCEDURE WDispose{(W:Window)}; {Dispose of old window}
BEGIN
  {Window must not be in show when WDispose called}
  IF (W<>NoWindow) AND NOT InShow(W) THEN BEGIN
    IF NOT ScreenValid THEN RePaint;       {Because info will be destroyed}
    AddToFree(Windows[W].StartLine);
    Windows[W].PrevWindow:=FreeWindow;
    FreeWindow:=W;
  END;
END;

FUNCTION Intersects(W1,W2:Window):BOOLEAN;
         {does W1 intersect with W2}
VAR WatX,WatY,WSizeX,WSizeY:INTEGER;
BEGIN
  WITH Windows[W1] DO BEGIN
    WatX:=AtX; WatY:=AtY;
    WSizeX:=SizeX; WSizeY:=SizeY;
  END;
  WITH Windows[W2] DO BEGIN
    Intersects:=(((AtX+SizeX)>=WatX) AND
                 (AtX<(WAtX+WSizeX)) AND
                 ((AtY+SizeY)>=WatY) AND
                 (AtY<(WatY+WSizeY)));
  END;
END;

PROCEDURE WShow{(W:Window)}; {Display window and set it as "current" one}
VAR LineNo,StartX,EndX,IndY,i:INTEGER;
    Seen,Obscured:BOOLEAN;
    WTemp:Window;
BEGIN
  IF (WSequence=W) OR (W=NoWindow) THEN EXIT(WShow);
  FlushOutput;
  {If already on show remove from sequence list first}
  WTemp:=WSequence; Seen:=FALSE; Obscured:=FALSE;
  WHILE WTemp<>NoWindow DO BEGIN
    Obscured:=Obscured OR Intersects(W,WTemp);
    IF Windows[WTemp].PrevWindow=W THEN BEGIN
      Seen:=TRUE;
      Windows[WTemp].PrevWindow:=Windows[W].PrevWindow;
      WTemp:=NoWindow; {to escape from WHILE}
    END
    ELSE WTemp:=Windows[WTemp].PrevWindow;
  END;
  Windows[W].PrevWindow:=WSequence;
  WSequence:=W; {add to show list head}
  IF Obscured OR NOT Seen THEN ScreenValid:=FALSE;
  GetLine;
  {IF NOT ScreenValid THEN Repaint;}
END;

FUNCTION RemoveFromSeq(W:Window):BOOLEAN;
Var WTemp:Window;
    Removed:BOOLEAN;
BEGIN
  Removed:=FALSE;
  IF (W<>NoWindow) AND (W=WSequence) THEN BEGIN
    WSequence:=Windows[WSequence].PrevWindow;
    Removed:=TRUE;
  END
  ELSE BEGIN
    WTemp:=WSequence;
    WHILE (WTemp<>NoWindow) AND NOT Removed DO BEGIN
      IF Windows[WTemp].PrevWindow=W THEN BEGIN
        Windows[WTemp].PrevWindow:=Windows[W].PrevWindow;
        Removed:=TRUE;
      END
      ELSE WTemp:=Windows[WTemp].PrevWindow;
    END;
  END;
  RemoveFromSeq:=Removed;
END;

PROCEDURE WHide{(W:Window)}; {remove window from screen - it is not disposed of}
VAR i:INTEGER;
BEGIN
  FlushOutput;
  IF W<>NoWindow THEN
    IF RemoveFromSeq(W) THEN BEGIN
      IF SCursIn=W THEN SCursIn:=NoWindow;
      GetLine;
      ScreenValid:=FALSE;
    END;
  {IF NOT ScreenValid THEN Repaint;}
END;

PROCEDURE WClearAndShow{(W:Window)}; {Clear Window and "Show" it}
BEGIN
  IF W=NoWindow THEN EXIT(WClearAndShow);
  FlushOutput;
  LinesClear(W);
  WShow(W);
  ScreenValid:=FALSE;
  GetLine;
  {IF NOT ScreenValid THEN Repaint;}
END;

PROCEDURE WClear; {clear "current" window}
BEGIN
  WClearAndShow(WSequence);
END;

{$I w.io}

========================================================================================
DOCUMENT :usus Folder:VOL12:w.io.text
========================================================================================

{w.io - insert into implementation part of Window Manager}
{Copyright 22-Feb-82 Austin Tate, ERCC}

PROCEDURE WGotoXY{(X,Y:INTEGER)}; {Set Window cursor to X,Y}
BEGIN
  {X,Y are relative to top left of window - base of 0}
  IF WSequence<>NoWindow THEN
    WITH Windows[WSequence] DO BEGIN
      IF HasHeading IN Options THEN Y:=Y+1;
      IF X<0 THEN CurrX:=0
      ELSE IF X<SizeX THEN CurrX:=X
      ELSE IF CanPan IN Options THEN
        BEGIN
          IF X>=ScreenWidth THEN CurrX:=ScreenWidth-1
          ELSE CurrX:=X;
          ScreenValid:=FALSE;
        END
      ELSE CurrX:=SizeX-1;
      IF Y<>CurrY THEN BEGIN
        IF Y<0 THEN CurrY:=0
        ELSE IF Y<SizeY THEN CurrY:=Y
        ELSE CurrY:=SizeY-1;
        FlushOutput;
        GetLine; {get further lines as needed to get CurrY on a line}
      END;
    END;
END;
          
PROCEDURE WScroll;
VAR FirstFree,LastFree,Freed,i:INTEGER;
  {Scroll current window - scroll up by one third of depth of window}
BEGIN
  {WSequence known not to be NoWindow}
  FlushOutput;
  WITH Windows[WSequence] DO BEGIN
    CurrX:=0; OldXMin:=0; OldXMax:=0;
    IF (CanPan IN Options) AND (CurrPan<>0) THEN
      BEGIN
        ScreenValid:=FALSE;
        CurrPan:=0;
      END;
    IF SizeY<2 THEN BEGIN {cannot have heading - so don't check for this}
        Lines[StartLine].Contents:=ClearLine;
        Cleared:=TRUE;
        ScreenValid:=FALSE;
      END
    ELSE BEGIN
      IF (CurrY+1)>=SizeY THEN BEGIN
        IF (CanScroll IN Options) AND (SizeY>1) THEN BEGIN {else overprint}
          FirstFree:=StartLine;
          IF HasHeading IN Options THEN
            FirstFree:=Lines[FirstFree].NextLine;
          LastFree:=FirstFree; Freed:=1;
          FOR i:= 2 TO SizeY DIV 3 DO BEGIN
            Freed:=Freed+1;
            LastFree:=Lines[LastFree].NextLine;
          END;
          IF HasHeading IN Options THEN
            Lines[StartLine].NextLine:=Lines[LastFree].NextLine
          ELSE
            StartLine:=Lines[LastFree].NextLine;
          Lines[LastFree].NextLine:=0;
          AddToFree(FirstFree);
          Cleared:=TRUE;
          ScreenValid:=FALSE;
          CurrY:=CurrY-Freed+1; GetLine;
        END;
      END
      ELSE IF FreeLine<>0 THEN BEGIN {free line - else overprint on bottom line}
        CurrY:=CurrY+1;
        CurrLine:=Lines[CurrLine].NextLine;
        IF CurrLine=0 THEN GetLine; {get a further line}
      END;
    END;
  END;
  IF NOT ScreenValid THEN RePaint;
END;

PROCEDURE WClrEOL;
VAR LastNonSpace:INTEGER;
BEGIN
  IF NOT ScreenValid THEN RePaint;
  IF WSequence<>NoWindow THEN BEGIN
    WITH Windows[WSequence],Lines[CurrLine] DO BEGIN
      IF CurrX<OldXMin THEN OldXMin:=CurrX;
      LastNonSpace:=ScreenWidth+SCAN(-ScreenWidth,<>' ',
                                      Contents[ScreenWidth]);
      IF LastNonSpace>CurrX THEN BEGIN
        FILLCHAR(Contents[CurrX+1],LastNonSpace-CurrX,' ');
        OldXMax:=LastNonSpace;
      END;
    END;
  END;
END;

PROCEDURE WWriteLn;
BEGIN
  IF NOT ScreenValid THEN RePaint;
  IF WSequence<>NoWindow THEN BEGIN
    WScroll;
    WClrEOL;
  END;
END;

PROCEDURE WClrEOS;
VAR X,Y,Line:INTEGER;
BEGIN
  IF NOT ScreenValid THEN RePaint;
  IF WSequence<>NoWindow THEN BEGIN
    WITH Windows[WSequence] DO BEGIN
      X:=CurrX; Y:=CurrY; Line:=CurrLine;
      WClrEOL;
      WHILE CurrY<SizeY-1 DO WWriteLn;
      FlushOutput; 
      CurrX:=X; CurrY:=Y; CurrLine:=Line;
      OldXMin:=X; OldXMax:=X;
    END;
  END;
END;

PROCEDURE WWriteCh{(Ch:CHAR)}; {write Ch at cursor position in window}
VAR s:STRING;
BEGIN
  IF WSequence=NoWindow THEN EXIT(WWriteCh);
  IF NOT ScreenValid THEN RePaint;
  WITH Windows[Wsequence],Lines[CurrLine] DO BEGIN
    IF Ch=CHR(Bs) THEN BEGIN
      IF CurrX<>0 THEN BEGIN {erase last ch}
        IF Contents[CurrX]<>' ' THEN BEGIN
          Contents[CurrX]:=' ';
          IF CurrX<=OldXMin THEN OldXMin:=CurrX-1;
        END;
        CurrX:=CurrX-1;
      END;
    END  {Backspace}
    ELSE BEGIN
      {$R-}
      s[0]:=CHR(1);
      {$R^}
      s[1]:=Ch;
      WWriteStr(s);
    END;
  END;
END;

PROCEDURE WWriteStr{(Str:STRING)}; {write Str at cursor position in window}
VAR i,j,Actual:INTEGER;
    Ch:CHAR;
    Continue:BOOLEAN;
BEGIN
  IF WSequence=NoWindow THEN EXIT(WWriteStr); 
  IF NOT ScreenValid THEN RePaint;
  WITH Windows[WSequence],Lines[CurrLine] DO BEGIN
    i:=1; j:=LENGTH(Str);
    IF CurrX+j>=ScreenWidth THEN j:=ScreenWidth-CurrX;
    Continue:=TRUE;
    WHILE (j>=1) AND Continue DO
      IF Contents[CurrX+j]=Str[j] THEN j:=j-1
      ELSE Continue:=FALSE;
    Continue:=TRUE;
    WHILE (i<=j) AND Continue DO 
      IF Contents[CurrX+i]=Str[i] THEN i:=i+1
      ELSE Continue:=FALSE;
    IF OldXMin=OldXMax THEN BEGIN
      OldXMin:=CurrX+i-1; OldXMax:=OldXMin;
    END;
    Actual:=j-i+1;
    IF Actual>0 THEN BEGIN
      MOVELEFT(Str[i],Contents[CurrX+i],Actual);
      IF CurrX+j>=OldXMax THEN OldXMax:=CurrX+j;
    END;
    CurrX:=CurrX+LENGTH(Str);
    IF CurrX>=ScreenWidth THEN CurrX:=ScreenWidth-1;
  END; {WITH}
END;

PROCEDURE WWriteInt{(Int,Width:INTEGER)};
          {write Int at cursor posn in window}
VAR i,j:INTEGER;
    buff:STRING;
BEGIN
   i:=10000; j:=1; 
   {$R-}
   buff[0]:=CHR(80); {to avoid range check problems}
   {$R^}
   IF Int<0 THEN BEGIN
      Int:=-Int;
      IF Int<0 THEN BEGIN
         WWriteStr('-32768'); EXIT(WWriteInt);
      END;
      buff[j]:='-'; j:=j+1; Width:=Width-1;
   END;
   WHILE (Int DIV i=0) AND (i<>1) DO BEGIN
      Width:=Width+1; i:=i DIV 10;
   END;
   Width:=Width-5;
   WHILE Width>0 DO BEGIN
      buff[j]:=' '; j:=j+1; Width:=Width-1;
   END;
   REPEAT
      buff[j]:=(CHR(ORD('0')+Int DIV i)); j:=j+1;
      Int:=Int-(Int DIV i)*i; i:=i DIV 10;
   UNTIL i=0;
   {$R-}
   buff[0]:=CHR(j-1);
   {$R^}
   WWriteStr(buff);
END;

PROCEDURE WReadCh{(VAR Ch:CHAR: Echo:BOOLEAN)}; {get character from keyboard}
VAR NewPan,X,Y:INTEGER;
    Key:PACKED ARRAY [0..1] OF CHAR;
BEGIN
  {Window functions can only take place within WReadCh}
  {Echo is controlled by user - non printable chs echo as bell}
  {First ensure screen is valid}
  FlushOutput;
  IF NOT ScreenValid THEN RePaint;
  REPEAT
    {Set X,Y of cursor in current window}
    IF WSequence=NoWindow THEN BEGIN
      X:=WX; Y:=WY; {No Window on screen}
    END
    ELSE
      WITH Windows[WSequence] DO BEGIN
        IF CurrX>=ScreenWidth THEN CurrX:=ScreenWidth-1;
        IF CanPan IN Options THEN BEGIN
          NewPan:=CurrPan;
          WHILE CurrX<NewPan DO BEGIN
            NewPan:=NewPan-(SizeX DIV 3);
            IF NewPan<0 THEN NewPan:=0;
          END;
          WHILE CurrX-NewPan>=SizeX DO BEGIN
            IF SizeX<3 THEN NewPan:=NewPan+1
            ELSE
              BEGIN
                NewPan:=NewPan+(SizeX DIV 3);
                IF NewPan+SizeX>ScreenWidth THEN NewPan:=ScreenWidth-SizeX;
              END;
          END;
          CurrPan:=NewPan;
          IF CurrPan<>OldPan THEN BEGIN
            ScreenValid:=FALSE;
            RePaint;
          END;
          X:=AtX+CurrX-CurrPan;
        END
        ELSE BEGIN
          IF CurrX>=SizeX THEN X:=(AtX+SizeX)-1 ELSE X:=AtX+CurrX;
        END;
        IF CurrY>=SizeY THEN Y:=(AtY+SizeY)-1 ELSE Y:=AtY+CurrY;
      END;
    WMGoToXY(X,Y);
    UNITREAD(SYSTERM,Key[0],1);
    Ch:=Key[0];
    IF Ch=CHR(27) THEN WindowFunction;
  UNTIL Ch<>CHR(27);
  IF Echo THEN BEGIN
    IF ((ORD(Ch) MOD 128)>=ORD(' ')) OR (Ch=CHR(Bs)) THEN WWriteCh(Ch)
    ELSE BEGIN
      IF Ch=CHR(Cr) THEN WWriteLn
      ELSE WRITE(CHR(Bel)); {cannot handle other control codes}
    END;
  END;
END;

PROCEDURE WReadLnStr{(VAR Str:STRING)}; {get a string from keyboard - echoed}
VAR STemp:STRING;
    Len:INTEGER;
    Ch:CHAR;
BEGIN
  {string is ended by newline. Only edit ch allowed is backspace}
  {non printable chs are not returned - but echo as bell}
            (*         1         2         3         4         5*)
            (*12345678901234567890123456789012345678901234567890*)
  STR:=CONCAT('                                                 ',
              '                            ');
  {overlay onto a bed of spaces}
  Len:=0;
  REPEAT
    WReadCh(Ch,TRUE);
    IF (Ch=CHR(Bs)) AND (Len>0) THEN Len:=Len-1
    ELSE BEGIN
      IF ((ORD(Ch) MOD 128)>=ORD(' ')) THEN BEGIN
        IF Len<ScreenWidth-1 THEN Len:=Len+1;
        Str[Len]:=Ch;
      END;
    END;
  UNTIL Ch=CHR(Cr);
  {$R-}
  Str[0]:=CHR(Len);
  {$R^}
END;

FUNCTION StrToInt(Str:STRING):INTEGER;
VAR Val,i,j,k:INTEGER; {result -ve if poor number input}
    Neg,Ok:BOOLEAN;
BEGIN
  Val:=0;
  Ok:=(LENGTH(Str)<>0);
  IF Ok THEN BEGIN
    Neg:=((Str[1]='-') AND (LENGTH(Str)>1));
    IF Neg THEN k:=2 ELSE k:=1;
    FOR i:=k TO LENGTH(Str) DO BEGIN
      j:=ORD(Str[i])-ORD('0');
      IF (j<0) OR (j>9) THEN Ok:=FALSE;
      IF Ok THEN Val:=Val*10+j;
    END;
  END;
  If Ok THEN BEGIN
    IF Neg THEN Val:=-Val;
    StrToInt:=Val;
  END
  ELSE StrToInt:=-MAXINT;
END;
 
PROCEDURE WReadLnInt{(VAR Int:INTEGER)}; {Get an integer from keyboard - echoed}
VAR STemp:STRING;
    Ch:CHAR;
BEGIN
  {integer is ended by newline. Only edit ch allowed is backspace}
  {non printable chs are not returned - but echo as bell}
  WReadLnStr(STemp);
  Int:=StrToInt(STemp);
END;

PROCEDURE WReadLn{(Echo:BOOLEAN)}; {Read up to next newline from keyboard}
VAR Ch:CHAR;
BEGIN
  {non printable chs echo as bell}
  REPEAT
    WReadCh(Ch,Echo)
  UNTIL Ch=CHR(Cr);
END;

FUNCTION WCurrentWindow{:Window};
         {Returns current window - one last shown - may be NoWindow}
BEGIN
  WCurrentWindow:=WSequence;
END;


========================================================================================
DOCUMENT :usus Folder:VOL12:w.segs.text
========================================================================================

{w.segs - Segment procedures for Window Manager}
{Copyright 22-Feb-82 Austin Tate, ERCC}

SEGMENT PROCEDURE WMStartup; {Initialise Window Manager System}
VAR i:INTEGER;
BEGIN
  Sc_Clr_Screen;
  
  WCursor:=CHR(64);    {At symbol} {Symbol for Window Manager Cursor}

  FOR i:=1 TO (MaxLine-1) DO Lines[i].NextLine:=i+1;
  Lines[MaxLine].NextLine:=0;
  FreeLine:=1;
  
  FOR i:=1 TO (MaxWindow-1) DO Windows[i].PrevWindow:=i+1;
  Windows[MaxWindow].PrevWindow:=NoWindow;
  FreeWindow:=1;
  
  {$R-}
  ClearLine[0]:=CHR(ScreenWidth);
  {$R^}
  FOR i:=1 TO ScreenWidth DO ClearLine[i]:=' ';
  
  WSequence:=NoWindow; OldWSequence:=NoWindow;
  SCursBuff:=' ';      SCursIn:=NoWindow;
  WX:=0;               WY:=0;
  RealX:=-1;           RealY:=-1;
  WCursPlaced:=FALSE;  ScreenValid:=FALSE;
END;

SEGMENT PROCEDURE WMInit;
BEGIN
  Sc_Clr_Screen;
  OldWSequence:=NoWindow;
  ScreenValid:=FALSE;
END;
  
SEGMENT PROCEDURE RePaint;
    VAR LineNo,FirstChanged,LastChanged,
      LastNonSpace,OldLastNonSpace,X,Y:INTEGER;
      WTemp,LastObscured,OldLastObscured:Window;
      ClearX,ClearY,ClearTo:INTEGER;
      OkToClear,PartialClear:BOOLEAN;
      RevSequence,OldRevSequence:ARRAY [0..MaxWindow] OF Window;
      NextWLine,OldNextWLine:ARRAY [0..MaxWindow] OF INTEGER;
      OldBuff,Buff,IOBuff:PACKED ARRAY [-1..XScreenWidth] OF CHAR;
  BEGIN
    IF ScreenValid THEN EXIT(RePaint);    {Nothing to do}
    RemoveCursor;
    
    {We are going to reconstruct 'before' and 'after' images
     of the screen line by line. Each window will place its
     contribution to a composite screen line in a screen line
     buffer. This is done in reverse show order to get overlapping
     right.}
       
    {First build two access vectors for the windows, containing
     'show' sequences}
    
    LastObscured:=0; OldLastObscured:=0;
    WTemp:=WSequence;
    WHILE WTemp<>NoWindow DO BEGIN
      RevSequence[LastObscured]:=WTemp;
      LastObscured:=LastObscured+1;
      WTemp:=Windows[WTemp].PrevWindow;
    END;
    WTemp:=OldWSequence;
    WHILE WTemp<>NoWindow DO BEGIN
      OldRevSequence[OldLastObscured]:=WTemp;
      OldLastObscured:=OldLastObscured+1;
      WTemp:=Windows[WTemp].OldPrevWindow;
    END;
    
    {Build screen lines 'before' and 'after', and compute
     I/O need to make the screen change from 'before' to after'}
       
    OkToClear:=FALSE;
    FOR Y:=0 TO ScreenHeight-1 DO BEGIN
      FILLCHAR(Buff[-1],XScreenWidth+2,' ');
      
      {Each window, in reverse show sequence, places its
       contribution into the composite line buffer}
      
      FOR X:=LastObscured-1 DOWNTO 0 DO BEGIN
        WITH Windows[RevSequence[X]] DO BEGIN
          IF (Y>=AtY) AND (Y<(AtY+SizeY)) THEN BEGIN
            {It has somthing to give}
            IF Y=AtY THEN LineNo:=StartLine
            ELSE LineNo:=NextWLine[X];
            IF LineNo<>0 THEN BEGIN
              NextWLine[X]:=Lines[LineNo].NextLine;
              {Get window's contibution to this line}
              IF (LineNo=StartLine) AND (HasHeading IN Options) THEN
                BEGIN
                  {Don't pan title lines}
                  MOVELEFT(Lines[LineNo].Contents[1],Buff[AtX],SizeX);
                  {Put pan indicators on title line if there is one}
                  IF (CanPan IN Options) THEN
                    BEGIN
                     IF CurrPan<>0 THEN Buff[Atx]:='<';
                     IF (CurrPan+SizeX)<ScreenWidth THEN Buff[AtX+SizeX-1]:='>';
                    END;
                END
              ELSE MOVELEFT(Lines[LineNo].Contents[CurrPan+1],Buff[AtX],SizeX);
            END
            ELSE FILLCHAR(Buff[AtX],SizeX,' ');
                 {LineNo of 0 indicates line of spaces}
            {Put side frame chars in buffer}
            Buff[AtX-1]:=LEChr; Buff[AtX+SizeX]:=REChr;
          END
          ELSE IF (Y=AtY-1) THEN BEGIN
            {Do top of frame}
            Buff[AtX-1]:=TLChr; Buff[AtX+SizeX]:=TRChr;
            FILLCHAR(Buff[AtX],SizeX,TEChr);
          END
          ELSE IF (Y=AtY+SizeY) THEN BEGIN
            {Do bottom of frame}
            Buff[AtX-1]:=BLChr; Buff[AtX+SizeX]:=BRChr;
            FILLCHAR(Buff[AtX],SizeX,BEChr);
          END;
        END;
      END;
      {Above dealt with after image( ie what we want)
       Computation of before image (ie what's there now) follows}
      FILLCHAR(OldBuff[-1],XScreenWidth+2,' ');
      FOR X:=OldLastObscured-1 DOWNTO 0 DO BEGIN
        WITH Windows[OldRevSequence[X]] DO BEGIN
          IF (Y>=OldAtY) AND (Y<(OldAtY+OldSizeY)) THEN BEGIN
            IF Y=OldAtY THEN LineNo:=StartLine
            ELSE LineNo:=OldNextWLine[X];
            IF LineNo<>0 THEN OldNextWLine[X]:=Lines[LineNo].NextLine;
            {When a window has been cleared then we forget what
             was on the screen before the clear took place - 
             see more below}
            IF Cleared AND NOT((HasHeading IN Options) AND (Y=OldAtY)) THEN
              LineNo:=0;
            IF LineNo<>0 THEN BEGIN
              IF (LineNo=StartLine) AND (HasHeading IN Options) THEN
                BEGIN
                  MOVELEFT(Lines[LineNo].Contents[1],OldBuff[OldAtX],OldSizeX);
                  IF (CanPan IN Options) THEN
                    BEGIN
                      IF OldPan<>0 THEN OldBuff[OldAtx]:='<';
                      IF (OldPan+OldSizeX)<ScreenWidth THEN 
                        OldBuff[OldAtX+OldSizeX-1]:='>';
                    END;
                END
              ELSE MOVELEFT(Lines[LineNo].Contents[OldPan+1],
                            OldBuff[OldAtX],OldSizeX);
            END
            ELSE IF Cleared THEN
              {The effect of the following is to force a total
               repaint of the area covered by a window which has
               been cleared, since we've forgotten what's currently
               on the screen}
              FILLCHAR(OldBuff[OldAtX],OldSizeX,CHR(0))
            ELSE FILLCHAR(OldBuff[OldAtX],OldSizeX,' ');
            OldBuff[OldAtX-1]:=LEChr; OldBuff[OldAtX+OldSizeX]:=REChr;
          END
          ELSE IF (Y=OldAtY-1) THEN BEGIN
            OldBuff[OldAtX-1]:=TLChr; OldBuff[OldAtX+OldSizeX]:=TRChr;
            FILLCHAR(OldBuff[OldAtX],OldSizeX,TEChr);
          END
          ELSE IF (Y=OldAtY+OldSizeY) THEN BEGIN
            OldBuff[OldAtX-1]:=BLChr; OldBuff[OldAtX+OldSizeX]:=BRChr;
            FILLCHAR(OldBuff[OldAtX],OldSizeX,BEChr);
          END;
        END;
      END;
      {Now compare before and after images, and compute
       I/O requirements}
      {Most of the complexity is due to delaying clear to EOLs
       with a view to doing a monumental clear to EOS.
       When multiple clear to EOLs are unavoidable, a limited effort
       to avoid clearing lines which are already clear is made}
      LastNonSpace:=ScreenWidth-1
                      +SCAN(-(ScreenWidth),<>' ',Buff[ScreenWidth-1]);
      IF Buff<>OldBuff THEN BEGIN
        {Screen must change}
        IF LastNonSpace>=0 THEN BEGIN
          {Non-blank line which was not blank before}
          FirstChanged:=0; LastChanged:=LastNonSpace;
          WHILE ((FirstChanged<LastChanged) AND
                 (Buff[FirstChanged]=OldBuff[FirstChanged])) DO
            FirstChanged:=FirstChanged+1;
          WHILE ((LastChanged>FirstChanged) AND
                 (Buff[LastChanged]=OldBuff[LastChanged])) DO
            LastChanged:=LastChanged-1;
          {Catch up on deferred line clearing}
          IF OkToClear THEN 
            FOR X:=ClearY TO ClearTo DO BEGIN
              Sc_Erase_To_Eol(ClearX,X);
              ClearX:=0;
            END;
          OkToClear:=FALSE; PartialClear:=FALSE;
          {Blat the screen, asynchronously}
          FGOTOXY(FirstChanged,Y); {**ALSO ENSURES THAT NEXT ASSIGN IS OK**}
          IOBuff:=Buff;
          UNITWRITE(CONSOLE,IOBuff[FirstChanged],
                      LastChanged-FirstChanged+1,,1);
          {Check if a clear to EOL is needed, but don't
           do it now}
          OldLastNonSpace:=ScreenWidth-1
                      +SCAN(-(ScreenWidth),<>' ',OldBuff[ScreenWidth-1]);
          IF LastNonSpace<OldLastNonSpace THEN BEGIN
            ClearX:=LastNonSpace+1; ClearY:=Y; ClearTo:=Y;
            OkToClear:=TRUE; PartialClear:=FALSE;
          END
        END
        ELSE BEGIN
          {Blank line which was not blank before}
          IF NOT(OkToClear) THEN BEGIN
            {If no outstanding clears then remember start and end point}
            ClearX:=0; ClearY:=Y; ClearTo:=Y; 
            OkToClear:=TRUE; PartialClear:=FALSE;
          END
          {Else just update end point}
          ELSE ClearTo:=Y
        END
      END
      ELSE BEGIN
        IF LastNonSpace>=0 THEN BEGIN
          {Unchanged non-blank line}
          {If there are any deferred clears do them now}
          IF OkToClear THEN BEGIN
            FOR X:=ClearY TO ClearTo DO BEGIN
              Sc_Erase_To_Eol(ClearX,X);
              ClearX:=0;
            END;
            OkToClear:=FALSE; PartialClear:=FALSE;
          END
        END
        ELSE BEGIN
          {Unchanged blank line}
          {Try to avoid doing a clear to EOL for this line}
          IF OkToClear THEN
            IF NOT PartialClear THEN BEGIN
              PartialClear:=TRUE;
              ClearTo:=Y-1;
            END
        END
      END;
    END;
    IF OkToClear THEN Sc_Eras_Eos(ClearX,ClearY);
    {Save info need to compute before image on next call}
    SaveSequence;
    ScreenValid:=TRUE;
    RealX:=-1; RealY:=-1;
  END;

SEGMENT PROCEDURE WHelp;
VAR WTop,WPopup:Window;
BEGIN
  WTop:=WSequence;
  WPopup:=WNew(WX,WY,36,15,[CanMove,CanKill,CanAlter],'');
  IF WPopup=NoWindow THEN WRITE(CHR(Bel))
  ELSE
    BEGIN
      WShow(WPopup);
      WWriteStr('Help - Window Manager Revn ');
      WWriteStr(WVersion);                                 WWriteLn;
      WWriteStr('------------------------------------');   WWriteLn;
      WWriteStr('Enter Window Manager Mode using ESC.');   WWriteLn;
      WWriteStr('       In this mode you can type:');      WWriteLn;
      WWriteStr('ESC or <space> to leave this Mode or');   WWriteLn;
      WWriteStr('       to make a ''mark''');              WWriteLn;
      WWriteStr('<arrow keys> move cursor');               WWriteLn;
      WWriteStr('1..9   move cursor over screen');         WWriteLn;
      WWriteStr('S(how  window under cursor');             WWriteLn;
      WWriteStr('K(ill  window under cursor');             WWriteLn;
      WWriteStr('H(ide  window under cursor');             WWriteLn;
      WWriteStr('M(ove  window under cursor to ''mark'''); WWriteLn;
      WWriteStr('A(lter window under cursor to fit');      WWriteLn;
      WWriteStr('       within next two ''marks''');       WWriteLn;
      WWriteStr('?      give this help window');
      WShow(WTop);
    END;
END;

SEGMENT PROCEDURE WindowFunction;
VAR WTemp,WTop:Window;
    WF:sc_key_command;
    Ch:CHAR;
    Temp,X1,Y1,X2,Y2:INTEGER;
    Key:PACKED ARRAY [0..1] OF CHAR;
    
  PROCEDURE ZoneMove(Y,X,ZY,ZX:INTEGER);
  BEGIN
    WX:=(ScreenWidth DIV (ZX*2))*((2*(X-1))+1);
    WY:=(ScreenHeight DIV (ZY*2))*((2*(Y-1))+1);
  END;
    
BEGIN
  PlaceCursor;
  UNITREAD(SYSTERM,Key[0],1);
  Ch:=Key[0];
  {<space> (known as 'MARK') or ESC cause an exit from WindowFunction}
  WHILE (Ch<>' ') AND (Ch<>CHR(27)) DO BEGIN
    WF:=sc_map_crt_command(Ch);
    RemoveCursor;
    CASE WF OF
      sc_up_key   : IF WY>0 THEN WY:=WY-1;
      sc_down_key : IF WY<(ScreenHeight-1) THEN WY:=WY+1;
      sc_right_key: IF WX<(ScreenWidth -1) THEN WX:=WX+1;
      sc_left_key : IF WX>0 THEN WX:=WX-1;
      sc_not_legal: 
        BEGIN
          CASE Ch OF
                   {numbers used to allow rapid cursor moves by a keypad
                       7  8  9
                       4  5  6
                       1  2  3
                   added by Chris Lee}
           '7'   : ZoneMove(1,1,3,3);
           '8'   : ZoneMove(1,2,3,3);
           '9'   : ZoneMove(1,3,3,3);
           '4'   : ZoneMove(2,1,3,3);
           '5'   : ZoneMove(2,2,3,3);
           '6'   : ZoneMove(2,3,3,3);
           '1'   : ZoneMove(3,1,3,3);
           '2'   : ZoneMove(3,2,3,3);
           '3'   : ZoneMove(3,3,3,3);
           
           'A',
           'a'   : BEGIN
                     WTop:=WSequence; WTemp:=SCursin;
                     IF WTemp<>NoWindow THEN BEGIN
                       IF (CanAlter IN Windows[WTemp].Options) THEN BEGIN
                         WindowFunction; {get one corner - wait for 'mark'}
                         X1:=WX; Y1:=WY;
                         WindowFunction; {get opposite corner - wait for 'mark'}
                         X2:=WX; Y2:=WY;
                         WHide(WTemp);
                         IF X2<X1 THEN BEGIN
                           Temp:=X1; X1:=X2; X2:=Temp;
                         END;
                         IF Y2<Y1 THEN BEGIN
                           Temp:=Y1; Y1:=Y2; Y2:=Temp;
                         END;
                         WAlter(WTemp,X1,Y1,X2-X1+1,Y2-Y1+1,
                                Windows[WTemp].Options,'');
                         WShow(WTemp); WShow(WTop);
                       END
                       ELSE WRITE(CHR(Bel))
                     END
                     ELSE WRITE(CHR(Bel));
                   END;
           
           'H',
           'h'   : BEGIN
                     WTemp:=SCursIn;
                     IF WTemp<>NoWindow THEN BEGIN
                       IF (WSequence<>SCursIn) AND
                          (CanHide IN Windows[SCursin].Options) THEN
                         WHide(SCursIn)
                       ELSE WRITE(CHR(Bel)) {cannot hide current window}
                     END
                     ELSE WRITE(CHR(Bel))
                   END;
           
           'K',
           'k': BEGIN
                  WTemp:=SCursIn;
                  IF (WTemp<>NoWindow) AND (WTemp<>WSequence) THEN BEGIN
                    IF CanKill IN Windows[WTemp].Options THEN BEGIN
                      WHide(WTemp);
                      WDispose(WTemp);
                    END
                    ELSE WRITE(CHR(Bel))
                  END
                  ELSE WRITE(CHR(Bel))
                END;
           
           'M',
           'm': BEGIN
                  WTop:=Wsequence; WTemp:=SCursIn;
                  IF WTemp<>NoWindow THEN BEGIN
                    IF CanMove IN Windows[WTemp].Options THEN BEGIN
                      WindowFunction; {get new top left - wait for 'mark'}
                      X1:=WX; Y1:=WY;
                      WHide(WTemp);
                      WAlter(WTemp,X1,Y1,-1,-1,
                             Windows[WTemp].Options,'');
                      WShow(WTemp); WShow(WTop);
                    END
                    ELSE WRITE(CHR(Bel))
                  END
                  ELSE WRITE(CHR(Bel));
                END;
           
           'S',
           's'   : IF WSequence<>SCursIn THEN
                     BEGIN
                       IF SCursIn<>NoWindow THEN
                         BEGIN
                           WTop:=WSequence;
                           WHide(WSequence);
                           WShow(SCursIn);
                           WShow(WTop);
                         END
                       ELSE WRITE(CHR(Bel));
                     END;
           
           '?'   : WHelp;
          END;
          IF NOT(Ch IN ['1'..'9','A','a','H','h','K','k','M','m','S','s','?'])
            THEN WRITE(CHR(Bel));
        END;
    END; {CASE}
    IF NOT ScreenValid THEN RePaint;
    PlaceCursor;
    UNITREAD(SYSTERM,Key[0],1);
    Ch:=Key[0];
  END;
  RemoveCursor;
END;


========================================================================================
DOCUMENT :usus Folder:VOL12:wfiler.text
========================================================================================

PROGRAM WFiler; {revision 22-Feb-82 Austin Tate}

USES {$U Windows.code} WindowManager;

CONST Bel=7;

VAR Ch:CHAR;
    ScriptWindow,MessWindow,CommWindow:Window;

{$I-}

PROCEDURE ShowCommand(FirstTime:BOOLEAN);
VAR W:Window;
BEGIN
  IF FirstTime THEN
    BEGIN
      CommWindow:=WNew(0,2,12,10,
                       [HasHeading,CanHide,CanMove,CanAlter],'Commands....');
      WShow(CommWindow);
      WWriteStr('C(reate file');WWriteLn;
      WWriteStr('D(ate');       WWriteLn;
      WWriteStr('E(xt. dir');   WWriteLn;
      WWriteStr('L(ist dir');   WWriteln;
      WWriteStr('R(emove');     WWriteLn;
      WWriteStr('V(olumes');    WWriteLn;
      WWriteStr('............');WWriteLn;
      WWriteStr('?(Commands');  WWriteLn;
      WWriteStr('Q(uit');
    END
  ELSE
    BEGIN
      IF WCurrentWindow<>CommWindow THEN WShow(CommWindow);
    END;
END;

PROCEDURE ShowMessage(FirstTime:BOOLEAN);
VAR W:Window;
BEGIN
  IF FirstTime THEN MessWindow:=WNew(0,0,80,1,[CanMove],'')
  ELSE WClearAndShow(MessWindow);
END;

PROCEDURE ShowScript(FirstTime:BOOLEAN);
          {Script window should always be left at start of a newline}
VAR W:Window;
BEGIN
  IF FirstTime THEN
    BEGIN
      ScriptWindow:=WNew(0,17,80,7,
                       [HasHeading,CanHide,CanMove,CanAlter,CanScroll,CanPan],
                       'TypeScript');
      WShow(ScriptWindow);
    END
  ELSE
    BEGIN
      IF WCurrentWindow<>ScriptWindow THEN WShow(ScriptWindow);
    END;
END;

PROCEDURE OpenDirWindow(Title:STRING; Detail:BOOLEAN);
VAR W:Window;
    Width,X,Y:INTEGER;
BEGIN
  WXY(X,Y);
  IF Detail THEN Width:=60 ELSE Width:=31;
  W:=WNew(X,Y,Width,12,
          [HasHeading,CanAlter,CanMove,CanKill],
          CONCAT('Directory of ',Title,':'));
  WShow(W);
END;

PROCEDURE OpenVolsWindow;
VAR W:Window;
    X,Y:INTEGER;
BEGIN
  WXY(X,Y);
  W:=WNew(X,Y,13,13,[HasHeading,CanAlter,CanMove,CanKill],'Volumes');
  WShow(W);
END;

PROCEDURE OpenDateWindow;
VAR W:Window;
    X,Y:INTEGER;
BEGIN
  WXY(X,Y);
  W:=WNew(X,Y,19,1,[CanMove,CanKill],'');
  WShow(W);
END;

PROCEDURE FileH(Action:CHAR);

{ Assume all input through                                 }
{   WReadCh       input character from source stream       }
{   WReadLnStr    input string from source stream up to NL }
{                                                          }
{Assume all output through                                 }
{   WWriteCh      output character to destination stream   }
{   WWriteStr     output string    to destination stream   }
{   WWriteInt     output integer   to destination stream   }
{   WWriteLn      output a newline to destination stream   }

{Directory layouts, etc. ideas from various sources including}
{UCSD p-System Users' Society Software Library Volume 8      }

CONST VIDLENG=7;  {NUMBER OF CHARS IN A VOLUME ID}
      TIDLENG=15; {NUMBER OR CHARS IN A TITLE ID}
      MAXDIR=77;  {MAX NUMBER OF ENTRIES IN A Directory}

TYPE  DATEREC = PACKED RECORD
                  MONTH: 0..12;          {0 IMPLIES DATE NOT MEANINGFUL}
                  DAY: 0..31;            {DAY OF MONTH}
                  YEAR: 0..100           {100 IS TEMP DISK FILE FLAG}
                END {DATEREC};
      DIRRANGE = 0..MAXDIR;
      TID = STRING[TIDLENG];
 
      FILEKIND = (UNTYPEDFILE,XDSKFILE,CODEFILE,TEXTFILE,
                  INFOFILE,DATAFILE,GRAFFILE,FOTOFILE,SECUREDIR);
 
      DIRENTRY = RECORD
                   DFIRSTBLK: INTEGER;          {FIRST PHYSICAL DISK ADDR}
                   DLASTBLK: INTEGER;           {POINTS AT BLOCK FOLLOWING}
                   CASE DFKIND: FILEKIND OF
                     SECUREDIR,
                     UNTYPEDFILE:               {normally in DIR[0]..vol info}
                       (DVID: STRING[VIDLENG];  {NAME OF DISK VOLUME}
                        DEOVBLK: INTEGER;       {LASTBLK OF VOLUME}
                        DNUMFILES: DIRRANGE;    {NUM FILES IN DIR}
                        DLOADTIME: INTEGER;     {TIME OF LAST ACCESS}
                        DLASTBOOT: DATEREC);    {MOST RECENT DATE SETTING}
                     XDSKFILE,CODEFILE,TEXTFILE,INFOFILE,
                     DATAFILE,GRAFFILE,FOTOFILE:
                       (DTID: TID;              {TITLE OF FILE}
                        DLASTBYTE: 1..512;      {NUM BYTES IN LAST BLOCK}
                        DACCESS: DATEREC)       {LAST MODIFICATION DATE}
                 END {DIRENTRY};

VAR   DI: RECORD CASE BOOLEAN OF
            TRUE: (RECTORY: ARRAY [DIRRANGE] OF DIRENTRY);
            FALSE:(RBLOCKS: ARRAY[1..4] OF ARRAY[1..512] OF CHAR)
          END;
      Months: ARRAY [0..15] OF STRING[3];


PROCEDURE SPACES(V:INTEGER);
BEGIN
   FOR V:=V DOWNTO 1 DO WWriteCh(' ');
END;

PROCEDURE DIRINIT(UnitNum:INTEGER);
BEGIN
  UNITREAD(UnitNum,DI.RBLOCKS[1],2048,2); {LOAD DIR}
END {DIRINIT} ;

FUNCTION GETUNIT:BOOLEAN;
VAR UnitNum,I:INTEGER;
    GOOD:BOOLEAN;
    INSTRING:STRING;
    UNames:ARRAY[4:12] OF STRING[3];
BEGIN
   UNames[4]:='#4';
   UNames[5]:='#5';
   UNames[6]:='';
   UNames[7]:='';
   UNames[8]:='';
   UNames[9]:='#9';
   UNames[10]:='#10';
   UNames[11]:='#11';
   UNames[12]:='#12';
   If WCurrentWindow<>ScriptWindow THEN ShowScript(FALSE);
   WWriteStr('Volume or Unit: '); WReadLnStr(INSTRING);
   IF INSTRING<>'' THEN IF INSTRING[LENGTH(INSTRING)]=':' THEN BEGIN
      {$R-}
      INSTRING[0]:=PRED(INSTRING[0]);
      {$R+}
   END;
   IF INSTRING='*' THEN INSTRING:='#4';
   GOOD:=FALSE;
   IF INSTRING<>'' THEN BEGIN
      UnitNum:=3;
      REPEAT
         UnitNum:=SUCC(UnitNum);
         IF INSTRING[1]='#' THEN BEGIN
            IF INSTRING=UNames[UnitNum] THEN BEGIN
               DIRINIT(UnitNum);
               GOOD:=(IORESULT=0);
            END;
         END ELSE BEGIN
            IF UNames[UnitNum]<>'' THEN BEGIN
               DIRINIT(UnitNum);
               GOOD:=(IORESULT=0) AND (DI.RECTORY[0].DVID=INSTRING);
            END;
         END;
      UNTIL GOOD OR (UnitNum=12);
   END;
   IF NOT GOOD THEN BEGIN
      WWriteStr('Volume or Unit not on-line.');
      WWriteLn;
   END;
   GETUNIT:=GOOD;
END;

PROCEDURE Date(StandAlone:BOOLEAN);
BEGIN
  IF StandAlone THEN
    BEGIN
      OpenDateWindow;
      DirInit(4); {get date on system disk}
      WWriteStr('Date is:');
    END;
  WITH DI.RECTORY[0] DO
    BEGIN
      IF DLASTBOOT.MONTH > 0 THEN BEGIN
         SPACES(2);
         WWriteInt(DLASTBOOT.DAY,2);
         WWriteCh('-');
         WWriteStr(Months[DLASTBOOT.MONTH]);
         WWriteCh('-');
         WWriteInt(DLASTBOOT.YEAR,2);
      END;
    END;
END;

PROCEDURE Directory(DETAIL:BOOLEAN);
VAR LINES,I,LARGEST,FREEBLKS,USEDAREA,USEDBLKS: INTEGER;
    GS: STRING;

PROCEDURE SENDLN;
CONST WDepth=10;
VAR CH:CHAR;
BEGIN
   WWriteLn;
   LINES:=LINES+1;
   IF LINES=WDepth THEN BEGIN
      WWriteStr('Press <space> to continue');
      REPEAT
         WReadCh(CH,FALSE);
      UNTIL CH=' ';
      WClear;
      LINES:=0;
   END;
END;

PROCEDURE FREECHECK(FIRSTOPEN,NEXTUSED: INTEGER);
VAR FREEAREA: INTEGER;
BEGIN
  FREEAREA := NEXTUSED-FIRSTOPEN;
  IF FREEAREA > LARGEST THEN LARGEST := FREEAREA;
  IF FREEAREA > 0 THEN
    BEGIN FREEBLKS := FREEBLKS+FREEAREA;
      IF DETAIL THEN
        BEGIN
          WWriteStr('< UNUSED >      ');
          WWriteInt(FREEAREA,4);
          SPACES(11);
          WWriteInt(FIRSTOPEN,6);
          SENDLN;
        END
    END;
END {FREECHECK} ;

BEGIN
  IF NOT GETUNIT THEN EXIT(Directory);
  FREEBLKS := 0; USEDBLKS := 0;
  LARGEST := 0;
  GS:=DI.RECTORY[0].DVID;
  OpenDirWindow(GS,DETAIL);
  LINES:=0;
  FOR I := 1 TO DI.RECTORY[0].DNUMFILES DO
    WITH DI.RECTORY[I] DO
      BEGIN
        FREECHECK(DI.RECTORY[I-1].DLASTBLK,DFIRSTBLK);
        USEDAREA := DLASTBLK-DFIRSTBLK;
        USEDBLKS := USEDBLKS+USEDAREA;
        IF DACCESS.YEAR IN [1..99] THEN
        BEGIN
          WWriteStr(DTID);
          SPACES(TIDLENG-LENGTH(DTID)+1);
          WWriteInt(USEDAREA,4);
          IF DACCESS.MONTH > 0 THEN
            BEGIN
              SPACES(2);
              WWriteInt(DACCESS.DAY,2);
              WWriteCh('-');
              WWriteStr(Months[DACCESS.MONTH]);
              WWriteCh('-');
              WWriteInt(DACCESS.YEAR,2);
            END;
          IF DETAIL THEN
            BEGIN
              IF DACCESS.MONTH = 0 THEN SPACES(11);
              WWriteInt(DFIRSTBLK,6);
              WWriteInt(DLASTBYTE,6);
              GS := '     file';
              CASE DFKIND OF
                XDSKFILE: GS := 'Bad block';
                CODEFILE: GS := 'Code file';
                TEXTFILE: GS := 'Text file';
                INFOFILE: GS := 'Info file';
                DATAFILE: GS := 'Data file';
                GRAFFILE: GS := 'Graf file';
                FOTOFILE: GS := 'Foto file'
              END;
              SPACES(2);
              WWriteStr(GS)
            END;
          SENDLN;
        END;
      END;
  FREECHECK(DI.RECTORY[I-1].DLASTBLK,DI.RECTORY[0].DEOVBLK);
  WWriteInt(DI.RECTORY[0].DNUMFILES,0);
  WWriteStr(' files, ');
  WWriteInt(USEDBLKS,0);
  WWriteStr(' blocks used, ');
  WWriteInt(FREEBLKS,0);
  WWriteStr(' unused');
  IF DETAIL THEN BEGIN
     WWriteStr(', ');
     WWriteInt(LARGEST,0);
     WWriteStr(' in largest area.');
  END;
END; {Directory}

PROCEDURE Vols;
VAR UnitNum:INTEGER;
BEGIN
   OpenVolsWindow;
   WWriteStr(' 1  CONSOLE:'); WWriteLn;
   WWriteStr(' 2  KEYBOARD:');WWriteLn;
   WWriteStr(' 3  GRAPHIC:');
   FOR UnitNum:=4 TO 12 DO 
      BEGIN
        IF UnitNum=9 THEN
          BEGIN
            WWriteLn; WWriteStr(' 6  PRINTER:');
            WWriteLn; WWriteStr(' 7  REMIN:');
            WWriteLn; WWriteStr(' 8  REMOUT:');
          END;
        IF UnitNum IN [4,5,9,10,11,12] THEN BEGIN
        DIRINIT(UnitNum);
        IF IORESULT=0 THEN BEGIN
           WWriteLn;
           WWriteInt(UnitNum,2);
           SPACES(2);
           WWriteStr(DI.RECTORY[0].DVID);
           WWriteCh(':');
        END;
     END;
   END;
END;

PROCEDURE RemoveFile;
VAR STR:STRING;
    DFILE:FILE;
BEGIN
   IF WCurrentWindow<>ScriptWindow THEN ShowScript(FALSE);
   WWriteStr('Remove filename:');
   WReadLnStr(STR);
   RESET(DFILE,STR);
   IF IORESULT<>0 THEN
      WWriteStr('File does not exist.')
   ELSE BEGIN
      CLOSE(DFILE,PURGE);
      WWriteStr('File ');
      WWriteStr(STR);
      WWriteStr(' removed.');
   END;
   WWriteLn;
END;

BEGIN
   Months[ 0] := '???'; Months[ 1] := 'Jan';
   Months[ 2] := 'Feb'; Months[ 3] := 'Mar';
   Months[ 4] := 'Apr'; Months[ 5] := 'May';
   Months[ 6] := 'Jun'; Months[ 7] := 'Jul';
   Months[ 8] := 'Aug'; Months[ 9] := 'Sep';
   Months[10] := 'Oct'; Months[11] := 'Nov';
   Months[12] := 'Dec'; Months[13] := '???';
   Months[14] := '???'; Months[15] := '???';
   CASE Action OF
     'E':Directory(TRUE);
     'L':Directory(FALSE);
     'V':Vols;
     'R':RemoveFile;
     'D':Date(TRUE);
   END;
END;

PROCEDURE CreateFile;
CONST NoSuchFile=10;
VAR F:TEXT;
    Str:STRING;
    i:INTEGER;
    Abort:BOOLEAN;
BEGIN
  ShowScript(FALSE);
  WWriteStr('Create filename:');
  WReadLnStr(Str);
  RESET(F,STR);
  IF IORESULT<>NoSuchFile THEN WWriteStr('File open error.')
  ELSE
    BEGIN
      REWRITE(F,Str);
      WWriteStr('Give text - end with @');  WWriteLn;
      REPEAT
        WReadLnStr(Str);
        i:=POS('@',Str);
        IF i<>0 THEN Str:=COPY(Str,i-1,LENGTH(Str)-1);
        WRITELN(F,Str);
        Abort:=(IORESULT<>0);
      UNTIL (i<>0) OR Abort;
      IF Abort THEN WWriteStr('File write error.')
      ELSE
        BEGIN
          CLOSE(F,LOCK);
          IF IORESULT<>0 THEN WWriteStr('File close error.')
          ELSE WWriteStr('File created okay.');
        END;
    END;
    WWriteLn;
  END;
  
{$I+}
BEGIN
 WStartup; {- not used if Window manager in *SYSTEM.PASCAL} {<<<<<<<}
 {WInit; - needed if Window manager in *SYSTEM.PASCAL}      {<<<<<<<}
 ShowScript(TRUE);
 WWriteStr('ESC enters Window manager mode - then ? will get help information');
 WWriteLn;
 ShowCommand(TRUE);
 ShowMessage(TRUE); {does not actually show the window}
 WCursorXY(30,6);
 REPEAT
   ShowMessage(FALSE);
   WWriteStr('WFiler: give command letter: ');
   REPEAT
     WReadCh(Ch,FALSE);
     IF (Ch>='a') AND (Ch<='z') THEN Ch:=CHR(ORD(Ch)-32);
   UNTIL Ch IN ['?','C','D','H','R','E','L','V','Q'];
   WWriteCh(Ch); WWriteLn;
   IF (Ch='H') OR (Ch='?') THEN ShowCommand(FALSE)
   ELSE IF (Ch='C') THEN CreateFile
   ELSE IF (Ch<>'Q') THEN FileH(Ch);
 UNTIL Ch='Q';
 WHide(ScriptWindow);
 WHide(CommWindow);
 WHide(MessWindow);
 WDispose(ScriptWindow);
 WDispose(CommWindow);
 WDispose(MessWindow);
 {other windows left on screen for info in case WindowManager is a
  System Unit in *SYSTEM.PASCAL}
END.



========================================================================================
DOCUMENT :usus Folder:VOL12:windows.text
========================================================================================

{ L W.LISTING.TEXT}
{ R-}
UNIT WindowManager;  {Austin Tate (ERCC) and Chris Lee (INMOS)}

INTERFACE

  {Window Manager for the UCSD p-System}
  {Windows are displayed as rectangular areas on the screen, bordered by
   a frame and optionally headed by a heading.  Each window has its own
   size, screen location, text area, cursor and status information.
   Each window may be written into and will scroll independently, and
   may be cleared, moved, changed in size, etc. by a user's program.

   During any input operation the user may escape into 'Window Manager
   Mode' (and subsequently return to 'Input Mode', to complete the input).
   In Window Manager Mode the Window Manager uses a special cursor which
   is independent of any window. This cursor is used to indicate screen
   position parameters to the Hide, Show, Alter, Move and Kill commands.
   Whether or not a particular command may be applied to a particular
   window is controlled by the user's program.
  }

  CONST WVersion='22-Feb-82';
        NoWindow=0;
        MaxWindow=10;

  TYPE  Window=NoWindow..MaxWindow;
        WindowOptions=(CanHide,CanMove,CanAlter,CanKill,
                       HasHeading,CanScroll,CanPan);
        WindowAttributes=SET OF WindowOptions;

{Initialisation Routines}
  
  PROCEDURE WStartup;
  {Called by *SYSTEM.STARTUP to REALLY initialise}
  {If window manager is placed in *SYSTEM.PASCAL then you MUST supply
   a *SYSTEM.STARTUP that calls WStartup. Thereafter any program which
   uses the window manager should initialise via WInit, the effect of which
   is to repaint the screen as it was when the last using program terminated.
   If Window Manager is not in *SYSTEM.PASCAL then use WStartup always}

  PROCEDURE WInit;
  {Initialise Window Manager System}
  {just redisplays all windows}
  {if Manager is a system unit, all windows survive program changes}

{Routines to create, alter, show, clear, hide and dispose of windows}

  FUNCTION  WNew(WatX,WatY,WSizeX,WSizeY:INTEGER;
                 WControls:WindowAttributes;
                 WHeading:STRING):Window;
  {Get new window}

  PROCEDURE WAlter(W:Window;
                   WatX,WatY,WSizeX,WSizeY:INTEGER;
                   WControls:WindowAttributes;
                   WHeading:STRING);
  {Alter existing window}
  {WatX,WatY,SizeX,SizeY -ve means do not alter}
  {WControls replaces existing window attributes}
  {Window must not be in show when WAlter called}

  PROCEDURE WShow(W:Window);
  {Display window and set it as "current" one}

  PROCEDURE WClearAndShow(W:Window);
  {Clear window, then "Show" it}

  PROCEDURE WHide(W:Window);
  {Remove window from screen - it is not disposed of}

  PROCEDURE WDispose(W:Window);
  {Dispose of old window}
  {Window must not be in show when WDispose called}

{The following procedures all apply to the "current" last shown window}

  PROCEDURE WClear;
  {Clear Window}
  
  PROCEDURE WClrEOL;
  {Clear remainder of current line}
  
  PROCEDURE WClrEOS;
  {Clear remainder of window}

  PROCEDURE WGotoXY(X,Y:INTEGER);
  {Set Window cursor to X,Y}
  {X,Y are relative to top left of window - base of 0, excluding heading}

  PROCEDURE WWriteCh(Ch:CHAR);
  {Write Ch at cursor position in window}
  {Non printable chs map to bell}

  PROCEDURE WWriteStr(Str:STRING);
  {Write Str at cursor position in window}
  {MUST NOT CONTAIN NON PRINTABLE CHARS}

  PROCEDURE WWriteInt(Int,Width:INTEGER);
  {Write Int at cursor posn in window}
  {Equivalent to WRITE(Int:Width) in Pascal}
  {Width may be 0 (or -ve) to mean as narrow as possible}

  PROCEDURE WWriteLn;
  {Write newline at cursor position in window}
  {If cursor goes below base of window, window is cleared}

  PROCEDURE WReadCh(VAR Ch:CHAR;Echo:BOOLEAN);
  {Get character from keyboard}
  {Window functions can only take place within WReadCh}
  {Any non window function ch is returned to user     }
  {Echo is controlled by user - non printable chs echo as bell}
  {Other Window Reading Procedures - below - use WReadCh}

  PROCEDURE WReadLnStr(VAR Str:STRING);
  {Get a string from keyboard - echoed}
  {String is ended by newline. Only edit ch allowed is backspace}
  {Non printable chs are not returned - but echo as bell}

  PROCEDURE WReadLnInt(VAR Int:INTEGER);
  {Get an integer from keyboard - echoed}
  {Integer is ended by newline. Only edit ch allowed is backspace}
  {Non printable chs are not returned - but echo as bell}

  PROCEDURE WReadLn(Echo:BOOLEAN);
  {Read up to next newline from keyboard}
  {Non printable chs echo as bell}

{the following functions and procedures are utilities on windows}

  FUNCTION  WInWindow(X,Y:INTEGER):Window;
  {Returns window in which position X,Y occurs - NoWindow if none}
  {X,Y in screen coordinates}

  FUNCTION  WChAtXY(X,Y:INTEGER; W:Window):CHAR;
  {Return Ch under screen position X,Y in W}
  {Space returned if X,Y not in Window, or NoWindow}
  {Ch need not be in view at time of call}

  PROCEDURE WXY(VAR X,Y:INTEGER);
  {Get Coordinates of window manager cursor - in window coordinates}

  PROCEDURE WCursorXY(X,Y:INTEGER);
  {Set coordinates of window manager cursor - in window coordinates}

  FUNCTION WCurrentWindow:Window;
  {Return Current Window - one last shown - may be NoWindow}
  
  {HISTORY
  
   Copyright: Austin Tate, ERCC.  All rights reserved.
              This program may be used for non-commercial purposes
              by users of the UCSD p-System provided that this
              copyright notice appears in the source.  Enquiries for
              other uses should be directed to the copyright owner.
  
   The Window Manager was originally written in March 1981 by
   Austin Tate, ERCC as a demonstration for a course on Office
   Systems and Advanced Personal Computers.
   -------------------------
   It was subsequently modified by Chris Lee while at INMOS up
   to 10-Feb-82. The major changes he made were:
   
   I/O optimisation - all I/O is delayed as long as possible, and
   is done in as large units as possible, via UNITWRITE (asynch!!!),
   and isn't done at all if what we want is on the screen already.
   See routines flushoutput and repaint. Repaint certainly pays
   its way (try moving and altering windows with the original and
   this version), flushoutput almost certainly doesn't - it makes
   lines zap out in one swell foop, but stops the dreaded dots.
   
   Window Functions - on the operator interface are all handled
   inside the window manager. During input use ESC to toggle between
   window manager and input modes (and notice the cursor change when 
   you do). See WindowFunction. Notice that screen position parameters
   are signalled by moving the cursor and typing ESC or <space> (known
   as a 'mark' in Window Manager Mode).  Eg,  to move a window type
          ESC                              -- to enter window mode
          <move cursor into window to be moved>
          M or m                           -- to request a move
   ---->  <move cursor to new top left corner position>
          <space> or ESC                   -- the window moves at this point
          <space> or ESC                   -- to return to input mode
                 
   NB at point ----> WindowFunction calls itself recursively. You
      can nest window functions (and get into a real mess) if you want).
      The interface to WNew has changed to allow the programmer to 
      control what WindowFunctions the user may apply to a window.
   
   Frames - are drawn by characters. There are CONSTs for the four
   corners and four sides so if you have forms drawing chars you
   should be able to make things look pretty
   
   Scrolling and Panning - misc minor changes. Scroll by one third
   of window depth rather than one line. Only re-pan at input time.
   Both these mods are designed to eliminate unnecessary I/O and
   repainting.
   
   To improve efficiency WWriteStr assumes that only printable
   chars are in the string. 
   
   This version was produced during experimentation into window
   management. Hence the code hasn't been beautified and bugs
   may be present.
   -------------------------
   The Window Manager as modified by Chris Lee was then altered in
   some minor respects by Austin Tate prior to release to the
   UCSD p-System Users' Society (USUS) Software Library in February 1982.
 }


IMPLEMENTATION
{$I w.impln}
END.

========================================================================================
DOCUMENT :usus Folder:VOL13:declare.text
========================================================================================


       
{*******************************************************************}
{                                                                   }
{  RUNON  Copyright (C) 1980   Wynn Newhouse and Herb Jellinek.     }
{                              All rights reserved.                 }
{                                                                   }
{*******************************************************************}
 
 
 
{**********************************************************************
 
  Explanation of global CONSTants.
 
   MINLINEWIDTH    The minimum size that the paper width can be set to.
   MAXLINEWIDTH    The maximum size that the paper width can be set to.
                   (all buffers are this long.)
   MAXNUMSIZE      Maximum number of digits of the page number.
   MINPAPLEN       The minimum size of the paper length.
   MAXCMDLENGTH    The length of the longest dot command plus one (1).
                   A space must be added to the string name of each
                   command. Check this when adding commands.    
   MAX_FILES       The maximum number of open INCLUDE files at one time.
   BORDERSIZE      Amount of space reserved at top and bottom of
                   page to serve as border.
   MINSPACING      Minimum spacing between lines, as with typewriters
                   (i.e. spacing 1 means no intervening blank lines)
   MAXSPACING      Maximum spacing between lines.
   LCOFFSET        ORD('a') - ORD('A') : used in case conversion.
   R_OFFSET        Offset from right side of page to start of
                   page number.
   BLANK_HEADING   Number of lines to skip at top of first page.
   VERSION_NUMBER  The current version of RUNON.
 
**********************************************************************}
 
 
 
 
const
   minlinewidth   = 30;
   maxlinewidth   = 132;
   maxnumsize     = 4;
   minpaplen      = 20;
   maxcmdlength   = 12;
   max_files      = 5;
   bordersize     = 14;
   minspacing     = 1;
   maxspacing     = 5;
   lcoffset       = 32;  
   r_offset       = 5;  
   blank_heading  = 7;
   uca            = 'A';
   ucz            = 'Z';
   lca            = 'a';
   lcz            = 'z';
   blank_char     = ' ';
   zero           = '0';
   nine           = '9';
   dot            = '.';
   pound          = '#';
   underline      = '_';
   nul            = '';
   version_number = 'V2';
 
{**********************************************************************
 
   Description of global types.
 
   COMMANDTYPE    Enumerated type that represents current status to
                  OUT_PROC.
   ERRORTYPE      Type representing error.
   FILLTYPE       Type representing the current filling mode.
   HARD_SOFT      Used to represent 'malleability' in determining
                  flexibility attribute of spaces.
   OLD_NEW        Used in SYSVARS to 'point' to current settings.
   ATTRIB         Attributes that a character may have.  
   CHAR_REC       One individual element of internal and output
                  buffers.  Represents one character.
   LINE_OF_RECS   An array of CHAR_RECs.
   BUFFER         A LINE_OF_RECS with STart and ENd pointers.
   LINE_OF_CHARS  An array of characters.
   STRNG          A LINE_OF_CHARS with STart and ENd pointers.
   MISCINFO       A record used to hold system values.
   STACK_ENTRY    The current variables that need to be saved
                  when INCLUDEing a file, and recursively calling  
                  PROCESS_FILE.
 
**********************************************************************}
 
 
 
 
type
   commandtype   = (brk,    fig,    indt,   pag,    tstpag, skp,    nofil,
                    cntr,   til,    inclu,  fil,    lmar,   rmar,   onnum,
                    offnum, num,    onpag,  offpag, papsiz, spc,    std,
                    justfy, norm,   autop,  noauto, autset, upper,  lower,
                    same,   cmnt);
 
   errortype     = (badcmd,  tooshrt, toowide, toonrrw, badsym,  argmsng,
                    nonnum,  toolow,  toohgh,  tilwide, cntwide, figbad,
                    wdlen,   dblnam,  incerr,  filerr,  nesdep,  aplow,
                    aphgh,   cmderr,  baddelm, dlmmsng, endlead, badcnt);
 
   filltype      = (justification, filling, nofilling);
 
   cmd_name      = packed array [1..maxcmdlength] of char;
 
   posint        = 0..maxint;
 
   hard_soft     = (hard, soft);
 
   old_new       = (old, new);   
 
   attrib        = (u_line, u_case, l_case, xpand);
 
   attrib_set    = set of attrib;
 
   char_rec      = record
                      ch           : char;
                      malleability : hard_soft;
                      length       : posint;
                      atts         : attrib_set;
                   end;
 
   line_of_recs  = packed array [1..maxlinewidth] of char_rec;
 
   buffer        = record
                      st,
                      en   : posint;
                      str  : line_of_recs;
                   end;
 
   line_of_chars = packed array [1..maxlinewidth] of char;
 
   strng         = record
                      st,
                      en  : posint;
                      str : line_of_chars;
                   end;
 
   Miscinfo      = record
                      version         : old_new;
                      fill_mode       : filltype;
                      paging,
                      numbering,
                      ap_mode         : boolean;
                      lm,
                      rm              : posint;
                      ap_indent,
                      ap_skip,
                      paper_width,
                      paper_length,
                      chars_in_line,
                      printable_lines : posint;
                      spacing         : minspacing..maxspacing;
                   end;
 
  stack_entry    = record
                      name   : string;
                      line   : posint;
                      in_buf : strng;
                   end;
 
{**********************************************************************
 
  Explanation of global variables.
 
   F,
   S0..S5,
   DEST           F is used to test for the existence of a file or
                  volume. S0 and DEST are the file variables for
                  the main input and output files. S1..S5 are used
                  to INCLUDE other source files.
   FILE_IN,
   FILE_OUT       Actual names of input and output files.
   SYSVARS        Contains commonly-used system values, such as
                  margins, etc.  Subject to time-warp effect.
   PAGEINFO       Contains other system information pertinent
                  to output page, such as page number, etc.
                  Not subject to time-warp effect.
   STD_VALS       Contains default values for system initialization.
   INPUT_BUF      Buffer into which characters are initially read
                  from input file.
   INTERNAL_BUF,
   OUTPUT_BUF     Two buffers that hold intermediate representations
                  of the text.
   GLOBAL_CASE    The case that all text read in is taken to be. Over-
                  ridden by special character commands.
   N, M           Global variables used to represent dot-command
                  parameters.
   TEXT_DELIMS    The set of legal characters that can be used to
                  delimit text parameters for dot commands.
   LEADIN_CHARS   Set of charcters used as first character of
                  all embedded command sequences.
   DELIM_CHARS    Set of control characters plus space and pound sign.
                  These are the valid delimiters.
   LOCK_OPS,
   WORD_OPS       These are the characters that may follow LEADIN_CHARS.
   SPACE_CHARS    Set of space and pound-sign characters.
   LC_LETTERS     Set of lower-case letters.
   LOCK_STATUS    A set that contain current attributes as set
                  by the scanner, assigned to characters being scanned.
   LEAD_BLANK     Boolean set by READLINE to indicate that first character
                  of INPUT_BUF is a blank.  Used to start a new paragraph. 
   BLANKLINE,
   DOT_COMMAND    Flags set by READLINE to indicate status of input
                  buffer.
   NUMBERS        Characters representing digits '0' through '9'.
   ACT_CMDS       'Constant' set of commands which get routed to
                  output processor.
   TEXT_CMDS      The set of commands that take textual parameters.
   MORE_INPUT     Boolean flag which indicates if the internal
                  buffer contains unprocessed text.
   VC_IN_LINE     Number of visible characters in current output line.
   IC_IN_LINE     Number of invisible characters in current output line.
   LN_NUMBER      Current line number of input file.  Used only
                  by ERROR.
   HARD_SPACE,
   SOFT_SPACE,
   BLANK_BUF,
   BLANK_STRING   'Constant' blank-like thingies, used to
                  reinitialize characters, buffers, etc.
   CMD_STRINGS    The actual string names for each commandtype. Used by
                  GET_COMMAND to match abbreviations. 
   FILE_STACK     A stack used to keep track of the level of nesting
                  of INCLUDE files. The file names are saved for error
                  testing purposes.
 
**********************************************************************}
 
 
 
 
var
   f,
   s0, s1, s2,
   s3, s4, s5,
   dest          : text;
 
   file_in,
   file_out      : string;
 
   sysvars       : array [old_new] of miscinfo;
 
   pageinfo      : record
                      currline,
                      currpage       : posint;
                      figure_set,
                      figure_pending : boolean;
                      figure_size    : posint;
                      title          : strng;
                   end;
 
   std_vals      : miscinfo;
 
   input_buf     : strng;
   internal_buf,
   output_buf    : buffer;
 
   global_case   : set of u_case..l_case;
 
   n, m          : posint;
 
   text_delims,
   leadin_chars,
   delim_chars,
   space_chars,
   uc_letters,
   lc_letters,
   word_ops,
   lock_ops      : set of char;
 
   numbers       : set of zero..nine;
 
   act_cmds      : set of brk..nofil;
   text_cmds     : set of cntr..inclu;
 
   lock_status   : attrib_set;
 
   more_input,
   blankline,
   dot_command,
   lead_blank    : boolean;
 
   vc_in_line,
   ic_in_line,
   ln_number     : posint;
 
   soft_space,
   hard_space    : char_rec;
   blank_buf     : buffer;
   blank_string  : strng;
 
   cmd_strings   : packed array [commandtype] of cmd_name;
 
   file_stack    : record
                      ptr   : 0..max_files;
                      stack : packed array[1..max_files] of stack_entry;
                   end;
 
   bs            : char;
 
 
 


========================================================================================
DOCUMENT :usus Folder:VOL13:defalt_doc.text
========================================================================================



.comment            !---------------------------------!
.comment            !                                 !
.comment            !       RUNON documentation       !
.comment            !          Default values         !
.comment            !                                 !
.comment            !          August 3, 1980         !
.comment            !                                 !
.comment            !---------------------------------!


.skip 2 .center " ^^^&default values\^\& " .skip 1

The following are the values that Runon uses to process
the text, until they are reset by the use of dot commands.
.spacing 2 .nofill
 
1.  Page numbers on every page except the first
2.  Spacing 1 between lines
3.  Justification enabled
4.  Left margin 10
5.  Right margin 70
6.  Paper size : Length 66 lines, Width 80 characters
7.  Autoparagraph : enabled, skip 1, indent 5
8.  Paging enabled
9.  Case : same
.spacing 1 .justify


========================================================================================
DOCUMENT :usus Folder:VOL13:dopage.text
========================================================================================

 
{**********************************************************************
 
  DO_PAGE is called in order to begin each new page of output, other
  than the first.  If page numbering is in effect, the current page
  number is written out.  If a title exists, it too is written out.
 
  The routine also takes care of 'pending figures' - that is,
  if a figure was too large to fit on the previous page, it is
  placed at the top of the current one.
 
  PUT_TITLE takes care of processing and centering the title. Notice
  that the global attribute set, LOCK_STATUS, is saved and set to
  nil before SCANNER is called, and restored afterwards. This ensures
  that SCANNER will not process the title improperly. Note that the
  current line, PAGEINFO.CURRLINE, is reset to 0 as the title is
  output using OUT_PROC, which increments the current line.
 
**********************************************************************}
 
 
Procedure do_page;
 
const
   down_skip = 2;
 
var
   i : posint;
 
 
 
      Procedure put_title; 
 
      var
         temp_buf    : buffer;
         save_status : attrib_set;
 
      begin
         temp_buf := blank_buf;
 
         save_status := lock_status;
         lock_status := [];
 
         scanner(pageinfo.title.st,
                 pageinfo.title.en,
                 pageinfo.title.str,
                 temp_buf);
 
         lock_status := save_status;
 
         center_buffer(temp_buf,
                       1,
                       sysvars[new].paper_width,
                       pageinfo.title.en,
                       tilwide                 );
 
         output_buf := temp_buf;
 
         out_proc(brk);
 
         pageinfo.currline := 0;
      end;  { put_title }
 
 
 
begin  { do_page }
 
   page(dest);
   writeln(dest);
   writeln(dest);
 
   if sysvars[new].numbering then
      begin
         for i := 1 to (sysvars[new].paper_width - maxnumsize - r_offset) do
            write(dest, blank_char);
         writeln(dest, pageinfo.currpage:5);
      end
   else
      writeln(dest);
 
   writeln(dest);
 
   pageinfo.currline := 0;
   pageinfo.currpage := pageinfo.currpage + 1;
 
   if pageinfo.title.en >= pageinfo.title.st
      then put_title
      else writeln(dest);
 
   for i := 1 to down_skip do
      writeln(dest);
 
   if pageinfo.figure_pending then
      begin
         pageinfo.figure_pending := false;
         putline(pageinfo.figure_size);
      end;
 
end;  { do_page }
 
{**********************************************************************
 
  PUT_LINE puts CR/LF pairs into the output file at the end of each
  output line.  It is called by the skip, figure, and page routines.
 
  If there is not enough space on the page to skip the desired number
  of lines (when in paging mode), the routine calls DO_PAGE, which
  then outputs any pending figure.  The essential features of DO_PAGE
  are simulated here, with the exception of the actual paging itself,
  when not in paging mode.
 
  PUT_LINE is declared FORWARD as it is called by DO_PAGE.  There is
  no possibility of infinite recursion.
 
**********************************************************************}
 
 
 
 
{***********************************************}
{                                               }
{    Forward declaration in SYSGEN file.        }
{-----------------------------------------------}
{                                               }
{    Procedure putline(n : posint); Forward;    }
{                                               }
{***********************************************}
 
 
Procedure putline;
 
var
   crlf : posint;
 
begin
   pageinfo.currline := pageinfo.currline + n;
 
   if sysvars[new].paging then
      begin
         if pageinfo.currline < sysvars[new].printable_lines then
            for crlf := 1 to n do
               writeln(dest)
         else
            do_page;
      end
   else  { not paging }
      begin
         for crlf := 1 to n do
             writeln(dest);
 
         if pageinfo.currline > sysvars[new].printable_lines then
            begin
               pageinfo.currline := pageinfo.currline -
                  sysvars[new].printable_lines;
 
               pageinfo.currpage := pageinfo.currpage + 1;
 
               if pageinfo.figure_pending then
                  begin
                     pageinfo.figure_pending := false;
                     putline(pageinfo.figure_size);
                  end;
            end
      end
end;  { putline }
 
 {**********************************************************************
 
  SHOVE_BUFFER writes the output buffer to the output file,
  taking into account the attributes of each character, if it has
  any.
 
  After the buffer has been 'shoved', several important global variables
  are reset.  The current VERSION of SYSVARS is set to point to the
  NEW values, the 'visible character count' is set to zero, the
  'invisible character count' is set to zero, and the output buffer is
  cleared.  If a figure has been set, it is output; otherwise,
  (spacing factor) number of lines are output.
 
**********************************************************************}
 
 
Procedure shove_buffer;
 
var
   i, j    : posint;
   khar    : char;
   attribs : attrib_set;
 
 
begin
 
   for i := 1 to output_buf.en do
      begin
         attribs := output_buf.str[i].atts;
         khar := output_buf.str[i].ch;
         if attribs <> [] then
            begin
               if attribs = [xpand] then
                  for j := 1 to output_buf.str[i].length do  
                     write(dest, blank_char)
               else
                  begin
                     if u_line in attribs then
                        begin
                           write(dest, underline);
                           write(dest, bs);
                        end;
                     if l_case in attribs then
                        begin
                           if khar in uc_letters then
                              khar := chr(ord(khar) + lcoffset);
                        end
                     else
                        if u_case in attribs then
                           if khar in lc_letters then
                              khar := chr(ord(khar) - lcoffset);
                     write(dest, khar);
                  end; { else }
            end { if attribs }
         else  { no attributes }
            write(dest, khar);
 
      end;  { for }
 
   sysvars[new].version := new;
   output_buf := blank_buf;
   vc_in_line := 0;
   ic_in_line := 0;
 
   if pageinfo.figure_set then
      begin
         pageinfo.figure_set := false;
         putline(pageinfo.figure_size);
      end
   else
      putline(sysvars[new].spacing);
 
end;  { shove_buffer }
 
{**********************************************************************
 
  MOVE_WORD moves the next word, starting from the STth element of
  the internal buffer (aka INTERNAL_BUF) into the output buffer
  (OUTPUT_BUF) starting with its EN+1st element.  The aforementioned
  counters get updated; the ST pointer to one beyond the end of
  the word in the internal buffer, and the EN pointer to the end of
  the word in the output  buffer.  A space is appended to the end
  of each word.
 
  (A word is defined to be any contiguous sequence of characters,
   delimited by SOFT_SPACEs.)
 
  Other variables that get updated are: VC_IN_LINE, which contains
  the number of visible chars in the output buffer; IC_IN_LINE,
  which contains the number of invisible characters in the buffer;
  EO_INPUT, which signals that the internal buffer is empty; and
  EO_OUTPUT, which signals the output buffer as being full.
 
  CHARS_FIT is a function used to determine if
 
    a) there is enough space for the visible-length of the 
       word between the margins;
    b) the total number of characters in the word added
       to the number of characters already in the buffer
       does not exceed the length of the buffer.
 
**********************************************************************}
 
Procedure move_word(var eo_input, eo_output : boolean);
 
var
   vc_in_word,
   ic_in_word,
   buf_pos     : posint;
   ablank,
   aword,
   ic_only     : boolean;
   curr_char   : char_rec;
 
 
      Procedure move_to_output(first_ch, last_ch : posint);
 
      var
         word_len,
         offset    : posint;
 
      begin
         word_len := last_ch - first_ch + 1;
 
         for offset := 1 to word_len do
            output_buf.str[output_buf.en + offset] :=
               internal_buf.str[offset + first_ch - 1];
 
         internal_buf.st := last_ch + 1;
         output_buf.en := output_buf.en + word_len;
      end;  { move_to_output }
 
 
      Function chars_fit : boolean;
  
      begin
         chars_fit :=
            ((vc_in_line + vc_in_word) <= sysvars[v].chars_in_line) and  
               ((sysvars[v].lm + vc_in_line + vc_in_word +
                  ic_in_word + ic_in_line) <= maxlinewidth);
      end;  { chars_fit }
 
 
begin  { move_word }
   ic_in_word := 0;
   vc_in_word := 0;
   ablank := true;
   aword := true;
   buf_pos := internal_buf.st;
 
   while ablank and (buf_pos <= internal_buf.en) do
      if internal_buf.str[buf_pos] = soft_space
         then buf_pos := buf_pos + 1
         else ablank := false;
 
   internal_buf.st := buf_pos;
 
   if buf_pos > internal_buf.en then
      eo_input := true
   else
      begin
         ic_only := true;
 
         while aword and (buf_pos <= internal_buf.en) do
            begin
               curr_char := internal_buf.str[buf_pos];
 
               if curr_char = soft_space then
                  aword := false
               else
                  begin
                     buf_pos := buf_pos + 1;
 
                     if curr_char.length > 0 then 
                        begin
                           vc_in_word := vc_in_word + curr_char.length;
                           ic_only := false;
                        end
                     else
                        ic_in_word := ic_in_word + 1;
                  end;
            end; { while }
 
         if vc_in_word > sysvars[v].chars_in_line then
            error(wdlen, buf_pos - 1, input_buf.str);
 
         if chars_fit then
            begin
               move_to_output(internal_buf.st, buf_pos - 1);
               vc_in_line := vc_in_line + vc_in_word;
               ic_in_line := ic_in_line + ic_in_word;
 
               if buf_pos > internal_buf.en then
                  eo_input := true;
 
               if vc_in_line < sysvars[v].chars_in_line then
                  begin
                     if not(ic_only) then
                        begin
                           vc_in_line := vc_in_line + 1;
                           output_buf.en := output_buf.en + 1;
                           output_buf.str[output_buf.en] := soft_space;
                        end;
                  end
               else
                  eo_output := true;
            end
         else
            eo_output := true;
 
   end { else }
end; { move_word }
 
{**********************************************************************
 
  JUSTIFY is essentially an implementation of Findlay and Watt's
  text-justification algorithm (see F & W, p.238).  It justifies
  the text in the output buffer, between the STth and right-marginth
  positions.
 
**********************************************************************}
 
 
Procedure justify;
 
var
   i, gaps, spread, pos : posint;
   extraspaces          : integer;
 
 
begin
 
   i := output_buf.en;
 
   while output_buf.str[i] = soft_space do
      i := i - 1;
 
   output_buf.en := i;
 
   extraspaces := sysvars[v].rm - (output_buf.en - ic_in_line);
   if extraspaces > 0 then
      begin
         gaps := 0;
 
         for i := output_buf.st to output_buf.en do
            if output_buf.str[i] = soft_space then
               gaps := gaps + 1;
 
         if gaps > 0 then
            begin
               pos := output_buf.st;
               while pos <= output_buf.en do
                  if output_buf.str[pos] = soft_space then  
                     begin
                        spread := extraspaces div gaps;
                        if spread > 0 then
                           with output_buf.str[pos] do
                              begin
                                 atts := [xpand];
                                 length := spread + 1;
                              end; { with }
                        extraspaces := extraspaces - spread;
                        gaps := gaps - 1;
                        pos := pos + spread + 1;
                     end
                  else
                     pos := pos + 1;
            end; { if }
      end; { if }
end; { justify }
 
{**********************************************************************
 
  This is the top level of the output-processor.  CMD contains a
  representation of the command to be performed.  NORM is the case
  where text is processed normally (i.e. not by explicit command).
 
  The modules described:
 
    BRK     This is the break command.  If the output buffer is not
            empty, it merely causes the output buffer to be written
            to the destination file.
 
    FIG     If a figure is set, this errors out; otherwise, it
            sees if there is room remaining on the page for
            the figure.  If so, the figure is put out immediately,
            if the current output line is empty. Otherwise, the
            figure is SET. If there isn't enough room on the current
            page, the figure is PENDING.
 
    INDT    Causes a BRK; indents next line N-1 spaces beyond
            the left margin.
 
    PAG     Causes a BRK; if it pages on break, does not page output
            file, else pages file. Ignored in non-paging mode.
 
    TSTPAG  Tests if at least N lines are left on the current page,
            and if not, causes a BRK and a PAG. Ignored in non-paging
            mode.
 
    SKP     Causes a BRK; puts out N * SPACING blank lines.
 
    NORM    'Normal' entry to output processor.
 
            If in filling or justification mode, an auto-paragraph
            is done if AP_MODE and LEAD_BLANK are set. Otherwise, the
            left margin is put into the output buffer, if it is empty.
            Then, as many words as possible are put into the output
            buffer, until the output buffer is full or the internal
            buffer is empty. If the output buffer is full, the text
            is then justified, if in justify mode, and shoved out.
 
            In nofill mode, the leftmargin is first put into the
            output buffer, and then the internal buffer is mapped into
            the output buffer.  If the input line is blank, as deter-
            mined by READLINE, only a carriage return is shoved.
            If the length of the text in the internal buffer exceeds
            MAXLINEWIDTH - LM, it is truncated.
 
**********************************************************************}
 
 
 
 
{*******************************************}
{                                           }
{   header is located in SYSGEN file        }
{-------------------------------------------}
{                                           }
{   Procedure out_proc(cmd : commandtype);  }
{                                           }
{   var                                     }
{      i, j      : posint;                  }
{      v         : old_new;                 }
{      eo_input,                            }
{      eo_output : boolean;                 }
{                                           }
{*******************************************}
 
 
 
Procedure put_left_margin;
 
begin
   output_buf.en := sysvars[new].lm - 1;
   output_buf.st := sysvars[new].lm;  
end;  { put_left_margin }
 
 
 
Procedure break;
 
begin
  if output_buf.en >= output_buf.st then
     shove_buffer
  else
     sysvars[new].version := new;
end; { break }
 
 
 
Procedure auto_indent;
 
begin
   lead_blank := false;
 
   break;
   putline(sysvars[new].ap_skip);
 
   n := sysvars[new].ap_indent;
   if (sysvars[sysvars[new].version].lm + n) >
       sysvars[sysvars[new].version].rm then
          error(aphgh, 0, input_buf.str);
   out_proc(indt);
end;  { auto_indent }
 
 
 
begin  { output processor }
 
   case cmd of
      brk    : break;
      fig    : if not(sysvars[new].paging) then
                  putline(n)
               else
                  if (sysvars[new].printable_lines -
                       pageinfo.currline) < n then
                     begin
                        pageinfo.figure_pending := true;
                        pageinfo.figure_size := n;
                     end
                  else
                     if output_buf.st > output_buf.en then
                        putline(n)
                     else
                        begin
                           pageinfo.figure_set := true;
                           pageinfo.figure_size := n;
                        end;
      indt   : begin
                  break;
                  vc_in_line := n;
                  output_buf.st := sysvars[new].lm + n;
                  output_buf.en := sysvars[new].lm + (n - 1);
               end;
      pag    : begin
                  break;
                  if not((pageinfo.currline = 0) and
                     sysvars[new].paging) then
                        do_page;
               end;
      tstpag : if sysvars[new].paging and
                  ((pageinfo.currline + n * sysvars[new].spacing) > 
                     sysvars[new].printable_lines) then
                        begin
                           break;
                           if not(pageinfo.currline = 0) then
                              do_page;
                        end;  
      skp    : begin
                  break;
                  putline(n * sysvars[new].spacing);
               end;
      norm   : begin
                  v := sysvars[new].version;
 
                  if sysvars[v].fill_mode <> nofilling then
                     begin
                        if lead_blank and sysvars[new].ap_mode then
                           begin
                              auto_indent;
                              v := new;
                           end
                        else
                           if output_buf.en = 0 then
                              put_left_margin;
                        eo_input := false;
                        eo_output := false;
                        while not(eo_input) and not(eo_output) do
                           move_word(eo_input, eo_output);
                        more_input := not(eo_input);
                        if eo_output then
                           begin 
                              if sysvars[v].fill_mode = justification
                                 then justify;
                              shove_buffer;
                           end;
                     end
                  else  { nofilling mode }
                     begin
                        if not(blankline) then
                           begin
                              put_left_margin;
                              i := internal_buf.st;
                              j := output_buf.en + 1;
                              while (i <= internal_buf.en) and
                                 (j <= maxlinewidth) do
                                 begin
                                    output_buf.str[j] := internal_buf.str[i];
                                    i := i + 1;
                                    j := j + 1;
                                 end; { while }
                              output_buf.en := j - 1;
                           end;
                        shove_buffer; 
                     end
               end;  { norm }
   end;  { case }
end;  { out_proc }
 
 
 

========================================================================================
DOCUMENT :usus Folder:VOL13:dot_doc.text
========================================================================================


         
.comment        !----------------------------------!
.comment        !                                  !
.comment        !       RUNON documentation        !
.comment        !          Dot Commands            !
.comment        !                                  !
.comment        !         August 9, 1980           !
.comment        !                                  !
.comment        !----------------------------------!


.page .center " ^&DOT COMMANDS\& " .justify

  The dot commands are divided into four types as shown in the table
below.   They differ in the number and type of their parameters.
The parameter, or parameters, if any, must follow the command on the
same line.

.nofill

^&Example   command            Parameters\&

  1.       .BREAK              None

  2.       .INDENT n           One numeric parameter required

  3.       .PAPERSIZE m n      Two numeric parameters required

  4.       .TITLE /text/       Text required

.justify

  All dot commands begin with a period. They may be in   
upper, lower or mixed case.
Commands can be abbreviated indefinitely so long as they are distinct.
For example, ^^.includ, .inclu, .incl,\^ and <^.inc are all acceptable
abbreviations for <^.include.  Notice that <^.in is ^&not\&, because there is a
conflict with the <^.indent command.

   
  The three case commands (.SAMECASE, .LOWERCASE, .UPPERCASE) affect all 
text in the source file, including the .CENTER and .TITLE commands.
  Any command errors will cause an error message to be sent to the terminal, and
execution will cease. The following is a list of all current <^runon dot 
commands. 

.skip 2 .fill .center " ^&Dot commands\& " .skip 1

.comment     !------------------------------------------------------!
.comment     !                                                      !
.comment     !  Below we make extensive use of a little trick       !
.comment     !  that enables us to format boxes with labels.        !
.comment     !  Once Runon starts forming a new output line,        !   
.comment     !  any commands that might change the width of the     !
.comment     !  output line do not take effect until the line is    !
.comment     !  output. With the left margin set normally, the      !
.comment     !  label is placed into the output line. Enough        !
.comment     !  hard spaces are placed on the end of the label      !
.comment     !  to the desired left margin of the box, minus one.   !
.comment     !  The left margin is then changed to the desired      !      
.comment     !  setting. Filling proceeds normally from there.      !        
.comment     !  At the end of each box, the margin is reset.        !
.comment     !  Needless to say, this trick works only in filling   !
.comment     !  or justification mode.                              !
.comment     !                                                      !
.comment     !------------------------------------------------------!
 
<^.autopara######## 
 
.leftmargin 28 
 
enables <^autoparagraph mode, in which all source file lines that 
begin with a space character cause a combination of a <^.skip and
an <^.indent to occur. This feature is disabled in <^nofill mode. The
distances to skip and indent may be respecified by using the <^.autoset
command, described below.
 
.skip 1 .test 7 .leftmargin 10 
 
<^.autoset m n##### 
 
.leftmargin 28 
 
sets new skip (m) and indent (n) values for use in autoparagraphing. The 
skip that is performed is in terms of ^&single lines\& rather than in terms of
the spacing factor. The m parameter may range from 0 to 5, and n may range
from 1 to the right margin setting.
 
.skip 1 .test 5 .leftmargin 10 
 
<^.break########### 
 
.leftmargin 28 
 
causes the current line to be output with no justification, and places the 
next word of the source text at the beginning of the next line. If the current
line is empty, no break is performed.
 
.skip 1 .test 6 .leftmargin 10 
 
<^.center /text/### 
 
.leftmargin 28    
 
causes a <^.break, and centers the text on the line following the command in 
the middle of the output page as determined by the current settings of the
left and right margins. If there is nothing, or only spaces, between the text
delimiters, an error occurs.
 
.skip 1 .leftmargin 10 
 
<^.comment ...##### 
 
.leftmargin 28 
 
the remainder of the line following this command will be ignored. 
 
.skip 1 .leftmargin 10 
 
<^.figure n######## 
 
.leftmargin 28 
 
leaves n blank lines free to make room for a figure or a diagram. If there are     
less than n lines left on the page, text continues to fill this page and the
diagram is placed at the top of the next page. n can range from 2 to the
number of printable lines on a page (defined as page length (usually 66
lines) minus 14 (length of top and bottom borders)). Thus, on a standard
size page, the figure parameter may range from 2 to 52.
 
 
.skip 1 .leftmargin 10
 
<^.fill############ 
 
.leftmargin 28 
  
places as much text on the current line as can fit. This allows the use   
of a 'ragged-right' margin. All blank lines are discarded, as are 'redundant'
spaces, i.e. more than one non-HARD SPACE in a row.
 
.skip 1 .leftmargin 10 
 
<^.justify######### 
 
.leftmargin 28 
 
places as much text on the current line as can fit, like <^.fill, 
and then redistributes the text on the line to create a smooth right
margin. As with <^.fill, blank lines and extraneous spaces are discarded.      
 
.skip 1 .leftmargin 10 
 
<^.nofill########## 
 
.leftmargin 28 
 
causes all text to be output 'as is,' with no filling or justification.
Blank lines and spaces are output 'as is'. If a line 
is longer than the maximum line length minus the current left margin, it
is truncated on the right end, without warning.
 
.skip 1 .leftmargin 10 
 
<^.samecase######## 
 
.leftmargin 28 
 
causes all text in the source file to be taken as being in the same 
case as the one in which it appears. This is the default case setting.   
 
.skip 1 .testpage 4 .leftmargin 10 
 
<^.lowercase####### 
 
.leftmargin 28 
 
causes all text in the source file to be taken as being in lower 
case. This mode is useful for displays lacking lower case capability
(e.g. the Apple II). To output upper case text in lower case mode,
use the special characters for capitalization. To have a single upper
case character (as the first letter of a sentence, for example), prefix
the character with the 'quote' special character ('__').    
 
.skip 1 .leftmargin 10 
 
<^.uppercase#######   
 
.leftmargin 28 
 
causes all text in the source file to be taken as being in upper   
case. This mode is the inverse of <^.lowercase.
 
.skip 1 .leftmargin 10 
 
<^.include /text/## 
 
.leftmargin 28 
 
text is taken to be a filename. The file is opened and <^runon proceeds to 
process the text in the named file.  When <^runon finishes that file,
processing reverts to the 'interrupted' file. Any and all changes effected by
included files will remain in effect. An included file may itself include
another file, to a depth of five files.
 
.skip 1 .leftmargin 10 
 
<^.indent n######## 
 
.leftmargin 28 
 
causes a <^.break and sets the next line to begin n spaces from the left 
margin.  n can range from 1 to the line width (left margin minus
right margin).
 
.skip 1 .leftmargin 10               
 
<^.leftmargin n#### 
 
.leftmargin 28 
 
sets the left margin to be the nth column. n must be greater than zero and     
less than the right margin setting.
 
.skip 1 .leftmargin 10   
 
<^.noautopara######       
 
.leftmargin 28 
 
disables autoparagraph mode. Any leading spaces in the source file have   
no effect.
 
.skip 1 .leftmargin 10 
 
<^.onnumber######## 
 
.leftmargin 28 
 
turns on page numbering. 
 
.skip 1 .leftmargin 10 
 
<^.offnumber####### 
 
.leftmargin 28 
 
turns off page numbering; continues to keep track of page number.    
 
.skip 1 .leftmargin 10 
 
<^.number n######## 
 
.leftmargin 28 
 
sets the next page number to n. 
 
.skip 1 .leftmargin 10 
 
<^.onpage########## 
 
.leftmargin 28 
 
enables paging of output. 
 
.skip 1 .leftmargin 10 
 
<^.offpage######### 
 
.leftmargin 28 
 
disables paging, titling of output. 
 
.skip 1 .testpage 5 .leftmargin 10 
 
<^.page############ 
     
.leftmargin 28       
 
causes a page break to occur. Ignored in non-paging mode. If this command 
appears twice in succession, with no intervening text or skips, the second
invocation is ignored.
 
.skip 1 .leftmargin 10 
 
<^.papersize m n### 
 
.leftmargin 28 
 
sets the length of the page to m lines, and sets the width to n characters. 
The left margin is reset to 10, and the right margin is set to the new  
page width minus 10.
m may be no less than 20, and n is resticted to the range 30 to 132.
 
.skip 1 .leftmargin 10 
   
<^.rightmargin n###  
 
.leftmargin 28 
 
sets the right margin to the nth column, with a lower limit of the left margin 
and an upper limit of 132.
 
.skip 1 .leftmargin 10 
 
<^.skip n########## 
 
.leftmargin 28 
 
causes a <^.break and skips (n times the spacing factor) lines. 
If there are fewer than n lines left on
the current page, output begins at the top of the next page. n may not be
greater than the number of lines on the page; see <^.figure.              
 
.skip 1 .leftmargin 10 
 
<^.spacing n####### 
 
.leftmargin 28 
 
sets the inter-line spacing. When n is equal to 1, there are no blank 
lines inserted; when it equals 2 the file is output double-spaced.
n may range from 1 to 5.
 
.skip 1 .leftmargin 10 
 
<^.standard########   
 
.leftmargin 28 
 
resets all settings to their default values. The values used are those 
listed in the Defaults section, with the exception of the case, which
must be changed explicitly.
 
.skip 1 .testpage 6 .leftmargin 10  

<^.testpage n######    

.leftmargin 28 

used to preserve pieces of text, to insure they are not broken across page 
boundaries. If less than (n times spacing factor) lines remain on the 
current page, a page break occurs. This command is ignored in 
non-paging mode. 
 
.skip 1 .leftmargin 10 
 
<^.title /text/#### 
 
.leftmargin 28 
 
takes text to be new title of the document. This title is output at the top of 
each subsequent page.  If there is no text, the title is set to null.      
 
.skip 3 .leftmargin 10 .justify
  
  When using a command that takes a text parameter, the text must 
be delimited, shown above using the "/" symbol.  
The delimiter is taken to be the first non-blank character
following the command.  If no matching right delimiter is found,
an error condition results.

.nofill .test 10

The following symbols may be used to delimit text:  

   ! " _# $ % & ' ( ) * + , - . / : ; _< = > ? @ [ _\ ] _^ __ 

(in short, all the 'graphic' characters save the curly
brackets, accent, and vertical bar). 
.justify

  The text may contain embedded special characters. See the
section entitled <&Special <&Characters for more details.

.skip 1


========================================================================================
DOCUMENT :usus Folder:VOL13:errordata
========================================================================================

 bad block or CRC error illegal device #       illegal i/o request    data-com timeout       volume went off-line   file lost in directory bad file name          no room on volume     	 volume not found      
 file not found         dup directory entry    file already open     
 file not open          bad input information  ring buffer overflow   vol write protected    illegal block          illegal buffer         = or ? not allowed     no multiple files               
 GEORGER         A       SETUP   OUTPUT  INPUT                                                             
                  N  ^ V                                                                                                                                                                                                                                                                                                                                                                                            
========================================================================================
DOCUMENT :usus Folder:VOL13:err_doc.text
========================================================================================


 
.comment            !---------------------------------!
.comment            !                                 !
.comment            !      RUNON documentation        !
.comment            !        Error messages           !
.comment            !                                 !
.comment            !        August 3, 1980           !
.comment            !                                 !
.comment            !---------------------------------!


.page .center " ^&Errors and Error Messages\& "

  When an error occurs, the output file is locked, preserving all text
processed so far. The offending line of the input file is output to the
console, with a pointer to whatever was incorrect.  Some messages do
not point at anything.

  Note that errors that point to the title will have incorrect line
numbers, because the title is not checked until it is time to print
it out.

  The following is a list of the messages RUNON uses to inform the user of
errors and warnings:

.noautopara .skip 2 .center " <^unknown <^command "

<^runon saw a period ('.') on the current command line, and could not
recognize the command following it.

.skip 2 .center " <^missing <^parameter "

A parameter was expected after the command, but none was found.

.skip 2 .center " ^^parameter out of range - too high/low\^ "

The numeric parameter is incorrect. See the description
of the dot-command for an explanation of the allowable range
of the number.
 
.skip 2 .center " ^^numeric parameter required\^ "
 
Text was found where <^runon expected to find a number.
 
.skip 2 .center " ^^bad character following lead-in\^ "
 
<^runon could not recognize the symbol following the
'_\', '_^', or '_<' as a valid command.
 
.skip 2 .center " ^^lead-in character illegal at end of text\^ "
 
Using a lead-in character across line boundaries is not allowed.
 
.skip 2 .testpage 3 .center " ^^text wider than margins allow\^ "
 
The piece of text that you are trying to center is too long.
 
.skip 2 .testpage 4 .center " ^^title wider than paper width\^ "  
 
The program could not fit the title onto the page, because it
was too long for the current paper width.
 
.skip 2 .testpage 3 .center " ^^paper length too short\^ "
 
Paper can be a minimum of 20 lines long.
 
.skip 2 .center " ^^paper too wide\^ "
 
Paper can be a maximum of 132 columns wide.
 
.skip 2 .center " ^^paper width less than right margin\^ "
 
This is a no-no.
 
.skip 2 .center " ^^word too long for present line\^ "
 
The word is too long to fit on one line.  You can either
change the margins or use a smaller word.
 
.skip 2 .center " ^^figure already set or pending\^ "
 
While RUNON was waiting for a new page so that it could
output a pending figure, a request for a new figure came up.
Move the FIGURE command down in the file.
 
.skip 2 .center " ^^non-unique abbreviation\^ "
 
The command was too short for <^runon to discern it from other commands.
Try a longer abbreviation.
 
.skip 2 .center " ^^file already included\^ "
 
You attempted to include a file that was still in use.  This is not allowed 
because it would lead to an infinite recursion.
 
.skip 2 .center " ^^include file i/o error\^ "
 
Something is not right with the file you tried to include. Either it does not
exist or the volume name is incorrect.
 
.skip 2 .center " ^^too many include files\^ "
 
Too many files were active at one time. There is a maximum of five nested
levels of include files simultaneously.
 
.skip 2 .center " ^^auto-indent out of range - too low\^ "
 
The minimum setting of the indent parameter is 1.
 
.skip 2 .testpage 3 .center " ^^auto-indent out of range - too high\^ "
 
The auto-indent parameter exceeded the right margin. Note that the line and line
number that get printed out are essentially meaningless, in that they
indicate the line that <&triggered the auto-paragraph, and <&not the
one that originally set the incorrect parameter.
 
.skip 2 .testpage 3 .center " ^^command error\^ "
 
The command parser found unrecognizable junk on the line. 
 
.skip 2 .testpage 3 .center " ^^illegal delimiter for text parameter\^ "
 
The delimiter is not a member of the set of legal text delimiters. Refer to
the section on dot commands for more information.
 
.skip 2 .center " ^^missing delimiter for text parameter\^ "
 
<^runon could not find a matching right delimiter for the indicated one.
 
.skip 2 .center " ^^attempt to center non-existent text\^ "
 
The text you centered contained nothing. Don't do that.
.standard

========================================================================================
DOCUMENT :usus Folder:VOL13:fit.text
========================================================================================

(*$L-printer:*)
program fit;    {federal income tax program}
                { by edward heyman         }
                {    300 center hill rd
                     centerville de 19807  }
                     
                {keyed in from Feb 1982 Byte by
                 George Schreyer }
                
{From "FIT - A Federal Income Tax Program in UCSD Pascal" by Edward Heyman
 appearing in the Feburary 1982 issue of Byte magazine.  Copyright 1982
 Byte Publications, Inc.  Used with permission of Byte Publications, Inc.}
 
{This program is not EXACTLY the original, it has been patched is several
 places.  Specifically, some of the data in TAXTABLE.TEXT has been changed}
 
const  maxline          = 115;
       maxtline         = 66;
       minaline         = 67;
       maxaline         = 107;
       minbline         = 108;
       maxbline         = 115;
       esc              = 27;

type longint            = integer [ 9 ];
     filename           = string [ 15 ];
     intstr             = string [ 12 ];
     namestr            = string [ 26 ];
     filing_status      = 0..5;
     tline_num          = 1..maxline;
     tlineset           = set of tline_num;
     owner              = (h_own, w_own, t_own );
     pointer            = ^item;
     item               = packed record
                                nptr    : pointer;
                                name    : string[ 10 ];
                                amt     : integer [ 9 ];
                                whose   : owner;
                                tlnum   : tline_num;
                          end;
     tline              = packed record
                             case tag : integer of
                               1        : (iptr : pointer;
                                           hus  : integer [ 9 ];
                                           wif  : integer [ 9 ];
                                           tot  : integer [ 9 ]);
                               2        : (d1, d2, d3 : integer;
                                           taxyear    : string [ 4 ];
                                           fs         : filing_status;
                                           exem       : integer );
                               3        : (name : namestr );
                             end;
     tls                = packed array [ 1..maxline ] of tline;
     taxtable           = ( x, y, ys, z );
     taxfactors         = ( lower, upper, base, percent );
     factorarray        = array [ 1..16, taxfactors ] of longint;
     
var  ch         : char;
     ttable     : taxtable;
     fstat      : filing_status;
     screen,
     single,
     same,
     quit       : boolean;
     day,
     month,
     year       : integer;
     specset,
     dlineset,
     slineset,
     spageset,
     calcset    : tlineset;
     taxray     : array [ taxtable ] of factorarray;
     titles     : array [ 1..maxline ] of string [ 30 ];
     tlines     : tls;
     max_tax    : array [ owner ] of longint;
     p          : file of char;

procedure mem; forward;
function  readint ( len : integer ) : integer; forward;
procedure clear; forward;
procedure eline; forward;
procedure eeol; forward;
procedure eeos; forward;
procedure wait; forward;
procedure pdol ( dol : longint;
                 var stdol : intstr ); forward;
procedure center ( st : string;
                   screen : boolean ); forward;
procedure readdol ( len : integer;
                    var dolread : longint ); forward;
procedure namer ( title : namestr;
                  var st : string;
                  l : integer ); forward;
procedure line ( ch : char;
                 long : integer ); forward;

(*$I taxstart.text*)
(*$I taxrw.text*)
(*$I taxprint.text*)
(*$I taxcalc.text*)
(*$I taxedit.text*)

procedure mem;
begin
   writeln ( 'memory available ',memavail );
end;

procedure line (* ch : char;
                  long : integer *);
var j : integer;
begin
   for j := 1 to long do write ( p, ch );
end;

procedure namer (* title : namestr;
                   var st : string;
                   l : integer *);
{used to permit string data input TITLE is a prompt, L is the max length
 of the returned string}
begin
   repeat
      gotoxy ( 0, 6 );
      write ( 'enter ',title,' -->  ' );
      eeol;
      readln ( st );
      if ( length ( st ) ) > l then
         begin
            write ( 'name cannot exceed ', l, ' characters' );
            wait;
            gotoxy ( 0, 7 );
            eeol;
         end;
   until length ( st ) <= l;
   writeln;
end;

function readint (* len : integer ) : integer *);
{a long winded routine to allow input of an inter of len digits }
const   period =  '.';
        plus    = '+';
        minus   = '-';
        dol     = '$';
        bs      = 8;
        lf      = 10;
        ff      = 12;
        cr      = 13;
        del     = 127;
        space   = 32;

var     charray : array [ 1..10 ] of char;
        readinteger : integer;
        position : 1..9;
        neg : boolean;
        digits : set of char;

begin {readint}
   digits := [ '0'..'9' ];
   for position := 1 to len do write ( '_' );
   for position := 1 to len do write ( chr ( bs ) );
   position := 1;
   while position = 1 do
      begin
         read ( keyboard, charray [ position ] );
         if charray [ position ] in ( digits + [ plus, minus ] ) then
            begin
               write ( charray [ position ] );
               position := succ ( position );
            end;
      end;
   while position <= len do
      begin
         read ( keyboard, charray [ position ] );
         if charray [ position ] in digits then
            begin
               write ( charray [ position ] );
               position := succ ( position );
            end
         else
            begin
               if charray [ position ] = chr ( bs ) then
                  begin
                     write ( chr ( bs ) );
                     position := pred ( position );
                  end;
               if ( charray [ position ] in [ chr ( space ), chr ( cr ) ] ) then
                  len := pred ( position );
            end;
      end;
   readinteger := 0;
   if charray [ 1 ] = minus then neg := true else neg := false;
   for position := 1 to len do
      begin
         if charray [ position ] in digits then
            readinteger := 10 * readinteger + ord ( charray [ position ] ) -
               ord ( '0' );
      end;
   if neg then readint := -readinteger else readint := readinteger;
end; {readint}

procedure eeos;  {erase to end of screen}
begin
   write ( chr ( 27 ), 'J' );  {for H-19}
end;

procedure clear;  {clear to end of screen}
begin
   gotoxy ( 0, 0 );
   eeos;
end;

procedure eline;  {erase entire line}
begin
   write ( chr ( 27 ) , 'l' );  {for H-19}
end;

procedure eeol;  {erase to end of line}
begin
  write ( chr ( 27 ), 'K' );  {for H-19}
end;

procedure wait;
{routine used to halt program while user examines output}
var ch : char;
begin
   gotoxy ( 10, 23 );
   write ( 'enter <space> to continue' );
   repeat
      read ( keyboard, ch );
   until ( ch = chr ( 32 ) ) and ( not eoln ( keyboard ) );
end;

procedure center;
{routine to print a string in the center of the line}
var x, y : 0..132;
    ch : char;
begin
   ch := ' ';
   if screen then y := 40 else y := 66;
   x := y - ( length ( st ) div 2 );
   writeln ( ch:x, st );
end;

procedure pdol (*dol : longint;
                 var stdol : intstr *);
begin
   str ( dol, stdol );
   insert ( '.', stdol, pred ( length ( stdol ) ) );
end;

procedure readdol (* len integer;
                     var dolread : longint *);
{routine to permit entry of long integer of len digits}
const bs        = 8;
      plus      = '+';
      minus     = '-';
var   position  : 1..10;
      neg       : boolean;
      esc       : char;
      charray   : array [ 1..10 ] of char;
      digits    : set of char;
begin {readdol}
   same := false;
   quit := false;
   digits := [ '0'..'9' ];
   esc := chr ( 27 );
   for position := 1 to len do write ( '_' );
   for position := 1 to len do write ( chr ( bs ) );
   position := 1;
   repeat
      read ( keyboard, charray [ position ] );
   until ( charray [ position ] in digits + [ plus, minus, esc, 'Q', 'q' ] );
   if ( charray [ position ] = esc ) or ( charray [ position ] in [ 'q','Q' ] )
     then if ( charray [ position ] ) in [ 'q', 'Q' ] then
        begin
           quit := true;
           exit ( readdol );
        end
     else
        begin
           same := true;
           exit ( readdol );
        end
  else 
     begin
        write ( charray [ position ] );
        position := succ ( position );
     end;
  while position <= len do
     begin
        repeat
           read ( keyboard, charray [ position ] );
        until ( charray [ position ] in ( digits + [ '.', chr ( bs ) ] ) );
        if ( charray [ position ] in digits ) then
           begin
              write ( charray [ position ] );
              position := succ ( position );
           end
        else
           begin
              if charray [ position ] = chr ( bs ) then
                 begin
                    write ( chr ( bs ) );
                    position := pred ( position );
                 end;
              if ( charray [ position ] = '.' ) then
                 begin
                    write ( '.' );
                    len := succ ( position );
                 end;
           end;
     end;
  dolread := 0;
  if charray [ 1 ] = minus then neg := true else neg := false;
  for position := 1 to len do
     if ( charray [ position ] in digits ) then
       dolread := 10 * dolread + ord ( charray [ position ] ) - ord ( '0' );
  if neg then dolread := -dolread;
end; {readdol}

begin  {fit main}
   start;
   writeln;
   mem;
   wait;
   repeat;
      clear;
      write ( 'fit command --> P)rint E(dit C(alculate R(read W(rite Q(uit ');
      repeat
         read ( keyboard, ch );
      until ( ch in [ 'p','P','e','E','c','C','r','R','w','W','q','Q' ] );
      case ch of
        'E','e' : edit;
        'R','r' : begin
                     rw ( 'R' );
                     fstat := tlines [ 7 ].fs;
                     if fstat in [ 2, 3 ] then single := false;
                  end;
        'W','w' : rw ( 'W' );
        'P','p' : printer;
        'C','c' : calculate;
      end;
   until ch in [ 'Q', 'q' ];
end.  {fit main }


========================================================================================
DOCUMENT :usus Folder:VOL13:howto_doc.text
========================================================================================


 
.comment            !---------------------------------!
.comment            !                                 !
.comment            !      RUNON documentation        !
.comment            !           Front end             !
.comment            !                                 !
.comment            !         August 3, 1980          !
.comment            !   (Revised February 6, 1981)    !
.comment            !                                 !
.comment            !---------------------------------!


.skip 2 .center " ^^^&running the program\^\& "

  At the system monitor level, type X (execute), followed by the
volume name (if needed) and <^runon. <^runon replies:
.nofill

<^runon Text Processor [V2]

Input file:

.justify
  Let's assume that we have a file named <^foo.text that we want to format.
If we type
.skip 1

Input file: <&FOO####

.leftmargin 30

will cause <^runon to append <^.text to the name FOO and open the file
with that name. If the file is not found, an error message results. Do 
<&not supply the <^.text yourself!

.leftmargin 10 .nofill

If RUNON accepts your file, it replies:

.justify

Output file:#######

.leftmargin 30

if you enter a carriage return at this point, the program appends
'/' to the beginning of the input file name, <^.text to the end,
and uses the resulting name for the output file. Typing another name
at this point, <^fred for example, causes <^runon to use that name
for the output file, with a <^.text appended, of course.

.leftmargin 10

  <^runon will also allow the use of non-.TEXT files for input and output.
This feature allows you to completely specify the exact file name(s),
overriding any characters that might be appended to it. We may do this
by placing a period ('.') at the end of the file name. For example,
.nofill

Input file: <&<^foo.baz.
Output file: <&<^fred.

.justify
opens <^foo.baz for input and <^fred for output. The period option may be
used on the input file name, output file name, or both.

.testpage 6

  <^runon also allows you to enter both names on a single line. When the
program prompts you for an input file, you can enter two file names,
seperated by a comma. This suppresses the output file prompt. Typing one
filename, followed by a comma and nothing else is the same as typing a
carriage return to the output file prompt, as in the first example.

.skip 1 .center " <&Examples " .nofill

Input file: <&HARRY
Output file: _<cr>

opens HARRY.TEXT for input, and /HARRY.TEXT for output.

Input file: <&HARRY,

same effect as above.

Input file: <&SAM
Output file: <&MARY

opens SAM.TEXT for input, MARY.TEXT for output.

Input file: <&<^alfred.
Output file: _<cr>

opens <^alfred for input, <^/alfred for output.

Input file: <&<^alfred.,

same as above

Input file: <&<^donna
Output file: <^<&alfonzo.memo.

opens <^donna.text for input and <^alfonzo.memo for output.
.justify
  And finally, what happens if the file name is too long to add a '/' to
it? The answer is
that <^runon will add the '/' and then truncate the name to the proper
length. For example,
.nofill

Input file: <&<^toolongname,

opens <^toolongnam.text for input and <^/toolongna.text for output.

.justify
  Under no circumstances will <^runon create a filename with more than
15 characters, excluding the volume name, which may be a maximum of
seven characters long. If we type
.nofill

Input file: <^<&toolongname.,anothername.

.justify
RUNON opens <^toolongname and <^anothername as input and output
files, respectively.

  Note that an entire file name must be specified for input, but
only a volume name need be specified on output if the output file
is not a block-structured device (e.g. PRINTER:, REMOUT:, etc.). There is
no need to suffix it with a period to inhibit the <^.text. For example:

.nofill

Input file: <&<^zap
Output file: <&<^printer:

opens ZAP.TEXT for input and PRINTER: (system printer) for output.

.justify

  After <^runon has accepted the files for processing, it will
print the names of the input and output files, i.e.

.nofill

mydisk:letter.text  -->  mydisk:/letter.text

.justify
  <^runon will also output the names of any .^^include\^d files to
the <^console: as it encounters them.


========================================================================================
DOCUMENT :usus Folder:VOL13:initc.text
========================================================================================

 
{**********************************************************************
 
  INIT_CONST initializes all variables that remain constant throughout
  program execution. These variables are true system constants.
 
**********************************************************************}
 
 
 
Procedure init_const;
 
var
   i : posint;
 
 
      Procedure init_cmd_strings;
 
      begin
         cmd_strings[ autop  ] := 'AUTOPARA    ';
         cmd_strings[ autset ] := 'AUTOSET     ';
         cmd_strings[ brk    ] := 'BREAK       ';
         cmd_strings[ cntr   ] := 'CENTER      ';
         cmd_strings[ cmnt   ] := 'COMMENT     ';
         cmd_strings[ fig    ] := 'FIGURE      ';
         cmd_strings[ fil    ] := 'FILL        ';
         cmd_strings[ indt   ] := 'INDENT      ';
         cmd_strings[ inclu  ] := 'INCLUDE     ';
         cmd_strings[ justfy ] := 'JUSTIFY     ';
         cmd_strings[ lmar   ] := 'LEFTMARGIN  ';
         cmd_strings[ lower  ] := 'LOWERCASE   ';
         cmd_strings[ noauto ] := 'NOAUTOPARA  ';   
         cmd_strings[ nofil  ] := 'NOFILL      ';
         cmd_strings[ num    ] := 'NUMBER      ';
         cmd_strings[ offnum ] := 'OFFNUMBER   ';
         cmd_strings[ offpag ] := 'OFFPAGE     ';
         cmd_strings[ onnum  ] := 'ONNUMBER    ';
         cmd_strings[ onpag  ] := 'ONPAGE      ';
         cmd_strings[ pag    ] := 'PAGE        ';
         cmd_strings[ papsiz ] := 'PAPERSIZE   ';
         cmd_strings[ rmar   ] := 'RIGHTMARGIN ';
         cmd_strings[ same   ] := 'SAMECASE    ';
         cmd_strings[ skp    ] := 'SKIP        ';
         cmd_strings[ spc    ] := 'SPACING     ';
         cmd_strings[ std    ] := 'STANDARD    ';
         cmd_strings[ tstpag ] := 'TESTPAGE    ';
         cmd_strings[ til    ] := 'TITLE       ';
         cmd_strings[ upper  ] := 'UPPERCASE   ';
      end; { init_cmd_strings }
 
 
begin  { init_const }
 
   init_cmd_strings;
 
   with std_vals do
      begin
         version := new;
         fill_mode := justification; 
         paging := true;
         numbering := true;
         ap_mode := true;
         lm := 10;
         rm := 70;
         ap_indent := 5;
         ap_skip := 1;
         paper_width := 80;
         paper_length := 66;
         chars_in_line := rm - lm + 1;
         printable_lines := paper_length - bordersize;
         spacing := 1;
      end; { with }
 
   with blank_string do
      begin
         st := 1;
         en := 0;
         for i := 1 to maxlinewidth do
            str[i] := blank_char;
      end;
 
   with soft_space do
      begin
         ch := blank_char;
         malleability := soft;
         length := 1;
         atts := [];
      end; { with }
 
   with blank_buf do
      begin
         st := 1;
         en := 0;
         for i := 1 to maxlinewidth do
            str[i] := soft_space;
      end; { with }
 
   hard_space := soft_space;
   hard_space.malleability := hard;
 
   numbers := [zero..nine];
   act_cmds := [brk..nofil];
   text_cmds := [cntr..inclu];
 
   text_delims := ['!'..'/'] + [':'..'@'] + ['['..'_'];
   leadin_chars := ['^', '\', '<', '_'];
   lock_ops := ['&', '^'];
   word_ops := ['&', '^'];
 
   space_chars := [blank_char, pound];
   delim_chars := [chr(1)..chr(32)] + [pound];
   uc_letters := [uca..ucz];
   lc_letters := [lca..lcz];
 
   bs := chr(8);
 
end; { init_const }

{**********************************************************************
 
  INIT_VARS initializes all system variables that can change during
  program execution.
 
**********************************************************************}
 
 
 
Procedure init_vars;
 
var
   i : posint;
 
begin
 
   sysvars[new] := std_vals;
   sysvars[old] := std_vals;
 
   with pageinfo do
      begin
         currline := 0;
         currpage := 2;
         figure_set := false;
         figure_pending := false;
         figure_size := 0;
         title := blank_string;
      end;
 
   internal_buf := blank_buf;
   output_buf := blank_buf;
 
   n := 0;
   m := 0;
 
   global_case := [];
   lock_status := [];
 
   lead_blank := false;
   blankline := false;
   dot_command := false;
   more_input := false;
 
   vc_in_line := 0;
   ic_in_line := 0;
   ln_number := 0;
 
   with file_stack do
      begin
         ptr := 0;
         for i := 1 to max_files do
            with stack[i] do
               begin
                  name := nul;
                  line := 0;
                  in_buf := blank_string;
               end;
      end; { with }
 
end; { init_vars }

{**********************************************************************

  Error procedure.  This routine accepts a parameter of type ERRORTYPE,
  and prints the corresponding error message on the user's terminal,
  preceded by the line number of the source line in which the error
  occurred, and followed by the offending line itself. It is assumed
  that ERR_POS has been set to the position of the offending item.
  The routine then closes all open files, and executes an EXIT(RUNON),
  which ends RUNON execution.

***********************************************************************} 


Procedure error(err_msg : errortype;
                err_ptr : posint;
                err_buf : line_of_chars);

var
   i : posint;
   
   
   Procedure print1;
   
   begin
      case err_msg of
         badcmd  : writeln('Unknown command');
         tooshrt : writeln('Paper length too short');
         toowide : writeln('Paper width too wide');
         toonrrw : writeln('Paper width less than right margin');
         badsym  : writeln('Bad character following lead-in');
         argmsng : writeln('Missing parameter');
         nonnum  : writeln('Numeric parameter required');
         toolow  : writeln('Parameter out of range - too low');
         toohgh  : writeln('Parameter out of range - too high');
         tilwide : writeln('Title wider than paper width');
         cntwide : writeln('Text wider than margins allow');
         figbad  : writeln('Figure already set or pending');
      end { case }
   end; { print1 }
   
   
   
   Procedure print2; 
   
   begin
      case err_msg of
         wdlen   : writeln('Word too long for present line'); 
         dblnam  : writeln('Non unique abbreviation'); 
         incerr  : writeln('File already included'); 
         filerr  : writeln('Include file I/O error'); 
         nesdep  : writeln('Too many include files'); 
         aplow   : writeln('Auto-indent out of range - too low'); 
         aphgh   : writeln('Auto-indent out of range - too high'); 
         cmderr  : writeln('Command error'); 
         baddelm : writeln('Illegal delimiter for text parameter'); 
         dlmmsng : writeln('Missing delimiter for text parameter'); 
         endlead : writeln('Lead-in character illegal at end of line'); 
         badcnt  : writeln('Attemp to center non-existent text');
      end; { case }
   end; { print2 }



begin  { error }

   writeln;
   writeln('ERROR IN LINE ', ln_number:5, ' : ');
   
   if err_msg in [badcmd..figbad]
      then print1
      else print2;
   
   writeln(err_buf);
   
   if err_ptr > 0 then
      begin
         for i := 1 to (err_ptr - 1) do write(blank_char);
         writeln('^');
      end;
   
   writeln;
   
   close(s0);
   
   for i := 1 to file_stack.ptr do
      case i of
         1 : close(s1);
         2 : close(s2);
         3 : close(s3);
         4 : close(s4);
         5 : close(s5);
      end; { case }
   
   close(dest, lock);
   
   exit(RUNON);      { so, it's ugly... }
   
end; { error }
 
{**********************************************************************
 
  CENTER_BUFFER centers the text found in the ALINE buffer between
  the parameters LMARG and RMARG. The text is presumed to be left
  justified in ALINE upon entry to this procedure. The .ST and .EN
  pointers are changed to point to the centered text.
 
  CENTER_BUFFER is called on by PUT_TITLE and TEXT_CMNDS to center
  the title, and for the .CENTER command.
 
**********************************************************************}
 
 
Procedure center_buffer(var aline    : buffer;
                            lmarg,
                            rmarg    : posint;
                            err_pos  : posint;
                            err_code : errortype);
 
var
   textlen,
   width,
   offset, i : posint;
 
begin
   width := rmarg - lmarg + 1;
   textlen := aline.en;
 
   if textlen > width then
      begin
         if err_code = tilwide
            then error(err_code, err_pos, pageinfo.title.str)
            else error(err_code, err_pos, input_buf.str);
         end;
 
   offset := ((width - textlen) div 2) - 1;
 
   for i := textlen downto 1 do
      aline.str[i + offset + lmarg] := aline.str[i];
 
   aline.st := offset + lmarg + 1;
   aline.en := offset + lmarg + textlen;
 
   for i := (offset + lmarg) downto 1 do
      aline.str[i] := soft_space;
 
end; { center_buffer }
     
{**********************************************************************
 
  SCANNER parses the IN_BUF, placing the 'image' of the line into
  the OUT_BUF.  It processes the special symbols ( ^&, etc.),
  removes them from the text, and gives each character 'attributes'
  based on previous occurrences of the special symbols. Note that
  only quoted characters, and normal (i.e. non-delimiter, non-
  control) characters have attributes. Further, note that quoted
  characters may only have U_LINE as an attribute, and that if
  normal characters do not have case attributes, they assume what-
  ever global case attribute is in effect as set by the case dot
  commands, or the default setting.
 
  A subprocedure, INTERN, is used to put each character into the
  internal buffer, setting the print-out length of the character,
  'malleability' (both used in the justification process), and
  the attributes.
 
  Note that ASCII control characters are INTERNed with zero
  length, in order to allow them to be justified 'unnoticed'.  
 
**********************************************************************}
 
 
Procedure scanner(    st_pos,
                      en_pos  : posint;
                      in_buf  : line_of_chars;
                  var out_buf : buffer       );
 
var
   current_char : char;
   current_atts : attrib_set;
   char_num     : posint;
   quote,
   word_on,
   lock_on,
   lock_off     : boolean;
   word_status  : attrib_set;
   
   
 
      Procedure intern(curr_ch : char;
                       density : hard_soft;
                       len     : posint;
                       ats     : attrib_set );
 
      begin
         out_buf.en := out_buf.en + 1;
 
         with out_buf.str[out_buf.en] do
            begin
               ch := curr_ch;
               malleability := density;
               length := len;
               atts := ats
            end  { with }
 
      end; { intern }
 
 
 
begin  { scanner }
 
   quote := false;
   word_on := false;
   lock_on := false; 
   lock_off := false;
   word_status := [];
   
   For char_num := st_pos to en_pos do
      begin
         current_char := in_buf[char_num];
         current_atts := word_status + lock_status;
 
         if quote then
            begin
               intern(current_char, hard, 1, current_atts - [u_case, l_case]);
               quote := false;
            end
         else
            If word_on then
               begin
                  if current_char in word_ops then
                     case current_char of
                        '&'    : word_status := word_status + [u_line];
                        '^'    : word_status := word_status + [u_case];
                     end
                  else
                     error(badsym, char_num, in_buf);
                  word_on := false;
               end
            else
               If lock_on then
                  begin
                     if current_char in lock_ops then
                        case current_char of
                           '&'    : lock_status := lock_status + [u_line]; 
                           '^'    : lock_status := lock_status + [u_case];
                        end
                     else
                        error(badsym, char_num, in_buf);
                     lock_on := false;
                  end
               else
                  If lock_off then
                     begin
                        if current_char in lock_ops then
                           case current_char of
                              '&'    : lock_status := lock_status - [u_line];
                              '^'    : lock_status := lock_status - [u_case];
                           end
                        else
                           error(badsym, char_num, in_buf);
                        lock_off := false;
                     end
                  else
                     If current_char in leadin_chars then
                        case current_char of  
                           '^'    : lock_on := true;
                           '\'    : lock_off := true;
                           '<'    : word_on := true;
                           '_'    : quote := true
                        end
                     else
                        If current_char in delim_chars then
                           begin
                              word_status := [];
                              If current_char in space_chars then
                                 begin
                                    if current_char = pound
                                       then intern(blank_char, hard, 1, [])
                                       else intern(blank_char, soft, 1, []);
                                 end
                              else   { ctrl chars }
                                 intern(current_char, hard, 0, []);
                           end
                        else
                           begin
                              if (current_atts - [u_case, l_case]) =
                                 current_atts then
                                    current_atts :=
                                       current_atts + global_case;
                              intern(current_char, hard, 1, current_atts);
                           end;
      end;  { for }
 
   if quote or word_on or lock_on or lock_off then
      error(endlead, en_pos, in_buf);
 
end;  { scanner }
 
 
 


========================================================================================
DOCUMENT :usus Folder:VOL13:intro_doc.text
========================================================================================


   
.COMMENT            !---------------------------------!
.COMMENT            !                                 !
.COMMENT            !     RUNON DOCUMENTATION         !
.COMMENT            !         INTRODUCTION            !
.COMMENT            !                                 !
.COMMENT            !        AUGUST 3, 1980           !
.COMMENT            !                                 !
.COMMENT            !---------------------------------!


.LOWERCASE .NUMBER 1 .PAGE .CENTER "<&<^INTRODUCTION"

  <^RUNON IS A "DOCUMENT PROCESSOR" - THAT IS, A PROGRAM THAT ALLOWS
EASY FORMATTING OF TEXT, I.E. TERM PAPERS, LETTERS, ETC.
  _THE TEXT MAY BE FORMATTED TO YOUR SPECIFICATION BY SIMPLY INSERTING
<^RUNON COMMANDS AND A FEW SPECIAL CHARACTERS INTO THE TEXT WHEN IT
IS ENTERED INTO THE COMPUTER.
_THE TEXT IS TYPICALLY PLACED IN A FILE USING A TEXT EDITOR. _WHEN <^RUNON
HAS PROCESSED THE TEXT, THE RESULTING DOCUMENT CAN BE STORED IN ANOTHER
FILE, OR SENT TO THE PRINTER OR SIMILAR DEVICE.

.SKIP 2 .CENTER " ^^^&SOURCE FILE\^\& "   

  _THE SOURCE FILE CONSISTS OF THE RAW TEXT THAT IS TO BE FORMATTED
PLUS THE <^RUNON COMMANDS INSERTED IN THE TEXT. _THE <^RUNON COMMANDS IN
THE SOURCE FILE DO NOT APPEAR IN THE FINAL DOCUMENT. _THERE ARE TWO
GENERAL TYPES OF <^RUNON COMMANDS. _THESE ARE KNOWN AS  "DOT
COMMANDS" AND "SPECIAL CHARACTERS."
  _THE DOT COMMANDS ARE PREFIXED WITH A PERIOD, AND MUST START IN
THE FIRST COLUMN OF A LINE. _MULTIPLE DOT COMMANDS MAY APPEAR ON A LINE.
_THERE ARE CURRENTLY EIGHT SPECIAL CHARACTER SEQUENCES THAT HAVE MEANING TO
<^RUNON. _THESE CHARACTERS CONTROL SPACING, CASE AND UNDERLINING. _THEY MAY
APPEAR ANYWHERE IN THE TEXT, AND IN PARTICULAR, PREFIXED TO A WORD.
  _OTHER THAN CERTAIN RESTRICTIONS PLACED ON DOT COMMANDS, THE TEXT MAY BE
ENTERED FREELY WITHOUT WORRYING ABOUT SPACING OR LINE WIDTHS. _THE MAIN
RESTRICTION IS THAT A PERIOD MAY NOT OCCUR IN THE FIRST COLUMN OF A LINE
UNLESS IT IS PREFIXED TO A
VALID DOT COMMAND.  _UNLESS OTHERWISE SPECIFIED, THE TEXT WILL APPEAR
IN THE OUTPUT FILE IN THE SAME CASE IN
WHICH IT WAS ENTERED, E.G. LOWER CASE WILL APPEAR AS LOWER CASE.
      _CONTROL
CHARACTERS WILL BE OUTPUT AS NON-PRINTING CHARACTERS IN THE FORMATTED FILE,
AND WILL HAVE NO EFFECT ON THE JUSTIFICATION.
  _N._B. <^RUNON IS A SOPHISTICATED TEXT PROCESSOR WRITTEN IN A HIGH-LEVEL
LANGUAGE, AND AS SUCH IS MUCH SLOWER THAN MACHINE-LANGUAGE TEXT PROCESSORS.
_HOWEVER, IT IS FAR MORE POWERFUL, MORE MODULAR, AND MORE EXTENSIBLE THAN
ANY SUCH LOW-LEVEL PROCESSOR.
  _WHEN DOING DISK-TO-DISK PROCESSING ON AN
<^APPLE <^II, THE PROGRAM RUNS AT A RATE OF ABOUT 1-1/2 MINUTES PER PAGE IN
JUSTIFICATION MODE.  _ON A _WESTERN _DIGITAL _MICROENGINE (TM), THE 
PROCESSING RATE IS APPROXIMATELY 20 SECONDS PER PAGE.
  _ONE WAY TO INCREASE THE PROGRAM'S 'BANDWIDTH,' AS IT WERE, IS TO OUTPUT
DIRECTLY TO <^PRINTER: OR <^REMOUT: OR WHATEVER YOU USE FOR HARDCOPY;
<^RUNON IS QUITE CAPABLE OF DRIVING MOST PRINTERS AS FAST AS THEY
WILL GO.
.SAMECASE 


========================================================================================
DOCUMENT :usus Folder:VOL13:main.text
========================================================================================

 
{**********************************************************************
 
  READ_FIL_NAMES as it's name implies, reads an input and output file
  name from the user's terminal. The two names can be seperated by a
  comma, or a carriage return. If the comma is not followed by a name,
  or the output file name prompt is given a carriage return, the output
  name defaults to the input name, and a slash is prefixed to the front.
 
  If either or both names are followed by a period, no extensions are
  added to the end of that name. Otherwise, the extension .TEXT is
  added to the name. In the case of the default output name, the exten-
  sion depends upon whether the input name has been followed by a period.
  If only a volume name is provided for the output name, it need not
  be followed by a period to inhibit the extension, as this is checked for.
 
  If either the file name, or a volume name prefix are too long, (see
  UCSD Pascal manual) they are truncated without warning. The same is
  true when adding the .TEXT extension, or the default prefix.  
 
  When the file names have been formed, they are checked for bad char-
  acters, and the existance of the appropiate disk files and volume
  names. An input name must contain a file name, and certain volume
  names are illegal. The output name need not contain a file name,
  that is to say, it need only contain a volume name such as PRINTER:.
  Any output volume name is acceptable so long as it is on line.
 
  Any errors resulting from the above operations cause an error message
  to be sent to the terminal, and the input sequence is started again.
  READ_FIL_NAMES is exited when the file names are succesfully read, or
  a blank input name is entered, or the EOF character (ctrl-C) is
  entered any time during the the input sequence.
 
 
  TEST_FILE tests for the existance of the file name and/or volume name
  provided.
 
  STRIP_SPACES strips any and all spaces out of the file name provided.
 
  BAD_CHARS_IN tests if any characters occur in the file name that are  
  not in the set of characters provided. If there are any, they are
  bad characters.
 
  TEST_NAME tests and truncates the length of the volume name, and the
  file name. To the length of the file name are added the lengths of the
  default prefix, and the extension, if any. Bad characters are tested
  for, and on the input name, the volume name if any is compared to the
  list of illegal volume names. The volume name, file name, and prefix,
  and extension are then concatenated toegether.
 
  MAKE_NAME calls TEST_NAME with the appropiate parameters after deciding
  if the name passed it is suffixed with a period.
 
***********************************************************************}
 
 
 
Procedure read_fil_names(var in_name,
                             out_name : string;
                         var empty    : boolean);
 
const
   filenamelen = 15;
   volnamelen  = 7;
   suffix      = '.text';
   prefix      = '/';
   inp_delim   = ',';
   vol_delim   = ':';
   nul         = '';
   star        = '*';
 
type
   warningtype = (clear,  badinp, badvol, badfil,
                  volerr, filerr, illopp);
   file_type   = (inp, out);
   char_set    = set of char;
   err_set     = set of 1..10;
 
var
   inp_string : string;
   delim_pos  : posint;
   fil_chars,
   vol_chars  : char_set;
   inp_errs,
   out_errs   : err_set;
   warning    : warningtype;
   err_name   : string;
   default    : boolean;
 
 
 
 
      Procedure test_file(f_name    : string;
                          err_codes : err_set);
 
      var
         error : posint;
 
 
            Function file_status(f_name : string) : posint;
 
            begin
               {$I-} 
                  reset(f, f_name);
                  file_status := ioresult;
                  close(f);
               {$I+} 
            end; { file_status }
 
 
      begin  { test_file }
 
         error := file_status(f_name);
 
         if error in err_codes then
            case error of
               3  : warning := illopp;
               9  : warning := volerr;
               10 : warning := filerr;
            end;
 
      end; { test_file }
 
 
 
 
      Procedure strip_spaces(var astring : string);
 
      var
         blank_pos : posint;
 
      begin
         blank_pos := pos(blank_char, astring);
 
         while blank_pos > 0 do
            begin
               delete(astring, blank_pos, 1);
               blank_pos := pos(blank_char, astring);
            end;
      end; { strip_spaces }
 
 
 
 
      Function bad_chars_in(astring    : string;
                            good_chars : char_set) : boolean;
 
      var
         char_pos     : posint;
         illegal_char : boolean;
 
      begin
         char_pos := 1;
         illegal_char := false;
 
         while (char_pos <= length(astring)) and (not illegal_char) do
            begin
               if not(astring[char_pos] in good_chars)
                  then illegal_char := true
                  else char_pos := char_pos + 1;   
            end;
 
         bad_chars_in := illegal_char;
      end; { bad_chars_in }
 
 
 
 
      Procedure test_name(var f_name   : string;
                              prefix,
                              suffix   : string;
                              fil_type : file_type);
 
      var
         vol_id,
         fil_id  : string;
         add_len,
         vol_pos : integer;
 
      begin
         add_len := length(suffix) + length(prefix);
 
         vol_pos := pos(vol_delim, f_name);
 
         vol_id := copy(f_name, 1, vol_pos - 1);
         fil_id := copy(f_name, vol_pos + 1, length(f_name) - vol_pos);
 
         if length(vol_id) > volnamelen then
            vol_id := copy(vol_id, 1, volnamelen);
 
         if length(fil_id) > (filenamelen - add_len) then
            fil_id := copy(fil_id, 1, filenamelen - add_len);
 
         if bad_chars_in(vol_id, vol_chars) then
            warning := badvol
         else
            if bad_chars_in(fil_id, fil_chars) then
               warning := badfil
            else
               if (length(fil_id) = 0) and (fil_type = inp) then
                  warning := badinp
               else
                  if (fil_type = inp) and
                       ((vol_id = '#1') or
                        (vol_id = '#2') or
                        (vol_id = 'remin') or
                        (vol_id = 'remout') or
                        (vol_id = 'console') or
                        (vol_id = 'printer') or
                        (vol_id = 'keyboard')) then
                      warning := illopp
                  else
                     if vol_id <> nul then
                        begin
                           if (vol_pos = length(f_name)) and
                              (fil_type = out) then
                                 f_name := concat(vol_id,
                                                  vol_delim)
                           else
                              f_name := concat(vol_id,
                                               vol_delim,
                                               prefix,
                                               fil_id,
                                               suffix);
                        end
                     else
                        f_name := concat(prefix,
                                         fil_id,
                                         suffix);
 
      end; { test_name }
 
 
 
 
      Procedure make_name(var fil_name : string;
                              prefix,
                              suffix   : string;
                              fil_type : file_type;
                              dsk_errs : err_set);
 
      var
         nam_len : posint;
 
      begin
         nam_len := length(fil_name);
 
         if fil_name = dot then
            warning := badinp
         else
            if fil_name[nam_len] = dot then
               begin
                  delete(fil_name, nam_len, 1);   
                  test_name(fil_name, prefix, nul, fil_type)
               end
            else
               test_name(fil_name, prefix, suffix, fil_type);
 
         if warning = clear then
            test_file(fil_name, dsk_errs);
      end; { make_name }
 
 
 
 
begin  { read_fil_names }
 
   empty := false;
   inp_errs := [3, 9, 10];
   out_errs := [3, 9];
   fil_chars := ['a'..'z'] + ['A'..'Z'] + ['0'..'9'] +
                   ['-', '/', '\', '_', '.'];
   vol_chars := fil_chars + [pound] + [star];
 
   repeat
      in_name := nul;
      out_name := nul;
      err_name := 'INPUT';
      warning := clear;
      default := false;
 
      write('Input file: ');
 
      readln(inp_string);
      strip_spaces(inp_string);
 
      if (inp_string = nul) or eof(input) then
         empty := true
      else
         begin
            delim_pos := pos(inp_delim, inp_string);
 
            if delim_pos = 0 then
               begin
                  in_name := inp_string;
                  write('Output file: ');
 
                  readln(inp_string);
                  strip_spaces(inp_string);
 
                  if eof(input) then
                     empty := true
                  else
                     if inp_string = nul then
                        begin
                           default := true;
                           out_name := in_name;
                        end
                     else
                        out_name := inp_string;
               end
            else
               if delim_pos = 1 then
                  warning := badinp
               else
                  begin
                     in_name := copy(inp_string,
                                     1,
                                     delim_pos - 1);
                     out_name := copy(inp_string,
                                      delim_pos + 1,
                                      length(inp_string) - delim_pos);
                     if out_name = nul then   
                        begin
                           default := true;
                           out_name := in_name;
                        end;
                  end;
 
            if (warning = clear) and (not empty) then
               begin
                  make_name(in_name,
                            nul,
                            suffix,
                            inp,
                            inp_errs);
 
                  if warning = clear then
                     begin
                       err_name := 'OUTPUT';
 
                       if default then
                          make_name(out_name,
                                    prefix,
                                    suffix,
                                    out,
                                    out_errs)
                       else
                          make_name(out_name,
                                    nul,
                                    suffix,
                                    out, 
                                    out_errs);
                     end;
               end;
 
            if warning <> clear then
               begin
                  writeln;
                  write('ERROR IN ', err_name, ' FILE SPECIFICATION : ');
                  case warning of
                     badinp : writeln('No file name supplied');
                     badvol : writeln('Illegal character in volume name');
                     badfil : writeln('Illegal character in file name');
                     volerr : writeln('No such volume on line');
                     filerr : writeln('No such file on disk');
                     illopp : writeln('Illegal volume name');
                  end; { case }
                  writeln;
               end;
 
         end; { if }
 
   until (empty or (warning = clear));
 
end; { read_fil_names }

{**********************************************************************
 
  FRONT_END is RUNON's driver.  It consists of a single loop that
  repeats until the user types EOF (^C) at the terminal. The file
  names are read, the system global variables are then initialized,
  and the input file is processed.
 
**********************************************************************}
 
 
Procedure front_end;
 
var
   empty_name : boolean;
 
 
begin   { front end ( user interface and main loop )  }
 
   init_const;
 
   repeat
      writeln;
      read_fil_names(file_in, file_out, empty_name);
      writeln;
 
      if not empty_name then
         begin
            init_vars;
 
            reset(s0, file_in);
            rewrite(dest, file_out);
 
            writeln(file_in, ' --> ', file_out);
            writeln;
 
            process_file(s0, false);
 
            close(s0);
            close(dest, lock);
         end;
   until eof(input);
 
end;  { front end }
 
{**********************************************************************
 
  Main program.  Prints a greeting at the user's terminal, and
  calls FRONT_END.
 
**********************************************************************}
 
begin   {* main program *}
 
   writeln;
   writeln('RUNON Text Formatter [', version_number, ']');
 
   front_end;
 
end   { program }.
 
 
 


========================================================================================
DOCUMENT :usus Folder:VOL13:pdate.text
========================================================================================

(*$S+*)
(*$I globals*)
(* You will need the globals from volume 8 to compile this unit. *)
(* If you have a small interpreter, you may need it also as the globals
   eat the symbol table alive. *)
(* George Schreyer *)
(*$L+*)
(*$D+*)
separate unit puts_date ;
interface

procedure set_prefix ( prefix_volume : vid );
procedure eeos;
procedure eeol;
procedure p_date ( date : daterec ) ;
procedure get_date ( var date : daterec );

implementation

procedure set_prefix (*prefix_volume : vid*);
begin
  dkvid := prefix_volume;
end;

procedure eeos;
begin
   clearscreen;
end;

procedure eeol;
begin
   clearline;
end;

procedure get_date (*var date : daterec *);
begin
   date := thedate;
end;

procedure p_date (*date : daterec *);
begin
 thedate := date;
end;

end;
begin
end.


========================================================================================
DOCUMENT :usus Folder:VOL13:readln.text
========================================================================================


     
 
{**********************************************************************
 
  READLINE clears the input and internal buffers, and then reads a line
  of up to  MAXLINEWIDTH characters from the input file.  If the line
  is too long,  it is truncated. . ST and .EN are set to the beginning
  and end of text,  respectively.  If the line is empty, or begins
  with a dot (period) or a space,  an appropriate Boolean flag is set.
 
**********************************************************************}
 
 
Procedure readline;
 
var
   all_blanks : boolean;
   pos        : integer; 
 
begin
   input_buf := blank_string;
   internal_buf := blank_buf;
   all_blanks := true;
 
   blankline := false;
   dot_command := false;
   lead_blank := false;
   pos := 0;
 
   while not(eoln(source)) and (pos < maxlinewidth) do
      begin
         pos := pos + 1;
         input_buf.str[pos] := source^;
         if source^ <> blank_char then
            all_blanks := false;
         get(source); 
      end;
 
   ln_number := ln_number + 1;
 
   if pos = maxlinewidth then
      while not(eoln(source)) do
         get(source);
 
   if eoln(source) then
      get(source);
      
   input_buf.en := pos;   
 
   if (pos = 0) or all_blanks then  
      blankline := true
   else
      if input_buf.str[1] = dot then
         dot_command := true
      else
         if input_buf.str[1] = blank_char then
            lead_blank := true;
 
end; { readline }
 
{**********************************************************************
 
   PROCESS_FILE is the true top level for RUNON. It begins by outputting
   a blank page heading of BLANK_HEADING lines.  While the file is not
   empty or the internal buffer contains unprocessed text, the
   following sequence is repeated:
 
   a) If the internal buffer is empty, then read a line from
        the source file.
      If the line is empty, and we are in filling mode, ignore it,
        get a new line.
      If the line read in was a dot command, then call the dot-
        command processor.
      Otherwise, line is normal so scan and process it.
 
   b) If the internal buffer is not empty, then process it.
 
   Once the file and input buffer are both empty, force the output
   buffer  and close the output file.
 
   The variable INC_FIL indicates if the file being processed is an
   INCLUDE file. It it is, the blank heading is not put out, and
   the output buffer is not forced out after the file has been
   processed.
 
**********************************************************************}
 
 
 
 
{****************************************************}
{                                                    }
{   Procedure declaration in SYSGEN file.            }
{----------------------------------------------------}
{                                                    }
{   Procedure process_file(var source  : text;       }
{                              inc_fil : boolean);   }
{                                                    }
{****************************************************}
 
 
begin  { process file }
 
   if not(inc_fil) then
      begin
         n := blank_heading;
         out_proc(skp);
         pageinfo.currline := 0;
      end;
 
   While not(eof(source)) or more_input do
      begin
 
         If not(more_input) then
            begin
               Readline;
               If not(blankline and
                  (sysvars[new].fill_mode <> nofilling)) then
                  begin
                     if dot_command then
                        d_c_p 
                     else
                        begin
                           scanner(input_buf.st,
                                   input_buf.en,
                                   input_buf.str,
                                   internal_buf);
                           out_proc(norm);
                        end;
                  end;
            end
         else    { more_input }
            out_proc(norm);
 
      end;  { while }
 
   if not(inc_fil) then
      if sysvars[new].fill_mode <> nofilling then
         out_proc(brk);
 
end;  { process_file }
 
{*********************************************************************
 
  INCLUDE_FILE opens a new source file and then passes it recursively
  to the procedure PROCESS_FILE. Up to MAX_FILES nested levels of
  include files may be opened simultaneously. The procedure heading
  is declared FORWARD before OUT_PROC, and the actual code occurs
  after PROCESS_FILE. If an error occurs, all open files are closed
  by ERROR.
 
  Three different error conditions are tested for.
 
    1. Too many include files have been opened. Stack overflow.
    2. General file I/O error. Possibly specific at a future date.
    3. Include file already included. This is done to prevent
       infinite recursion. Possibly unnecessary.
 
**********************************************************************}
 
 
 
 
{*******************************************************}
{                                                       }
{   Forward declaration in SYSGEN file.                 }
{-------------------------------------------------------}   
{                                                       }
{   Procedure include_file(f_name : string);  Forward   }
{                                                       }
{*******************************************************}
 
 
Procedure include_file;
 
var
   i, err_pos : posint;
 
 
            Function file_status(f_name : string) : posint;
 
            begin
               {$I-} 
                  reset(f, f_name);
                  file_status := ioresult;
                  close(f);
               {$I+} 
            end; { file_status }
 
 
begin  { include_file }
 
   err_pos := input_buf.st - 2;
 
   if file_stack.ptr >= max_files then
      error(nesdep, err_pos, input_buf.str)
   else
      if file_status(f_name) <> 0 then
         error(filerr, err_pos, input_buf.str)
      else
         if f_name = file_in then
            error(incerr, err_pos, input_buf.str)
         else
            for i := 1 to file_stack.ptr do  
               if f_name = file_stack.stack[i].name then 
                  error(incerr, err_pos, input_buf.str);
 
   writeln('Including ', f_name);
 
   with file_stack do
      begin
         ptr := ptr + 1;
         stack[ptr].name := f_name;
         stack[ptr].line := ln_number;
         stack[ptr].in_buf := input_buf;
         ln_number := 0;
      end;
 
   case file_stack.ptr of
      1 : begin
             reset(s1, f_name);
             process_file(s1, true);
             close(s1);
          end;
      2 : begin
             reset(s2, f_name);
             process_file(s2, true);
             close(s2);
          end;
      3 : begin
             reset(s3, f_name);
             process_file(s3, true);
             close(s3);
          end;
      4 : begin
             reset(s4, f_name);
             process_file(s4, true);
             close(s4);
          end;
      5 : begin
             reset(s5, f_name);
             process_file(s5, true);
             close(s5); 
          end;
   end; { case }
 
   with file_stack do
      begin
         stack[ptr].name := nul;
         ln_number := stack[ptr].line;
         input_buf := stack[ptr].in_buf;
         ptr := ptr - 1;
      end;
 
end; { include_file }
 
 
 


========================================================================================
DOCUMENT :usus Folder:VOL13:readnu.text
========================================================================================

 
{**********************************************************************
 
  READNUM reads a number from the input buffer. If there isn't
  a valid number, or no number exists, the error routine is called.
  The number must be delimited by a space, a dot, or the end of line.
 
**********************************************************************}
 
 
Procedure readnum(var number : posint);
 
var
   firstchar,
   lastchar,
   pos, i    : posint;
   ablank,
   anumber   : boolean;
 
 
      Function power_of_ten(x : posint) : posint;
 
      var
         i, j : posint;
 
      begin
         j := 1;
         for i := 1 to x do
            j := j * 10;
         power_of_ten := j;
      end; { power_of_ten }
 
 
begin  { readnum }
 
   number := 0;
   ablank := true;
   anumber := true;
   pos := input_buf.st;
 
   while ablank and (pos <= input_buf.en) do
      if input_buf.str[pos] = blank_char
         then pos := pos + 1
         else ablank := false;
 
   if pos > input_buf.en then
      error(argmsng, input_buf.st, input_buf.str)
   else
      begin
         if not(input_buf.str[pos] in numbers) then
            error(nonnum, pos, input_buf.str);
 
         firstchar := pos;
 
         while anumber and (pos <= input_buf.en) do
            if input_buf.str[pos] in numbers
               then pos := pos + 1
               else anumber := false;
 
         lastchar := pos - 1;
      end;  { else }
 
   for i := 0 to (lastchar - firstchar) do
      number := number +
         (ord(input_buf.str[lastchar - i]) - ord(zero)) * power_of_ten(i);
 
   input_buf.st := pos;
 
end;  { readnum }

{**********************************************************************
 
  FIND_TEXT finds a string in the buffer TXT starting from the .STth
  position. The string is delimited by the first non-blank character
  found. The permissible delimiters are all printing, non-alphanumeric
  characters.
 
  The routine first searches for the two delimiters. The two pointers,
  ST_TXT and EN_TXT, are then set to the first and last non-blank
  characters within the delimiters. The .ST pointer of TXT is set
  to the second delimiter position plus one.
 
**********************************************************************}
 
 
Procedure find_text(var st_txt, en_txt : posint;
                    var txt            : strng);
 
var
   searching : boolean;
   txt_pos,
   err_pos   : posint;
   delim     : char;
 
begin
   txt_pos := txt.st;
   searching := true;
 
   while searching and (txt_pos <= txt.en) do
      if txt.str[txt_pos] = blank_char
         then txt_pos := txt_pos + 1
         else searching := false;
   
   if searching then error(argmsng, txt.st, txt.str); 
 
   delim := txt.str[txt_pos];
   err_pos := txt_pos;
 
   if not(delim in text_delims) then error(baddelm, txt_pos, txt.str);
 
   txt_pos := txt_pos + 1;
   st_txt := txt_pos;
   searching := true;
 
   while searching and (txt_pos <= txt.en) do
      if txt.str[txt_pos] <> delim
         then txt_pos := txt_pos + 1
         else searching := false;
 
   if searching then error(dlmmsng, err_pos, txt.str);
 
   en_txt := txt_pos - 1;
   txt.st := txt_pos + 1;
   searching := true;
 
   while searching and (st_txt <= en_txt) do
      if txt.str[st_txt] = blank_char
         then st_txt := st_txt + 1
         else searching := false;
 
   searching := true;
 
   while searching and (en_txt > st_txt) do
      if txt.str[en_txt] = blank_char
         then en_txt := en_txt - 1
         else searching := false;
 
  end;  { find_text }

{**********************************************************************
 
  GET_COMMAND reads a command from INPUT_BUF, beginning with the
  .ST pointer. The command must be delimited by a space, a dot, or
  the end of line.
 
  If the command is not identifiable, or it matches more than one
  command string, the error routine is called. Otherwise, CMD is set
  to an enumerated type corresponding to the command, and
  INPUT_BUF.ST is set to point at the delimiter.
 
**********************************************************************}
 
 
 Function get_command : commandtype;
 
var
   command      : cmd_name;
   cmd          : commandtype;
   match_count,
   cmd_length,
   buf_pos,
   fill         : posint;
   done,
   searching    : boolean;
 
 
      Function sub_string(part, whole : cmd_name;
                          cmd_len     : posint  ) : boolean;
 
      var
         same_char : boolean;
         i         : posint;
 
      begin
         same_char := true;
         i := 1;
 
         while (i <= cmd_len) and same_char do
            if part[i] = whole[i]
               then i := i + 1
               else same_char := false;
 
         sub_string := same_char;
      end; { sub_string }
 
 
begin  { get_command }
 
   buf_pos := input_buf.st;
   cmd_length := 1;
   searching := true;
 
   cmd := brk;
   done := false;
   match_count := 0;
 
 
   { read string from input buffer }
 
 
   while (buf_pos <= input_buf.en) and
      (cmd_length <= maxcmdlength) and
         searching do
 
      if input_buf.str[buf_pos] in [blank_char, dot] then
         searching := false
      else
         begin
            if input_buf.str[buf_pos] in lc_letters then
               command[cmd_length] :=
                  chr(ord(input_buf.str[buf_pos]) - lcoffset)
            else
               command[cmd_length] := input_buf.str[buf_pos];
 
            buf_pos := buf_pos + 1;
            cmd_length := cmd_length + 1;
         end;
 
   if input_buf.st = buf_pos
      then error(cmderr, input_buf.st, input_buf.str)
      else input_buf.st := buf_pos;
 
 
   { match string to command }
 
 
   while not done do
      begin
         if sub_string(command, cmd_strings[cmd], cmd_length - 1) then
            begin
               match_count := match_count + 1;
               get_command := cmd;
            end;
 
         if (match_count > 1) or (cmd = cmnt)
            then done := true
            else cmd := succ(cmd);
      end; { while }
 
      if match_count = 0 then
         error(badcmd, buf_pos - 1, input_buf.str)
      else
         if match_count > 1 then
            error(dblnam, buf_pos - 1, input_buf.str);
 
end; { get_command }
 
{**********************************************************************
 
  ACTION_CMNDS reads and checks parameters for action commands
  that require them.  It then calls the output processor.
 
**********************************************************************}
 
 
Procedure action_cmnds(cmd : commandtype);
 
begin
 
   case cmd of
      fig    : begin
                  if pageinfo.figure_set or pageinfo.figure_pending then
                     error(figbad, input_buf.st - 1, input_buf.str);
                  readnum(n);
                  if n < 2 then
                     error(toolow, input_buf.st - 1, input_buf.str)
                  else
                     if n > sysvars[new].printable_lines then
                        error(toohgh, input_buf.st - 1, input_buf.str);
               end;
      indt   : begin
                  readnum(n);
                  if n < 1 then
                     error(toolow, input_buf.st - 1, input_buf.str)
                  else
                     if (sysvars[sysvars[new].version].lm + n) >
                         sysvars[sysvars[new].version].rm then
                           error(toohgh, input_buf.st - 1, input_buf.str);
               end;
      skp    : begin
                  readnum(n);
                  if n < 1 then
                     error(toolow, input_buf.st - 1, input_buf.str)
                  else
                     if n > sysvars[new].printable_lines then
                        error(toohgh, input_buf.st - 1, input_buf.str);
               end;
      nofil  : begin
                  sysvars[new].fill_mode := nofilling;
                  cmd := brk;
               end;
      tstpag : begin
                  readnum(n);
                  if n > sysvars[new].printable_lines then
                     error(toohgh, input_buf.st - 1, input_buf.str)
                  else
                     if n < 1 then
                        error(toolow, input_buf.st - 1, input_buf.str);
               end;
      pag, brk : { do nothing } 
 
   end; { case }
 
   out_proc(cmd);
 
end;  { action_commands }
 
{*********************************************************************
 
  TEXT_CMNDS reads text parameters from the INPUT_BUF for those
  commands that require them. The two pointers START_POS and
  END_POS point to the text in the buffer.
 
  Please note that the .CENTER command resets the INTERNAL_BUF to
  empty so that multiple center commands will find it that way,
  and that the global variable LOCK_STATUS is suspended before
  the text is scanned so that the normal text attributes will
  not be used.
 
  READ_STRING reads a filename from INPUT_BUF for INCLUDE_FILE.
  Notice that this uses a UCSD Pascal string.
 
**********************************************************************}
 
 
Procedure text_cmnds(cmd : commandtype);
 
var
   start_pos,
   end_pos     : posint;
   f_name      : string;
   save_status : attrib_set;
 
 
 
      Procedure read_string(var str : string);
 
      var
         char_buf : string[1];
         char_pos : posint;
 
      begin
         str := nul;
         
         for char_pos := start_pos to end_pos do  
            begin
               char_buf := blank_char;
               char_buf[1] := input_buf.str[char_pos];
               str := concat(str, char_buf);
            end;
      end; { read_string }
 
 
 
begin  { text_cmnds }
 
   find_text(start_pos, end_pos, input_buf);
 
   case cmd of
      cntr  : begin
                 if end_pos < start_pos then
                    error(badcnt, start_pos, input_buf.str);
                 out_proc(brk);
                 internal_buf := blank_buf;
 
                 save_status := lock_status;
                 lock_status := [];
 
                 scanner(start_pos,
                         end_pos,
                         input_buf.str,
                         internal_buf);
 
                 lock_status := save_status;
 
                 center_buffer(internal_buf,
                               sysvars[new].lm,
                               sysvars[new].rm,
                               end_pos,
                               cntwide);
 
                 output_buf := internal_buf;
                 out_proc(brk);
              end;
      inclu : begin
                 read_string(f_name);
                 include_file(f_name);
              end;
      til   : begin
                 pageinfo.title.str := input_buf.str;
                 pageinfo.title.st := start_pos;
                 pageinfo.title.en := end_pos;
              end;
 
   end; { case }
 
end; { text_cmnds }
 
{**********************************************************************
 
  GLOBAL_CMNDS is the counterpart of ACTION_CMNDS for commands that
  do not require immediate output and effect system variables.
 
  N.B. For an explanation of FLIP_VERSION and why it is important,
  please see the documentation on the Time-warp effect.
 
**********************************************************************}
 
 
Procedure global_cmnds(cmd : commandtype);
 
var
   i : posint;
 
 
 
      procedure flip_version;
      begin
         if (output_buf.en <> 0) and (sysvars[new].version = new) then
            begin
               sysvars[old] := sysvars[new];
               sysvars[new].version := old;
            end;
      end;  { flip_version }
 
 
 
begin  { global_cmnds }
 
   case cmd of
      fil    : sysvars[new].fill_mode := filling;
      justfy : sysvars[new].fill_mode := justification;
      lmar   : begin
                  readnum(n);
                  if n > sysvars[new].rm then
                     error(toohgh, input_buf.st - 1, input_buf.str)  
                  else
                     if n < 1 then
                        error(toolow, input_buf.st - 1, input_buf.str);
                  flip_version;
                  sysvars[new].lm := n;
                  sysvars[new].chars_in_line :=
                     sysvars[new].rm - sysvars[new].lm + 1;
               end;
      rmar   : begin
                  readnum(n);
                  if n > sysvars[new].paper_width then
                     error(toohgh, input_buf.st - 1, input_buf.str)
                  else
                     if n < sysvars[new].lm then
                        error(toolow, input_buf.st - 1, input_buf.str);
                  flip_version;
                  sysvars[new].rm := n;
                  sysvars[new].chars_in_line :=
                     sysvars[new].rm - sysvars[new].lm + 1;
               end;
      onnum  : sysvars[new].numbering := true;
      offnum : sysvars[new].numbering := false;
      num    : begin
                  readnum(n); 
                  if n < 1 then
                     error(toolow, input_buf.st - 1, input_buf.str);
                  pageinfo.currpage := n;
               end;
      onpag  : begin
                  sysvars[new].paging := true;
                  pageinfo.currline := 1
               end;
      offpag : sysvars[new].paging := false;
      papsiz : begin
                  readnum(m);
                  if m < minpaplen then
                     error(tooshrt, input_buf.st - 1, input_buf.str);
                  readnum(n);
                  if n > maxlinewidth then
                     error(toowide, input_buf.st - 1, input_buf.str)
                  else
                     if n < minlinewidth then
                        error(toonrrw, input_buf.st - 1, input_buf.str);
                  flip_version;
                  sysvars[new].printable_lines := m - bordersize;
                  sysvars[new].paper_length := m;
                  sysvars[new].paper_width := n;
                  sysvars[new].lm := 10;
                  sysvars[new].rm := n - 10;
               end;
      spc    : begin
                  readnum(n);
                  if n < minspacing then
                     error(toolow, input_buf.st - 1, input_buf.str)
                  else
                     if n > maxspacing then
                        error(toohgh, input_buf.st - 1, input_buf.str);
                  sysvars[new].spacing := n;
               end;
      std    : begin
                  flip_version;
                  sysvars[new] := std_vals;
               end;
      autop  : sysvars[new].ap_mode := true;
      noauto : sysvars[new].ap_mode := false;
      autset : begin
                  readnum(m);
                  if m > maxspacing then
                     error(toohgh, input_buf.st - 1, input_buf.str);
                  readnum(n);
                  if n < 1 then
                     error(aplow, input_buf.st - 1, input_buf.str);
                  sysvars[new].ap_skip := m;
                  sysvars[new].ap_indent := n;
               end;
      upper  : global_case := [u_case];
      lower  : global_case := [l_case];
      same   : global_case := [];
 
   end;  { case }
 
end; { global commands }
 
{**********************************************************************
 
  The dot command processor reads commands from the input buffer,
  until the line is empty or a .COMMENT command is encountered,
  and dispatches them to either the action-, text-, or global-command
  processor. The header is declared before READNUM.
 
**********************************************************************}
 
 
{**************************************}
{                                      }
{   header is located in SYSGEN file   }
{--------------------------------------}
{                                      }
{   Procedure d_c_p;                   }
{                                      }
{   var                                }
{     searching,                       }
{     eo_line   : boolean;             }
{     cmd       : commandtype;         }
{     pos       : posint;              }
{                                      }
{**************************************}
 
 
 

begin  { dot command processor } 
 
   eo_line := false;
 
   repeat
      searching := true;
      pos := input_buf.st;
 
      while searching and (pos <= input_buf.en) do
         if input_buf.str[pos] = blank_char
            then pos := pos + 1
            else searching := false;
 
      if searching then
         eo_line := true
      else
         begin
            if input_buf.str[pos] <> dot then
               error(cmderr, pos, input_buf.str);
 
            input_buf.st := pos + 1;
 
            cmd := get_command;
 
            if cmd = cmnt then
               eo_line := true
            else
               begin
                  if cmd in act_cmds then
                     action_cmnds(cmd)
                  else
                     if cmd in text_cmds then
                        text_cmnds(cmd)
                     else
                        global_cmnds(cmd);
               end;
         end;
   until eo_line;
 
end;  { dot command processor }
 
 
 


========================================================================================
DOCUMENT :usus Folder:VOL13:runon_doc.text
========================================================================================


  
.comment        !--------------------------------------!
.comment        !                                      !
.comment        !    RUNON V.2 program documentation   !
.comment        !  by Wynn Newhouse and Herb Jellinek  !
.comment        !                                      !
.comment        !          August 9, 1980              !
.comment        !                                      !
.comment        !--------------------------------------!

.title '_User _Manual' .skip 3 .indent 40

August 9, 1980

.skip 5 .center "<^<&runon" .skip 1 .center "A Text Formatting Program"
.skip 30

.center / Copyright (C) 1980  Herb Jellinek and Wynn Newhouse /
.center / All rights reserved. /

.comment     ***      end of cover page

.incl /intro_doc.text/
.incl /howto_doc.text/
.incl /dot_doc.text/
.incl /defalt_doc.text/
.incl /spec_doc.text/
.incl /err_doc.text/
.incl /tech_doc.text/


========================================================================================
DOCUMENT :usus Folder:VOL13:scredit.text
========================================================================================

(*   $LPrinter:*)

{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}
{                                      }
{ Pascal Screen Generator - Edit Screen}
{ by Lee Meador -- Copyright (c) 1981  }
{ World Bible Translation Center       }
{ 1401 Hillcrest Dr.                   }
{ Arlington, TX  76010  (817) 469-6019 }
{                                      }
{ This program will create or modify a }
{   data file that is used by SCRGEN   }
{   to write a Pascal Procedure in a   }
{   text file. This procedure will set }
{   up a form on the screen and allow  }
{   you to input and output information}
{   for the blanks in the form.        }
{                                      }
{ When creating a new screen use the   }
{   option available to clear (zero)   }
{   the screen. Then enter information }
{   for each field on the screen. You  }
{   have a label and a series of '_'s  }
{   for each field. You must specify   }
{   the maximum length allowed, the    }
{   type (integer, real, string, etc.  }
{   that is being entered along with   }
{   the name of the variable to put the}
{   data into once someone enters it.  }
{   Display type of Normal is the only }
{   one supported.                     }
{                                      }
{ Note: The new field entry code was   }
{   written using a version of these   }
{   programs.                          }
{                                      }
{ Good Luck...                         }
{   let me know about enhancements     }
{                                      }
{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}

PROGRAM PScrn_1;

CONST MaxNumOfItems = 60;

TYPE

        Actcode = (inscr,outscr,setscr);
        stat    = (good,backup,default);
        s       = String[80];

(*$I:TYPES.TEXT *)

VAR     Scrfile : FILE OF Scrn;
        Txt     : TEXT;
        ScreenName,
        ScreenRes: STRING;
        YesNo,Yes: SET OF CHAR;
        ThatsAll,
        SaveIt   : BOOLEAN;
        ItemNum  : INTEGER;
        Status   : Stat;

procedure clear_screen;
begin
   gotoxy ( 0, 0 );
   write ( chr ( 27 ) , 'J' );  {H-19 specific}
end;

{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}
{                                      }
{ Get Functions                        }
{ by Lee Meador - Copyright (c) 1981   }
{                                      }
{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}
{                                      }
{ The following TYPE must be defined   }
{                                      }
{ TYPE Stat = (Good,Backup,Default);   }
{                                      }
{ The functions here are:              }
{  VAL - returns a Real given a string }
{  GetBoolean - returns a Boolean from }
{    whatever is input in the field    }
{  GetInteger - returns an Integer     }
{    from what is input in the field   }
{  GetReal - returns a Real from what  }
{    is input in the field             }
{  GetString - returns a String as the }
{    third parameter from what is      }
{    input in the field.               }
{                                      }
{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}

FUNCTION VAL(STRNG:STRING):REAL;

   (* BY David Stringham    *)
   (* 2102 Overbrook        *)
   (* Arlington, Tex. 71014 *)
   (* 7-MAR-81              *)
   { Mods by Lee Meador      }
   {  1 Apr 81               }

VAR
   S:STRING;
   PTEN,ZERO,I:INTEGER;
   NUMBER:REAL;

BEGIN (* VAL *)
   
   ZERO:=ORD('0');
   
   (* BEGIN CULLING NON VALID CHRS *)
   (* INDIVIDUAL NUMBERS IN SAME   *)
   (* STRING MUST BE SEPARATED BY  *)
   (* A NON VALID CHARACTER; SUCH  *)
   (* AS A BLANK. THUS $100.00$15  *)
   (* WILL RETURN       100.0015   *)
   (* AND $100.00 $15 RETURNS 100.0*)
   
   
   IF LENGTH(STRNG)<1 THEN 
     BEGIN
       VAL:=0.0;
       EXIT(VAL)
     END;
     
   I:=0;
   REPEAT 
     I:=I+1
   UNTIL (NOT (STRNG[I] IN ['+', '$', ',', '.', '-', '0'..'9'])
         OR (I=LENGTH(STRNG)));
   
   S:=COPY(STRNG,1,I);
        
        (* GET THE REAL NUMBER *)
   NUMBER:=0.0;
   PTEN:=0;
   FOR I:=LENGTH(S) DOWNTO 1 DO
       CASE S[I] OF
       
       '0','1','2','3','4','5','6','7',
       '8','9' :BEGIN
                   NUMBER:=NUMBER+ (ORD(S[I])-ZERO)*PWROFTEN(PTEN);
                   PTEN:=PTEN+1;
                END;
       
       '.'     :BEGIN
                   NUMBER:=NUMBER/PWROFTEN(PTEN);
                   PTEN:=0
                END;
       
       '-'     :NUMBER:=-NUMBER
       END; (* CASE *)
       
       (* IF NON NUMBER THEN *)
       (* IGNORE IT          *)
              
     VAL:=NUMBER; (* ASSIGN VAL*)
                   (* ITS VALUE  *)
     
END; (* VAL *)
      
PROCEDURE GetString(Len:INTEGER;VAR Status:STAT;VAR RET:S);

VAR     CH: CHAR;
        C : STRING;
        Str : STRING;
        Chars : INTEGER;
        
BEGIN
   Chars := 0; { The length }
   Str   := '';{ The String }
   
   REPEAT
      READ(ch);
      IF (ch = ' ') and (EOLN) THEN ch := chr(13);
         { make cr back to cr }
      CASE ord(ch) OF
      
      13 : BEGIN {return}
              IF Chars = 0 THEN BEGIN
                 Ret := '';
                 Status    := Default;
                 EXIT(GetString);
                END;
              Ret := Str;
              Status := Good;
              EXIT(GetString);
             END;
             
      8  : BEGIN {backspace}
              IF Chars = 0 THEN BEGIN
                 Ret := '';
                 Status    := Backup;
                 EXIT(GetString);
                END;
              WRITE(chr(8),'_',chr(8));
              Chars := Chars-1;
              Str := COPY(Str,1,LENGTH(Str)-1);
             END
      END;
      
      IF ORD(ch) IN [0..7,9..31,127] THEN
         CH := ' ';
      IF ORD(ch) IN [32..126] THEN BEGIN
         Chars := Chars+1;
         (*$R-*)
         C[1] := CH; C[0]:=CHR(1);
         (*$R+*)
         Str := CONCAT(Str,C);
        END;
        
   UNTIL Chars >= Len;
   Ret := Str;
   Status := Good;
END; { Get String }

FUNCTION GetBoolean(Len:INTEGER;VAR Status:STAT):BOOLEAN;

VAR S: String;
    I: Integer;

BEGIN
   GetString(Len,Status,S);
   
   { change all to upper case }
   
   FOR I := 0 TO LENGTH(S) DO 
      IF I > 0 THEN
         IF S[I] IN ['a'..'z'] THEN
            S[I] := CHR(ORD(S[I])-32);
   
   IF   (S = 'TRUE') OR
        (S[1] = 'Y')
      THEN GetBoolean := TRUE
      ELSE GetBoolean := FALSE;

END; { Get Boolean }

FUNCTION GetReal(Len:INTEGER;VAR Status:STAT):REAL;

VAR S: String;

BEGIN
   GetString(Len,Status,S);
   GetReal := VAL(S);
END;

FUNCTION GetInteger(Len:INTEGER;VAR Status:STAT):INTEGER;

VAR S: String;

BEGIN
   GetString(Len,Status,S);
   GetInteger := ROUND(VAL(S));
END;

{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}
{                                      }
{ END OF Get Functions                 }
{ by Lee Meador - Copyright (c) 1981   }
{                                      }
{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}

PROCEDURE SCREENOUT(Action:ACTCODE);

{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}
{                                      }
{ SCREENOUT is the result of using this}
{   program to enhance itself. This    }
{   code was written by SCRGEN on info }
{   stored by an earlier version of    }
{   this program. Some changes were    }
{   made to that code to add some new  }
{   features and support my defined    }
{   data types. The calls to this will }
{   help you understand what is being  }
{   done.                              }
{                                      }
{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}

VAR TempBoolean: BOOLEAN;
    TempString : STRING;
    TempInteger: INTEGER;
    TempReal   : REAL;
    TempLongInteger: INTEGER[36];
    Return     : Stat;
    
PROCEDURE INPROC;

LABEL 1,
      2,
      3,
      4,
      5,
      6,
      7,
      8,
      9;

BEGIN

WITH Scrfile^[ItemNum] DO BEGIN { Lee's Line added }

(*$G+*)

      (* Input ItemLabel *)
      1: GOTOXY(8,8);
      GetSTRING(33,Return,TempSTRING);
      IF Return = Backup THEN GOTO 1;
      IF Return = Default THEN TempSTRING:=ItemLabel;
      GOTOXY(8,8);
      WRITE(TempSTRING);
      ItemLabel:=TempSTRING;

      (* Input ItemName *)
      2: GOTOXY(11,9);
      GetSTRING(30,Return,TempSTRING);
      IF Return = Backup THEN GOTO 1;
      IF Return = Default THEN TempSTRING:=ItemName;
      GOTOXY(11,9);
      WRITE(TempSTRING);
      ItemName:=TempSTRING;

      (* Input ItemType *)
      3: GOTOXY(11,10);
      GetSTRING(15,Return,TempSTRING);
      IF Return = Backup THEN GOTO 2;
      IF Return = Default THEN TempSTRING:='STRING';
      GOTOXY(11,10);
      WRITE(TempSTRING);
      ItemType:=TempSTRING;

      (* Input ItemLength *)
      4: GOTOXY(9,11);
      TempINTEGER:=GetINTEGER(3,Return);
      IF Return = Backup THEN GOTO 3;
      IF Return = Default THEN TempINTEGER:=0;
      GOTOXY(9,11);
      WRITE(TempINTEGER);
      ItemLength:=TempINTEGER;

      (* Input ItemY *)
      5: GOTOXY(21,11);
      TempINTEGER:=GetINTEGER(3,Return);
      IF Return = Backup THEN GOTO 4;
      IF Return = Default THEN TempINTEGER:=12;
      GOTOXY(21,11);
      WRITE(TempINTEGER);
      ItemY:=TempINTEGER;

      (* Input ItemX *)
      6: GOTOXY(34,11);
      TempINTEGER:=GetINTEGER(3,Return);
      IF Return = Backup THEN GOTO 5;
      IF Return = Default THEN TempINTEGER:=0;
      GOTOXY(34,11);
      WRITE(TempINTEGER);
      ItemX:=TempINTEGER;

      (* Input ItemDisplayType *)
      7: GOTOXY(16,13);
      GetSTRING(8,Return,TempSTRING);
      IF Return = Backup THEN GOTO 6;
      IF Return = Default THEN TempSTRING:='NORMAL';
      GOTOXY(16,13);
      WRITE(TempSTRING);
      CASE TempSTRING[1] OF
      'N','n':
          ItemDisplayType:=NORMAL;
      'I','i':
          ItemDisplayType:=INVERSE;
      'F' ,'f' :
          ItemDisplayType:=FLASH
      END; {Case}
      
      (* Input ItemEdit *)
      8: GOTOXY(7,15);
      TempBOOLEAN:=GetBOOLEAN(6,Return);
      IF Return = Backup THEN GOTO 7;
      IF Return = Default THEN TempBOOLEAN:=TRUE;
      GOTOXY(7,15);
      IF TempBOOLEAN THEN WRITE('Yes') ELSE WRITE('No');
      ItemEdit:=TempBOOLEAN;

      (* Input ItemDefault *)
      9: GOTOXY(10,16);
      GetSTRING(60,Return,TempSTRING);
      IF Return = Backup THEN GOTO 8;
      IF Return = Default THEN TempSTRING:=ItemDefault;
      GOTOXY(10,16);
      WRITE(TempSTRING);
      ItemDefault:=TempSTRING;
(*$G-*)
END;
END; {INPROC}

BEGIN

WITH Scrfile^[ItemNum] DO BEGIN { Lee's Line added }

CASE action OF
   SETSCR : BEGIN 
      clear_screen;
      GOTOXY(1,8);
      WRITE ('Label: _________________________________');
      GOTOXY(1,9);
      WRITE ('Var Name: ______________________________');
      GOTOXY(1,10);
      WRITE ('VAR Type: _______________');
      GOTOXY(1,11);
      WRITE ('Length: ___');
      GOTOXY(15,11);
      WRITE ('Line: ___');
      GOTOXY(26,11);
      WRITE ('Column: ___');
      GOTOXY(1,13);
      WRITE ('Display Style: ________');
      GOTOXY(1,15);
      WRITE ('Edit? ______');
      GOTOXY(1,16);
      WRITE ('Default: ____________________________________________________________');
   END; (* Setup *)
   
   INSCR: BEGIN
      INPROC;
   END; (* Input *)
   
   OUTSCR : BEGIN
      (* Print ItemLabel *)
      GOTOXY(8,8);
      WRITE(ItemLabel);
      (* Print ItemName *)
      GOTOXY(11,9);
      WRITE(ItemName);
      (* Print ItemType *)
      GOTOXY(11,10);
      WRITE(ItemType);
      (* Print ItemLength *)
      GOTOXY(9,11);
      WRITE(ItemLength);
      (* Print ItemY *)
      GOTOXY(21,11);
      WRITE(ItemY);
      (* Print ItemX *)
      GOTOXY(34,11);
      WRITE(ItemX);
      (* Print ItemDisplayType *)
      GOTOXY(16,13);
      CASE ItemDisplayType OF
         Normal : WRITE('Normal');
         Inverse: WRITE('Inverse');
         Flash  : WRITE('Flash')
      END; (* CASE *)
      (* Print ItemEdit *)
      GOTOXY(7,15);
      IF ItemEdit THEN WRITE('Yes')
         ELSE WRITE('No ');
      (* Print ItemDefault *)
      GOTOXY(10,16);
      WRITE(ItemDefault);
   END (* Output *)
END; (* CASE *)

END; { WITH ... Lee's Line added }

END; (* ScreenOut *)

PROCEDURE OPEN_FILE;

BEGIN

  { Open Screen Definition }
  GOTOXY(5,5);
  WRITELN('What Screen shall I process?');
  WRITE  ('     (dev:fname) ');
  READLN(ScreenName);
  IF POS('.SCRN',ScreenName) = 0 THEN
     ScreenName := CONCAT(ScreenName,'.SCRN');

  (*$I-*)
     RESET(Scrfile,ScreenName);
  (*$I+*)
  
  IF IORESULT <> 0 THEN { Create file }
     REWRITE(Scrfile,ScreenName);

  SEEK(Scrfile,0);
     
END; { OPEN_FILE  }
     
  
FUNCTION Menu:INTEGER; { Show Menu and Return 1..5 }

VAR CH  : CHAR;

BEGIN
   CLEAR_SCREEN;
   GOTOXY(10,1);
   WRITELN('Pascal Screen Editor');
   GOTOXY(5,5);
   WRITELN('1. Clear Screen');
   GOTOXY(5,7);
   WRITELN('2. Clear Item');
   GOTOXY(5,9);
   WRITELN('3. Edit Item');
   GOTOXY(5,11);
   WRITELN('4. Exit and Save Changes');
   GOTOXY(5,13);
   WRITELN('5. Exit w/o Saving');
   GOTOXY(5,15);
   WRITELN('6. Show Screen');
   GOTOXY(5,17);
   WRITELN('7. Enter Item');
   
   GOTOXY(1,22);
   WRITE('Enter Command Number: ');
      
   REPEAT
      READ(CH);
      IF NOT (CH IN ['1'..'7']) THEN
         WRITE (CHR(7),CHR(8)); { Beep - BS }
   UNTIL CH IN ['1'..'7'];
   
   Menu := ORD(CH) - ORD('0');
   
END; { Menu }

PROCEDURE ZeroScreen;

VAR CH: CHAR;
    I : INTEGER;

BEGIN
   CLEAR_SCREEN;
   GOTOXY(5,5);
   WRITE('Clearing Screen Definition. OK? ');
   READ(CH);
   IF CH in Yes THEN
      FOR I := 1 TO MaxNumOfItems DO 
         WITH Scrfile^[I] DO BEGIN
            ItemLabel := '';
            ItemLength:= 0;
            ItemX     := 0;
            ItemY     := 0;
            ItemEdit  := False;
            ItemDefault:='';
            ItemType  := 'String';
            ItemDisplayType := Normal;
            ItemValid := FALSE;
           END; {LOOP}
         
END; { Clear All Items }

FUNCTION WhichItem(Action:String):INTEGER; { Returns Item Number }

VAR I : Integer;

BEGIN
   CLEAR_SCREEN;
   GOTOXY(5,5);
   WRITELN('Which Item do you want to ',Action,'? ');
   WRITE  ('     (1-60) ');
   READLN(I);
   WhichItem := I;
END; { WhichItem }

PROCEDURE ZeroItem;

VAR CH: CHAR;
    I : INTEGER;

BEGIN
   
   I := WhichItem('Remove');
   GOTOXY(5,7);
   WRITE('Removing Item ',I,'. OK? ');
   READ(CH);
   IF CH in Yes THEN
      Scrfile^[I].ItemValid := False;

END; { Clear an Items }

PROCEDURE EnterItem;

VAR CH: CHAR;

BEGIN
   ItemNum := WhichItem('Enter');
   IF Scrfile^[ITEMNUM].ItemValid THEN BEGIN
      GOTOXY(5,7);
      WRITELN('Item ',ItemNum,' Exists');
      WRITE  ('   Shall I ReEnter it? ');
      READ(CH);
      IF NOT (CH in Yes) THEN
         EXIT(EnterItem);
     END;
     
   REPEAT
      ScreenOut(Setscr);
      ScreenOut(Inscr);
      ScreenOut(Setscr);
      ScreenOut(outscr);
      GOTOXY(0,23);
      WRITE(' Is This Correct ');
   UNTIL GetBoolean(1,Status);
   Scrfile^[ITEMNUM].ItemValid := TRUE;
   
END;

PROCEDURE EditItem;

VAR I: INTEGER;

PROCEDURE ChangeS(VAR Value:String;Name:String);

VAR CH: CHAR;

BEGIN
   WRITELN(Name:15,' ',Value);
   REPEAT
      WRITE('Make Changes (y/n)? ');
      READ(CH);
      WRITELN;
   UNTIL CH IN YesNo;
   IF CH IN Yes THEN
      BEGIN
      WRITELN('Enter New Value ');
      READLN(Value);
      END;
END; { ChangeS }

PROCEDURE ChangeI(VAR Value:INTEGER;Name:STRING);

VAR CH: CHAR;

BEGIN
   WRITELN(Name:15,' ',Value);
   REPEAT
      WRITE('Make Changes (y/n)? ');
      READ(CH);
      WRITELN;
   UNTIL CH IN YesNo;
   IF CH IN Yes THEN
      BEGIN
      WRITELN('Enter New Value ');
      READLN(Value);
      END;

END; { ChangeI }
   
BEGIN { Body of EditItem }
   
   I := WhichItem('Edit');
      
   WITH Scrfile^[I] DO BEGIN
      IF NOT ItemValid THEN BEGIN
         
         ItemName := '';
         ItemLabel:= '';
         ItemType := '';
         ItemDefault := '';
         ItemEdit := FALSE;
         ItemLength := 0;
         ItemX      := 0;
         ItemY      := 0;
         ItemDisplayType := Normal;
        END;
      
      ChangeS(ItemName,'Name');
      ChangeS(ItemLabel,'Label');
      ChangeS(ItemType,'VAR type');
      ChangeS(ItemDefault,'Default Value');
      ChangeI(ItemLength,'Length');
      ChangeI(ItemX,'Column');
      ChangeI(ItemY,'Line Number');
      ItemValid := True;
   
   END;

END; { Edit an Item }
  
PROCEDURE ShowScreen;

VAR ItemNum,
    x,y,I   : INTEGER;
    CH      : CHAR;
    First   : BOOLEAN;

BEGIN
   CLEAR_SCREEN;
   First := True;
   FOR ItemNum := 1 to MaxNumOfItems DO
      WITH Scrfile^[ITEMNUM] DO
        IF ItemValid THEN BEGIN
         
         IF First THEN BEGIN
            x := ItemX+1+Length(ItemLabel);
            y := ItemY;
            First := FALSE;
           END;
           
         GOTOXY(ItemX,ItemY);
         WRITE (ItemLabel,' ');
         FOR I := 0 to ItemLength DO
            IF I > 0 THEN WRITE('_');
        END;
   
   GOTOXY(x,y);
   READ(CH);

END; { ShowScreen }

BEGIN { Main }

  YesNo := ['Y','y','N','n'];
  Yes   := ['Y','y'];
  
  CLEAR_SCREEN;
  GOTOXY(10,0);
  WRITELN('Edit or Create Screen');

  OPEN_FILE;
  
  ThatsAll := FALSE;
  REPEAT
     
    CASE Menu OF
     
     1 : ZeroScreen;
     
     2 : ZeroItem;
     
     3 : EditItem;
     
     4 : BEGIN { Exit and Save }
           SaveIt := True;
           ThatsAll := TRUE;
           SEEK(Scrfile,0);
           PUT (Scrfile);
         END;
     
     5 : BEGIN { Exit w/o Save }
           SaveIt := False;
           ThatsAll := TRUE;
         END;
        
     6 : ShowScreen;
        
     7 : EnterItem
     
    END; (* Case Statement *)
  
  UNTIL ThatsAll = TRUE;
  
  IF SaveIt THEN CLOSE(Scrfile,LOCK)
            ELSE CLOSE(Scrfile);
  
END.
  

========================================================================================
DOCUMENT :usus Folder:VOL13:scrgen.text
========================================================================================

(*dont use the $LPrinter:*)

SCREDIT - edit the screen definition
SCRGEN - write the Pascal program
TYPES - file definitions for SCREDIT and SCRGEN
These two programs allow you to define a form to be filled in on
     the screen and then write a Pascal procedure that you can
     incorporate in your own programs to set up the screen form,
     allow the user to enter data for all the fields and show the
     contents of all the fields.  This is version 1 of the
     programs but they work.  These should shorten the time needed
     to set up programs that enter several values from the screen.
     The programs that this program writes make calls to the
     functions in GETFUNCS above.
by Lee Meador - FWAUG, DAC


{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}
{                                      }
{ Screen Code Generator - by Lee Meador}
{ Version 1.0                Box 3261  }
{ Copyright (c) 1981     Arlington, TX }
{                            76010     }
{                                      }
{ Uses information written in a data   }
{   file to generate Pascal code (in   }
{   a text file) that will let you     }
{   set up a form on the screen, and   }
{   then input or output the info for  }
{   the screen.                        }
{                                      }
{ The program SCREDIT allows you to    }
{   create and modify the data file    }
{   so as to have the right number of  }
{   variables of the right types, etc. }
{                                      }
{ The Pascal Procedure written by this }
{   program requires the procedures in }
{   GETFUNCS to work correctly.        }
{                                      }
{ This program could use some work to  }
{   keep from writing procedures that  }
{   are too big. If this happens, you  }
{   can use the E)ditor to move part   }
{   of the code into a second procedure}
{                                      }
{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}

PROGRAM PScrn_2;

CONST MaxNumOfItems = 60;

TYPE
(*$I:TYPES.TEXT *)

VAR     Scrfile : FILE OF Scrn;
        Txt     : TEXT;
        First   : BOOLEAN;
        Indent,
        ScreenName,
        ScreenOut: STRING;
        ItemNum : INTEGER;
        
procedure clear_screen;
begin
   gotoxy ( 0, 0 );
   write ( chr ( 27 ), 'J' );  {H-19 specific}
end;

PROCEDURE OPEN_INPUT;

BEGIN

  REPEAT { Open Screen Definition }
     GOTOXY(5,5);
     WRITELN('What Screen shall I process?');
     WRITE  ('     (dev:fname) ');
     READLN(ScreenName);
     IF POS('.SCRN',ScreenName) = 0 THEN
        ScreenName := CONCAT(ScreenName,'.SCRN');
   
     (*$I-*)
        RESET(Scrfile,CONCAT(ScreenName,'[30]'));
     (*$I+*)
  UNTIL IORESULT = 0;
     
END; { OPEN_INPUT }
     
PROCEDURE OPEN_OUTPUT;

VAR Strng: String;
    Flag : Boolean;
    CH   : Char;
    
BEGIN
  
  REPEAT { Open Text Output file }
     ScreenOut := CONCAT(COPY(ScreenName,1,Length(ScreenName)-5),'.TEXT');
     GOTOXY(5,8);
     WRITELN('What Name for Text Output? ');
     WRITE  ('     (',ScreenOut,') ');
     READLN(Strng);
     IF Length(Strng) <> 0 THEN
        ScreenOut := Strng;
     (*$I-*)
        RESET(Txt,ScreenOut);
     (*$I+*)
     Flag := (IORESULT<>0); { Non-existent }
     IF NOT Flag THEN REPEAT
          CLOSE(Txt); { Close it for now }
          GOTOXY(0,23);
          WRITE('Already Exists. Replace? (Y/N) ');
          READ(CH);
          Flag := CH IN ['Y','y']; { OR ok to replace }
        UNTIL CH IN ['Y','y','N','n'];
  UNTIL Flag;
  REWRITE(Txt,ScreenOut);
  
  END; (* OPEN_OUTPUT *)
  
PROCEDURE DO_SETUP;

VAR I,ItemNum : Integer;

BEGIN
  GOTOXY(1,23);
  WRITE (' Generating SETUP   ',chr(7));
  
  WRITELN(Txt, '   SETUP : BEGIN ');
  {WRITELN(Txt, '      PAGE(OUTPUT);');}
  WRITELN ( TXT, '      WRITE ( CHR ( 27 ), CHR ( 69 ));' );  {H-19 SPECIFIC}
  FOR ItemNum := 1 TO MAXNUMOFITEMS DO 
     WITH Scrfile^[ItemNum] DO
         IF ItemValid THEN BEGIN
            WRITELN(Txt,Indent,
                    'GOTOXY(',ItemX,',',ItemY,');');
            WRITE  (Txt,Indent,
                    'WRITE (''',ItemLabel); { Put WRITE & Label }
            IF ItemLength > 0 THEN
               WRITE(Txt, ' '); { Put <SP> if more }
            FOR I := 1 to ItemLength DO
               WRITE(Txt, '_'); { Put Underlines }
            WRITELN(Txt, ''');'); { Put End of WRITE }
         END; {LOOP}
  
  WRITELN(Txt, '   END; (* Setup *)');
     
END; (* WRITING SETUP *)

PROCEDURE DO_INPUT;

VAR Last,
    I,
    ItemNum        : INTEGER;

PROCEDURE DO_Default; { within DO_INPUT }

BEGIN
   WITH Scrfile^[ItemNum] DO BEGIN
      WRITE  (Txt,Indent,
              'IF Return = Default THEN ');
      IF ItemDefault = ''
         THEN WRITE(Txt,'Temp',ItemType,':=',ItemName)
         ELSE BEGIN
            WRITE(Txt,'Temp',ItemType,':=');
            IF ItemType = 'STRING' THEN WRITE(Txt,'''');
            WRITE(Txt,ItemDefault);
            IF ItemType = 'STRING' THEN WRITE(Txt,'''');
           END; {ELSE}
      WRITELN(Txt,';');
   END; { WITH }
END; { Do Default }

BEGIN { DO_INPUT }
   GOTOXY(0,23);
   WRITE ('Generating INPUT',chr(7));
   
   WRITELN(Txt, '   INPUT: BEGIN');
   WRITELN(Txt, '(*$G+*)');
   
   Last := -1;
   FOR ItemNum := 1 TO MaxNumOfItems DO
      WITH Scrfile^[ItemNum] DO
          IF ItemValid THEN BEGIN
             FOR I := 1 to LENGTH(ItemType) DO
                IF ItemType[I] IN ['a'..'z'] THEN 
                   ItemType[I] := CHR(ORD(ItemType[I])-32);
             IF Last < 0 THEN Last := ItemNum; { For first item }
             WRITELN(Txt);
             WRITELN(Txt,Indent,
                    '(* Input ',ItemName,' *)');
             WRITELN(Txt,Indent,
                     ItemNum,': ','GOTOXY(',ItemX+1+Length(ItemLabel),
                     ',',ItemY,');');
             WRITE  (Txt,Indent);
             IF ItemType <> 'STRING' THEN
                WRITE(Txt,'Temp',ItemType,':=');
             WRITE  (Txt,'Get',ItemType,
                     '(',ItemLength,',Return');
             IF ItemType = 'STRING' THEN
                WRITE(Txt,',Temp',ItemType);
             WRITELN(Txt,');');
             WRITELN(Txt,Indent,
                     'IF Return = Backup THEN GOTO ',Last,';');
             DO_Default;
             
             WRITELN(Txt,Indent,
                     'GOTOXY(',ItemX+1+Length(ItemLabel),',',Itemy,');');
             IF ItemType = 'BOOLEAN'
                THEN WRITELN(Txt,Indent,
                             'IF TempBOOLEAN THEN WRITE(''Yes'')',
                             ' ELSE WRITE(''No'');')
                ELSE WRITELN(Txt,Indent,
                             'WRITE(Temp',ItemType,');');
             WRITELN(Txt,Indent,
                     ItemName,':=Temp',ItemType,';');
             
             Last := ItemNum; { For Labels }
          END; {LOOP}
   
   WRITELN(Txt, '(*$G-*)');
   WRITELN(Txt, '   END; (* Input *)');

END; (* WRITING INPUT *)

PROCEDURE DO_OUTPUT;

VAR ItemNum: INTEGER;

BEGIN
   GOTOXY(0,23);
   WRITE ('Generating OUTPUT',chr(7));
   
   WRITELN(Txt, '   OUTPUT : BEGIN');
   
   FOR ITEMNUM := 1 TO MAXNUMOFITEMS DO 
     WITH Scrfile^[ItemNum] DO
         IF ItemValid AND (ItemLength > 0) THEN BEGIN { No Screen Labels }
            
            WRITELN(Txt,Indent,
                    '(* Print ',ItemName,' *)');
            WRITELN(Txt,Indent,
                    'GOTOXY(',ItemX+1+LENGTH(ItemLabel),',',
                    ItemY,');');
            WRITELN(Txt,Indent,
                    'WRITE(',ItemName,');');
         
         END; {LOOP}
   
   WRITELN(Txt, '   END; (* Output *)');

END; (* WRITING OUTPUT *)
  
BEGIN { Main }

  clear_screen;
  GOTOXY(10,0);
  WRITELN('Generate Screen Code');

  OPEN_INPUT;
  
  OPEN_OUTPUT;
  
  clear_screen;
  GOTOXY(10,0);
  WRITELN('Pascal Screen Generator');
  WRITELN;
  WRITELN('Generating Pascal Source to');
  WRITELN('    ',ScreenOut);
  
  GOTOXY(1,23);
  WRITE (' Generating DEFINES ');
  
  Indent := '      ';
  WRITELN(Txt, 'PROCEDURE SCREENOUT(Action:ACTCODE);');
  
  WRITE  (Txt, 'LABEL ');
  First := True;
  For ItemNum := 1 to MaxNumOfItems DO
     If Scrfile^[ItemNum].ItemValid THEN BEGIN
        IF NOT First THEN BEGIN
           WRITELN(Txt,',');
           WRITE  (Txt,'      ');
          END;
        WRITE(Txt,ItemNum);
        First := FALSE;
       END;
  WRITELN(Txt, ';');
  
  WRITELN(Txt, 'TYPE Stat: (Good,Backup,Default);');
  
  WRITELN(Txt, 'VAR TempBoolean: BOOLEAN;');
  WRITELN(Txt, '    TempString : STRING;');
  WRITELN(Txt, '    TempInteger: INTEGER;');
  WRITELN(Txt, '    TempReal   : REAL;');
  WRITELN(Txt, '    TempLongInteger: INTEGER[36];');
  WRITELN(Txt, '    Return     : Stat');
  
  WRITELN(Txt, 'BEGIN');
  WRITELN(Txt, 'CASE action OF');
  
  DO_SETUP;
  
  DO_INPUT;
  
  DO_OUTPUT;
  
  WRITELN(Txt, 'END; (* ScreenOut *)');
  
  CLOSE(Txt,LOCK);
  
END.
  

========================================================================================
DOCUMENT :usus Folder:VOL13:spec_doc.text
========================================================================================


 
.comment            !---------------------------------!
.comment            !                                 !
.comment            !       RUNON documentation       !
.comment            !       Special characters        !
.comment            !                                 !
.comment            !         August 3, 1980          !
.comment            !                                 !
.comment            !---------------------------------!


.page .center "^&SPECIAL CHARACTERS\&"

  The eight following commands are used to control various functions.
These functions are underlining, spacing, case,
and the printing out of the special  characters themselves.
The commands that set upper case override the case-changing
dot-commands.

.nofill

The functions are each represented by a specific character:

    &  Underline,
    _^  Uppercase.

Notice that the following "lead-in characters" have
specific effects on the functions:

    _<  turns the function on for a word,
    _^  locks the function on until a '_\' is encountered,  
    _\  unlocks the function.


.center " ^&Command sequences\& " .fill .skip 1

_<_&##Underline word######

.leftmargin 35

When prefixed to a word, this sequence causes the word to be underlined. If
this sequence is not prefixed to a word, it will be ignored.

.skip 1 .leftmargin 10

_^_&##Underline lock######

.leftmargin 35

causes the underline lock to be set: all subsequent words will be underlined
until the underline unlock sequence is encountered. Spaces between words will
not be underlined.

.skip 1 .leftmargin 10

_\_&##Underline unlock####

.leftmargin 35

This sequence will only have effect if the underline lock sequence has
previously been encountered.

.skip 1 .leftmargin 10

_<_^##Uppercase word######

.leftmargin 35

When prefixed to a word, this sequence causes the word to be output in
uppercase. If this sequence is not prefixed to a word, it will be ignored.

.skip 1 .leftmargin 10

_^_^##Uppercase lock######   

.leftmargin 35

causes all subsequent words to be in uppercase until the uppercase unlock
sequence is encountered. Does not effect title or centered text.
.page

.leftmargin 10

_\_^##Uppercase unlock####

.leftmargin 35

This sequence will only have effect if the uppercase lock sequence has been
encountered.

.skip 1 .leftmargin 10

_####Hard space##########

.leftmargin 35

This character is used while in filling or justification mode to force
a space where needed. When one or more of
these characters are placed between two words, the spacing will be preserved in
the output file with no extra spacing inserted or removed due to justification
or filling.

.skip 1 .leftmargin 10

__###Quote###############

.leftmargin 35

The character following the quote character is taken literally, and is not
affected by any attributes in effect, except underlining.
It can be used to print one of the lead-in characters or _# if it is
to appear in the output file. For example, if it is desired to print a period in
column one of the output file, the period must be prefixed with an underline.
This character must be prefixed by itself if it is to be printed out.

.justify .leftmargin 10



========================================================================================
DOCUMENT :usus Folder:VOL13:startup.text
========================================================================================


(*
     PutDate is a simple routine which will allow you to enter the
     system date and pre-set the prefix at boot time.  This version
     works only on UCSD version II.0 or III.0 as it requires the system
     globals (found on volume 8).  There is also another file called
     PDATE.TEXT which must be compiled and linked with PUTDATE.
     
     There is a salutations message which is kind of silly, but I like it.
     However it uses H-19 "graphics" characters so you will have to change
     of delete it if you don't have an H-19.
     
     George Schreyer
*)
     
(*$S+*)
(*$C Copyright (c) 1982 Great Western Software  all rights reserved*)

program put_date;

const prompt_line = 21;

type date_string = string [ 10 ];
     
     {this record discribes the structure of a UCSD directory}
     
     daterec = packed record
                        month: 0..12;
                        day: 0..31;
                        year: 0..100
               end;

     dirrange = 0..78;  {this is set to 78 instead of 77 to make the record
                         larger than 4 blocks.  this allows the directory
                         to be read with a blockread without memory allocation
                         problems.  the final part of a record cannot be 
                         accessed because dloadtime will never exceed 77.}

     vid = string[7];
     tid = string[15];
     filekind = (untyped,xdisk,code,text,
                 info,data,graf,foto,securedir);

     direntry = record
                  dfirstblk: integer; {first block on disk}
                  dlastblk: integer;  {top of system area  blk 6 or 10}
                  case dfkind:filekind of
                    securedir,untyped: 
                                       (dvid:vid;  {volumeid}
                                        deovblk,   { ? }
                                        dloadtime, {# of files}
                                        dblocks:integer; {size of volume}
                                        dlastboot:daterec); {system date}
                    xdisk,code,text,info,data,
                    graf,foto: 
                               (dtid:tid;  {filename}
                                dlastbyte:1..512;  {last byte in last block}
                                daccess:daterec) {date}
                end;

     directory = array[dirrange] of direntry;
     
var  datex      : daterec;
     x,y : integer;
     day_string,
     month_string,
     year_string : string;
     temp_date,date       : string;
     iday,
     imonth,
     iyear      : integer;
     k          : integer;
     file_length: integer;
     dirx       : directory;
     disk       : file;
     quit       : boolean;
     prefix_volume : vid;

procedure set_prefix ( prefix_volume : vid ); external;
procedure eeos; external;
procedure eeol; external;
procedure p_date ( date : daterec );  external;
procedure get_date ( date : daterec ); external;

procedure int_to_str ( number : integer;
                     var strg : string );
var ch : char;
    neg : boolean;
    i : integer;
begin
   strg := '00000';
   neg := false;
   if number < 0 then
      begin
         neg := true;
         number := number * ( -1 );
      end;
   for i := 1 to 5 do
      begin
         ch := chr ( ( number mod 10 ) + ( ord ( '0' ) ) );
         number := number div 10;
         strg [ 6 - i ] := ch;
      end;
   while pos( '0', strg ) = 1 do delete ( strg, 1, 1 );
   if strg = '' then strg := '0'
   else if neg then strg := concat ( '-',strg );
end;

procedure decode_date(day,month,year:integer);
   begin
    case month of
      1: month_string:='Jan';
      2: month_string:='Feb';
      3: month_string:='Mar';
      4: month_string:='Apr';
      5: month_string:='May';
      6: month_string:='Jun';
      7: month_string:='Jul';
      8: month_string:='Aug';
      9: month_string:='Sep';
      10:month_string:='Oct';
      11:month_string:='Nov';
      12:month_string:='Dec'
    end;
    daystring := '';
    yearstring := '';
    int_to_str(day,daystring);
    int_to_str(year,yearstring);
 end;

procedure str_to_int( var data : string;
                    var number : integer;
                    var was_integer: boolean);
{converts input string to a positive integer}
var i : integer;

begin
   was_integer := true;
   number := 0;
   i := 0;
   if data <> '' then
      repeat
           i := i + 1;
           if data [i] in ['0'..'9'] then
              number := 10 * number + (ord(data[i]) - ord('0'))
           else was_integer := false;
      until ( not was_integer ) or ( i = length(data))
   else was_integer := false;
end;

procedure check_month ( month_string : string;
                        var month    : integer );
var i : integer;
begin
   month := 0;
   if length ( month_string ) > 0 then
      begin
         for i := 1 to length ( month_string ) do
           if month_string [ i ] in [ 'a'..'z' ] then
              month_string [ i ] := chr ( ord ( month_string [ i ] ) - 32 );
         if month_string = 'JAN' then month := 1;
         if month_string = 'FEB' then month := 2;
         if month_string = 'MAR' then month := 3;
         if month_string = 'APR' then month := 4;
         if month_string = 'MAY' then month := 5;
         if month_string = 'JUN' then month := 6;
         if month_string = 'JUL' then month := 7;
         if month_string = 'AUG' then month := 8;
         if month_string = 'SEP' then month := 9;
         if month_string = 'OCT' then month := 10;
         if month_string = 'NOV' then month := 11;
         if month_string = 'DEC' then month := 12;
      end;
end;
              
procedure space_wait;
var ch : char;
begin
   write ( ' <space> to continue ' );
   repeat
      read ( keyboard, ch );
   until ( ch = ' ' ) and ( not eoln ( keyboard ) );
   gotoxy ( 0, prompt_line + 1 );
   eeol;
end;

function take_apart_date ( var date    : date_string;
                            var day     : integer;
                            var month   : integer;
                            var year    : integer ): boolean;
var i : integer;
    day_ok, month_ok, year_ok : boolean;
    temp : string [ 1 ];

begin
   day_ok := true;
   month_ok := true;
   year_ok := true;
   take_apart_date := true;
   day_string := '';
   month_string := '';
   year_string := '';
   temp := ' ';
   i := 1;
   repeat
      temp [ 1 ] := date [ i ];
      if i in [ 1, 2 ] then
         begin
            if ( i = 2 ) and 
               ( not ( ord ( temp [ 1 ] ) in 
                  [ ord ( '0' )..ord ( '9' ) ] ) ) then
               begin
                  day_string := concat ( '0', day_string );
                  date := concat ( '0', date );
               end
            else
               day_string := concat ( day_string, temp );
         end;
      if i in [ 4, 5, 6 ] then
         month_string := concat ( month_string , temp );
      if i in [ 8, 9, 10 ] then 
         year_string := concat ( year_string, temp );
      i := succ ( i );
   until i > length ( date );
   if length ( day_string ) > 0 then
      str_to_int ( day_string, day, day_ok );
   if ( day_ok ) and ( day in [ 1..31 ] ) then
      begin
         if length ( month_string ) > 0 then 
            check_month ( month_string, month );
         if month in [ 1..12 ] then
            begin
               if length ( year_string ) > 0 then
                  str_to_int ( year_string, year, year_ok );
               if ( not ( year in [ 0..99 ] ) ) or
                  ( not year_ok ) then 
                  begin
                     write ( 'year invalid ' );
                     space_wait;
                     take_apart_date := false;
                     date := '';
                     year := 100;
                  end;
            end
         else  
            begin
               write ( ' month invalid ' );
               space_wait;
               take_apart_date := false;
               date := '';
               month := 0;
            end;
      end
   else
      begin
         write ( 'day invalid ' );
         space_wait;
         take_apart_date := false;
         date := '';
         day := 0;
      end;
end;

procedure banner;  {just a silly message using H-19 graphics,
                        delete this whole procedure or write your
                        own if you don't have an H-19}

PROCEDURE FINISH;
BEGIN
GOTOXY( x + 16, y + 3 );
WRITE('W e l c o m e');
GOTOXY( x + 21, y + 5 );
WRITE('t o');
GOTOXY( x + 10, y + 7 );
WRITE('George''s Computer Center');
GOTOXY( x + 4, y + 12 );
WRITE('UCSD Pascal p-system v2.0 presiding');
gotoxy ( x + 15, y + 14 );
prefix_volume := '#5';
write ( 'Prefix is ', prefix_volume, ':' );
set_prefix ( prefix_volume );
END;

procedure write_a ( x, y, n : integer );
var j : integer;
begin
   gotoxy ( x, y );
   for j := 1 to n do write ( 'a' );
end;

procedure write_bar ( x, y, n : integer );
var j : integer;
begin
gotoxy ( x, y );
for j := 1 to n do 
   begin
      write ( chr ( 96 ), chr ( 10 ), chr ( 8 ) );
   end;
end;

BEGIN
WRITELN(CHR(27),'t');  {sets keypad shifted mode}
WRITELN(CHR(27),'x5'); 
WRITELN(CHR(27),'F');
x := 17;
y := 4;
gotoxy ( x, y );
write ( 'f' );
write_a ( x + 1, y, 42 );
write ( 'c' );
gotoxy ( x + 2, y + 1 );
write ( 'f' );
write_a ( x + 3, y + 1, 38 );
write ( 'c' );
write_a ( x + 1, y + 10, 42 );
write ( 'd' );
write_a ( x + 3, y + 9, 38 );
write ( 'd' );
write_bar ( x, y + 1, 9 );
write ( 'e' );
write_bar ( x + 2, y + 2, 7 );
write ( 'e' );
write_bar ( x + 43, y + 1, 9 );
write_bar ( x + 41, y + 2, 7 );
WRITE(CHR(27),'G');
FINISH;
WRITE(CHR(27),'y5');
END;

procedure write_date_to_disk;
begin
   reset ( disk, '*' );
   k := blockread ( disk, dirx, 4, 2 );
   dirx[0].dlastboot := datex;
   k := blockwrite ( disk, dirx, 4, 2 );
   close ( disk, lock );
end;

begin
   gotoxy ( 0, 0 );
   eeos;
   banner;
   quit := false;
   file_length := 0;
   get_date ( datex );
   with datex do
      begin
         iday := day;
         imonth := month;
         iyear := year;
         decode_date ( iday, imonth, iyear );
      end;
   date := concat ( day_string, '-', month_string, '-', year_string );
   if pos ( '-', date ) = 2 then date := concat ( '0', date );
   with datex do
      begin
         if not take_apart_date ( date, iday, imonth, iyear ) then
            begin
               write ( 'date in memory invalid' );
               exit ( program );
            end;
         gotoxy ( 0,prompt_line -1 );
         writeln ( 'Today is ', date );
         repeat
            gotoxy ( 0, prompt_line );
            eeol;
            write ( 'New date ? ' );
            readln ( temp_date );
            if length ( temp_date ) = 0 then exit ( program );
            if take_apart_date ( temp_date, iday, imonth, iyear ) then
               begin
                  day := iday;
                  month := imonth;
                  year := iyear;
                  p_date ( datex );
                  quit := true;
                  write_date_to_disk;
               end;
         until quit;
      end;
end.




========================================================================================
DOCUMENT :usus Folder:VOL13:sysgen.text
========================================================================================


{$S+}  
 
{$C Copyright (C) 1980  Wynn Newhouse and Herb Jellinek. }
{$C All rights reserved. Unauthorized reproduction is a  }
{$C violation of applicable laws.                        }
 
Program Runon;
 
(*$I DECLARE.TEXT*)
(*$I INITC.TEXT*)
 
 
Procedure include_file(f_name : string);  Forward;
 
 
   Procedure out_proc(cmd : commandtype);
 
   var
      i, j      : posint;
      v         : old_new;
      eo_input,
      eo_output : boolean;
 
 
   Procedure putline(n : posint);  Forward;
 
 
      (*$I DOPAGE.TEXT*)
 
   Procedure d_c_p;
 
   var
      searching,
      eo_line    : boolean;
      cmd        : commandtype;
      pos        : posint;
 
 
   (*$I READNU.TEXT*)
 
 
   Procedure process_file(var source  : text;
                              inc_fil : boolean);
 
 
(*$I READLN.TEXT*)
(*$I MAIN.TEXT*)
 

========================================================================================
DOCUMENT :usus Folder:VOL13:taxcalc.text
========================================================================================

{From "FIT - A Federal Income Tax Program in UCSD Pascal" by Edward Heyman
 appearing in the Feburary 1982 issue of Byte magazine.  Copyright 1982
 Byte Publications, Inc.  Used with permission of Byte Publications, Inc.}
 
{This program is not EXACTLY the original, it has been patched is several
 places.  Specifically, some of the data in TAXTABLE.TEXT has been changed}
 

segment procedure calculate;
var     ln      : tline_num;

procedure ad ( first, second, sum : tline_num );
{add two lines}
var     ln : tline_num;
begin
   tlines [ sum ].hus := tlines [ first ].hus + tlines [ second ].hus;
   tlines [ sum ].wif := tlines [ first ].wif + tlines [ second ].wif;
   tlines [ sum ].tot := tlines [ first ].tot + tlines [ second ].tot;
end;

procedure add ( start, finish, sum : tline_num );
var     ln      : tline_num;
begin
   for ln := start to finish do
      begin
         tlines [ sum ].hus := tlines [ sum ].hus + tlines [ ln ].hus;
         tlines [ sum ].wif := tlines [ sum ].wif + tlines [ ln ].wif;
         tlines [ sum ].tot := tlines [ sum ].tot + tlines [ ln ].tot;
      end;
end;

procedure sub ( first, second, dif : tline_num );
{subtract two lines}
var     ln      : tline_num;
begin
   tlines [ dif ].hus := tlines [ first ].hus - tlines [ second ].hus;
   tlines [ dif ].wif := tlines [ first ].wif - tlines [ second ].wif;
   tlines [ dif ].tot := tlines [ first ].tot - tlines [ second ].tot;
end;

procedure taxcalc;
{the thx calculation is done here}
var     ch      : char;
        htaxable,
        wtaxable,
        ttaxable: longint;
        xfs     : filing_status;
        i       : 1..16;
        which   : longint;

procedure gettax ( tt : tax_table;
                   tax_able : longint;
                   var tax : longint;
                   w : owner );
{get factors from the taxtable ad do calculate the tax}
begin
   for i := 1 to 16 do {search the array for the correct tax bracket}
      if ( tax_able > taxray [ tt, i, lower ] ) and
         ( tax_able <= taxray [ tt, i, upper ] ) then
            begin   {bracked found, now calculate tax}
               tax := taxray [ tt, i, base ] + ( taxray [ tt, i, percent ] ) *
                 (( tax_able - taxray [ tt, i, lower ] ) div 100 );
               max_tax [ w ] := taxray [ tt, i, percent ];
               exit ( gettax );
            end;
end;

begin  {taxcalc}
   fstat := tlines [ 7 ].fs;   {get filing status}
   if fstat in [ 2, 3 ] then  {get exemptions for married}
      begin
         htaxable := tlines [ 34 ].hus - 100000;
         wtaxable := tlines [ 34 ].wif - 100000;
         ttaxable := tlines [ 34 ].tot - 100000 * ( tlines [ 7 ].exem );
         {calculate total as joint return use tax table Y}
         gettax ( y, ttaxable, tlines [ 35 ].tot, t_own );
         repeat
            clear;
            writeln ( 'should the individual taxes be calculated ' );
            write ('        as M(arried filing separatelu  U(nmarried ' );
            read ( keyboard, ch );
         until ch in [ 'M','m','U','u' ];
         if ch in [ 'U','u' ] then
            begin
            {calculate taxes for husband and wife as if they 
              could file as individuals}
               gettax ( x, htaxable, tlines [ 35 ].hus, h_own );
               gettax ( x, wtaxable, tlines [ 35 ].wif, w_own );
            end
         else
            begin
            {calculate taxes for husband and wife as filing separate}
               gettax ( ys, htaxable, tlines [ 35 ].hus, h_own );
               gettax ( ys, wtaxable, tlines [ 35 ].wif, w_own );
            end;
      end
   else
      begin  {get exemptions for unmarried}
         ttaxable := tlines [ 34 ].tot - 100000 * ( tlines [ 7 ].exem );
         case fstat of
           1 : gettax ( x, ttaxable, tlines [ 35 ].tot, t_own );
           2 : gettax ( z, ttaxable, tlines [ 35 ].tot, t_own );
           3 : gettax ( y, ttaxable, tlines [ 35 ].tot, t_own );
         end;
      end;
end;

procedure linea40;
{compensate for zero base}
begin
   if tlines [ 7 ].fs in [ 2, 3 ] then
      begin
         tlines [ 106 ].hus := 170000;
         tlines [ 106 ].wif := 170000;
         tlines [ 106 ].tot := 340000;
      end
   else
      case tlines [ 7 ].fs of
        1,4 : tlines [ 106 ].tot := 230000;
        5   : tlines [ 106 ].tot := 340000;
      end;
end;

procedure calsch_a;
{do calculations required by schedule A}
begin
   tlines [ 69 ].hus := tlines [ 31 ].hus div 100; {line A 3}
   tlines [ 69 ].wif := tlines [ 31 ].wif div 100; {line A 3}
   tlines [ 69 ].tot := tlines [ 31 ].tot div 100; {line A 3}
   sub ( 68, 69, 70 );                             {line A 4}
   with tlines [ 70 ] do
      begin
         if hus < 0 then hus := 0;                 {line A 4}
         if wif < 0 then wif := 0;                 {line A 4}
         if tot < 0 then tot := 0;                 {line A 4}
      end;
   add ( 70, 72, 73 );
   tlines [ 74 ].hus := 3 * tlines [ 69 ].hus;     {line A 7}
   tlines [ 74 ].wif := 3 * tlines [ 69 ].wif;     {line A 8}
   tlines [ 74 ].tot := 3 * tlines [ 69 ].tot;     {line A 8}
   sub ( 73, 74, 75 );
   with tlines [ 75 ] do
      begin
         if hus < 0 then hus := 0;                 {line A 9}
         if wif < 0 then wif := 0;                 {line A 9}
         if tot < 0 then tot := 0;                 {line A 9}
      end;
   ad ( 67, 75, 76 );                              {line A 10}
   tlines [ 99 ] := tlines [ 76 ];                 {line A 33}
   add ( 77, 81, 82 );                             {line A 16}
   tlines [ 100 ] := tlines [ 82 ];                {line A 34}
   add ( 83, 85, 86 );                             {line A 20}
   tlines [ 101 ] := tlines [ 86 ];                {line A 35}
   add ( 87, 89, 90 );                             {line A 24}
   tlines [ 102 ] := tlines [ 90 ];                {line A 36}
   sub ( 91, 92, 93 );                             {line A 27}
   if tlines [ 93 ].hus < 10000 then tlines [ 94 ].hus := tlines [ 93 ].hus
                                else tlines [ 94 ].hus := 10000;
   if tlines [ 93 ].wif < 10000 then tlines [ 94 ].wif := tlines [ 93 ].wif
                                else tlines [ 94 ].wif := 10000;
   if tlines [ 93 ].tot < 10000 then tlines [ 94 ].tot := tlines [ 93 ].tot
                                else tlines [ 94 ].tot := 10000;
   sub ( 93, 94, 95 );                             {line A 29}
   tlines [ 103 ] := tlines [ 95 ];                {line A 37}
   add ( 96, 97, 98 );                             {line A 32}
   tlines [ 104 ] := tlines [ 98 ];                {line A 38}
   add ( 99, 104, 105 );                           {line A 39}
   linea40;
   sub ( 105, 106, 107 );                          {line A 41}
   tlines [ 33 ] := tlines [ 107 ];
end;

procedure calsch_b;
begin
   tlines [ minbline + 1 ] := tlines [ minbline ];      {line B 1}
   tlines [ 9 ] := tlines [ minbline + 1 ];
   tlines [ minbline + 3 ] := tlines [ minbline + 2 ];  {line B 3}
   add ( minbline + 3, minbline + 5, minbline + 6 );    {line B 6}
   sub ( minbline + 3, minbline + 6, minbline + 7 );    {line B 7}
   tlines [ 10 ] := tlines [ minbline + 7 ];
end;

begin  {calcuate}
   gotoxy ( 0, 0 );
   eeol;
   write ( 'calculating ... ' );
   for ln := 8 to maxline do if ln in calcset then
      begin
         tlines [ ln ].hus := 0;
         tlines [ ln ].wif := 0;
         tlines [ ln ].tot := 0;
      end;
   calsch_b;
   with tlines [ 10 ] do
      begin   {dividend exclusion}
         hus := hus - 10000;
         if hus < 0 then hus := 0;
         wif := wif - 10000;
         if wif < 0 then wif := 0;
         tot := hus + wif;
      end;
   add ( 8, 21, 22 );                           {total income}
   add ( 23, 29, 30 );                          {total adjustments}
   sub ( 22, 30, 31 );                          {adjusted gross}
   tlines [ 32 ] := tlines [ 31 ];              {transfer 31 to 32}
   calsch_a;
   sub ( 32, 33, 34 );                          {income for start of tax
                                                 calculation}
   taxcalc;
   add ( 35, 36, 37 );                          {total taxes}
   add ( 38, 45, 46 );                          {total credits}
   sub ( 37, 46, 47 );                          {balance}
   add ( 47, 53, 54 );                          {balance}
   add ( 55, 61, 62 );                          {total tax payments}
   sub ( 54, 62, 63 );                          {taxes-tax payments}
   if tlines [ 63 ].hus < 0 then
      tlines [ 63 ].hus := -1 * tlines [ 63 ].hus       {overpayment}
   else
      begin
         tlines [ 66 ].hus := tlines [ 63 ].hus;        {balance due}
         tlines [ 63 ].hus := 0;
      end;
   if tlines [ 63 ].wif < 0 then
      tlines [ 63 ].wif := -1 * tlines [ 63 ].wif
   else
      begin
         tlines [ 66 ].wif := tlines [ 63 ].wif;
         tlines [ 63 ].wif := 0;
      end;
   if tlines [ 63 ].tot < 0 then
      tlines [ 63 ].tot := -1 * tlines [ 63 ].tot
   else 
      begin
         tlines [ 66 ].tot := tlines [ 63 ].tot;
         tlines [ 63 ].tot :=0;
      end;
   for ln := 8 to maxline do if ( ln in calcset ) then 
      tlines [ ln ].iptr := nil;
end; {calculate}
         

========================================================================================
DOCUMENT :usus Folder:VOL13:taxedit.text
========================================================================================

{From "FIT - A Federal Income Tax Program in UCSD Pascal" by Edward Heyman
 appearing in the Feburary 1982 issue of Byte magazine.  Copyright 1982
 Byte Publications, Inc.  Used with permission of Byte Publications, Inc.}
 
{This program is not EXACTLY the original, it has been patched is several
 places.  Specifically, some of the data in TAXTABLE.TEXT has been changed}
 

segment procedure edit;
var     ln      : tline_num;  {index to array tlines}
        int     : integer;
        edit_char,
        ch      : char;

procedure edit_spec;
{enter taxpayers name, the tax year, filing status, and the number of d
 dependents}
var     h, w    : integer;
        int,
        exemps  : integer;
        ln      : tline_num;

procedure filingstat;
begin
   with tlines [ 7 ] do
      begin
         gotoxy ( 0, 4 );
         eeos;
         writeln ( '   1) Single' );
         writeln;
         writeln ( '   2) Married filing Jointly' );
         writeln;
         writeln ( '   3) Married filing Separately' );
         writeln;
         writeln ( '   4) Head of Household' );
         writeln;
         writeln ( '   5) Widow(er)' );
         writeln;
         repeat
            int := readint ( 1 );
         until int in [ 1..5 ];
         fs := int;
         if fs in [ 2, 3 ] then single := false;
      end;
end;

begin {edit_spec}
   ln := 7;
   clear;
   gotoxy ( 0, 2 );
   with tlines [ 7 ] do
      begin
         center ( titles [ 5 ], screen );
         writeln;
         namer ( 'name', tlines [ 6 ].name, 26 );
         namer ( 'tax year', taxyear, 4 );
         filingstat;
         exem := 0;
         clear;
         gotoxy ( 0, 2 );
         write ( 'enter correct letter' );
         gotoxy ( 0, 4 );
         center ( titles [ 7 ], screen );
         writeln;
         writeln ( '   Y(ourself' );
         writeln;
         writeln ( '   O(ver sixtyfive' );
         writeln;
         writeln ( '   B(lind' );
         writeln;
         writeln ( '   T( over 65 and blind' );
         repeat
            read ( keyboard , ch );
         until ch in [ 'y','Y','o','O','b','B','t','T' ];
         case ch of 
           'Y','y' : h := 1;
           'O','o' : h := 2;
           'B','b' : h := 2;
           'T','t' : h := 3;
         end;
         if not single then
            begin
               center ( titles [ ln ], screen );
               writeln;
               gotoxy ( 0, 6 );
               eeos;
               writeln ( '   S(pouse' );
               writeln;
               writeln ( '   O(ver sixtyfive' );
               writeln;
               writeln ( '   B(lind' );
               writeln;
               writeln ( '   T( over 65 and blind' );
               repeat
                  read ( keyboard, ch );
               until ch in [ 's','S','o','O','b','B','t','T' ];
               case ch of
                 'S','s' : w := 1;
                 'O','o' : w := 2;
                 'B','b' : w := 2;
                 'T','t' : w := 3;
               end;
             end
          else w := 0;
          clear;
          gotoxy ( 0, 6 );
          write ( 'enter number of dependents ' );
          exemps := readint ( 2 );
          exem := w + h + exemps;
      end;
end;
               
procedure edit_tline ( ln : tline_num );
{main data input routine}
var     hsum,
        wsum,
        dol     : integer [ 9 ];
        nextptr,
        ptr,
        lastptr : pointer;
        tl      : boolean;
        ch      : char;

procedure view;
{displays contents of tlines[ln]}
var     screen : boolean;
        obj    : intstr;
begin
   obj := '';
   screen := true;
   gotoxy ( 0, 3 );
   eeos;
   if not single then
      begin
         gotoxy ( 0, 8 );
         pdol ( tlines [ ln ].hus, obj );
         write ( 'husband':20, obj:20 );
         gotoxy ( 0, 10 );
         pdol ( tlines [ ln ].wif, obj );
         write ( 'wife':20, obj:20 );
      end;
   gotoxy ( 0, 12 );
   pdol ( tlines [ ln ].tot, obj );
   write ( 'total':20, obj:20 );
end;

procedure sums;
{adds all items and place values in tlines [ ln ] }
begin
   with tlines [ ln ] do
      begin
         hus := 0;
         wif := 0;
         tot := 0;
         if iptr <> nil then
            begin
               nextptr := iptr;
               repeat 
                  if nextptr^.whose = h_own then hus := hus + nextptr^.amt
                   else wif := wif + nextptr^.amt;
                  nextptr := nextptr^.nptr;
               until nextptr = nil;
               tot := hus + wif;
            end;
      end;
end;

procedure who ( ptr : pointer );
{assign item to husband or wife}
begin
   with ptr^ do
      begin
         gotoxy ( 0, 12 );
         write ( 'assign to H(usband or W(ife ' );
         repeat
            read ( keyboard, ch );
         until ch in [ 'H','h','W','w' ];
         if ch in [ 'H','h' ] then whose := h_own else whose := w_own;
         gotoxy ( 0, 12 );
         eeol;  {clean-up   gws}
      end;
end;

function viewitem ( ptr : pointer ) : pointer;
{display and edit an item then return pointer to next item}
var     st      : string;
        ch      : char;
        obj     : intstr;
begin
   obj := '';  {got to initialize those strings!  gws}
   clear;
   write ( 'Command --> <space> to continue, ^D(elete,' );
   write ( ' Change --> N(ame, A(mount' );
   if not single then write ( ', W(hose' );
   with ptr^ do
      begin
         viewitem := nptr;
         gotoxy ( 0, 4 );
         write ( 'line number ' );
         if ln <= maxtline then write ( ln:2 )
           else if ln <= maxaline then write ( ln - minaline + 1:2 )
                                  else if ln <= maxbline then
                                          write ( ln - minbline + 1:2 );
         writeln ( '  ', titles [ ln ]:40 );
         gotoxy ( 0, 6 );
         write ( name );
         eeos;
         gotoxy ( 0, 8 );
         case whose of
           h_own : write ( 'husband' );
           w_own : write ( 'wife' );
           t_own : write ( 'total' );
         end;
         gotoxy ( 0, 10 );
         pdol ( amt, obj );
         write ( 'amount ', obj:12 );
         repeat
            repeat
               gotoxy ( 77, 0 );
               read ( keyboard, ch );
               if ch = chr ( 4 ) then
                  begin
                     if tl then    {if pointer was from tlines [ ln ]}
                        tlines [ ln ].iptr := nptr
                        else lastptr^.nptr := nptr;
                     exit ( viewitem );
                  end;
            until ( ch in [ 'N','n','W','w','A','a',' ' ] ) and
                  ( not eoln ( keyboard ) );
            if ch in [ 'N','n','W','w','A','a' ] then
               begin   {change a value in item}
                  with ptr^ do
                     begin
                        case ch of
                          'N','n' : namer ( 'name', ptr^.name, 10 );
                          'A','a' : begin
                                       gotoxy ( 0, 10 );
                                       readdol ( 9, amt );
                                       writeln;
                                    end;
                          'W','w' : who ( ptr );
                        end;
                        gotoxy ( 77, 0 );
                     end;
                  end;
         until ch = ' ';
      end;
   tl := false;  { parent of pointer is no longer tlines [ ln ]}
   lastptr := ptr;
end;

begin {edit_tline}
   hsum := 0;
   wsum := 0;
   with tlines [ ln ] do
      begin
         if iptr <> nil then   {if any items exist}
            begin
               tl := true;   {parent of pointer is tlines [ ln ]}
               nextptr := viewitem ( iptr );  {get first item}
               while ( nextptr <> nil ) do nextptr := viewitem ( nextptr );
            end;
         repeat    {add itmes or leave}
            clear;
            gotoxy ( 0, 2 );
            write ( 'line number ' );
            if ln <= maxtline then write ( ln:2 )
            else if ln <= maxaline then write ( ln - minaline + 1:2 )
                                   else if ln <= maxbline then
                                      write ( ln - minbline + 1:2 );
            writeln ( '  ',titles [ ln ]:40 );
            write ( 'do you want to add an item  y/n' );
            repeat
               read ( keyboard, ch );
            until ch in [ 'Y','y','N','n' ];
            eline;
            if ch in [ 'N','n' ] then
               begin
                  sums; {add the items and put in tlines [ ln ]}
                  view; {display the contents of tlines [ ln ]}
                  exit ( edit_tline );
               end;
            new ( ptr );
            if iptr = nil then iptr := ptr 
                                    {if its the first item of tlines [ln]}
               else lastptr^.nptr := ptr;
            lastptr := ptr;
            with ptr^ do   {begin actual data entry}
               begin
                  nptr := nil;
                  tlnum := ln;
                  namer ( 'name', ptr^.name, 10 );
                  gotoxy (0, 8 );
                  write ( 'enter amount  ' );
                  readdol ( 9, amt );
                  if single then whose := h_own else who ( ptr );
               end;
           until ch = 'Q';
   end;
end;

function edit_what : char;
{select a schedule to edit}
var     ch : char;
begin
   clear;
   write ( 'Edit Command --> A(schedlue A, B(schedule B, Z(form 1040,' );
   write ( ' F(iling status, Q(uit ');
   repeat
      read ( keyboard, ch );
   until ch in [ 'A','a','B','b','Z','z','F','f','Q','q' ];
   if ch in [ 'q','Q' ] then exit ( edit );
   writeln;
   edit_what := ch;
end;

procedure ed_sequent ( first, last : tline_num );
{edit elines [ first ] to tlines [ last ] unless the line is a calculated 
 line}
var     ln      : tline_num;
begin
   for ln := first to last do if not ( ln in calcset ) then
      begin
         edit_tline ( ln );
         gotoxy ( 10, 23 );
         write ( 'enter <space> to continue  <Q> to quit' );
         repeat
            read ( keyboard, ch );
         until ( ch in [ 'Q','q',chr ( 32 ) ] ) and ( not eoln ( keyboard ) );
         if ch in [ 'Q','q' ] then exit ( ed_sequent );
      end;
end;

procedure ed_individual;
{select a single line to edit}
var     ok      : boolean;
begin
   repeat
      clear;
      write ( 'enter line number to be changed  0) for help ' );
      repeat
        ok := false;
        int := readint ( 2 );
        if int = 0 then
           begin
              clear;
              case edit_char of
                'A','a' : for ln := minaline to maxaline do
                            if not ( ln in calcset ) then
                             write (( ln - minaline + 1):8,
                                      titles [ ln ]:32);
                'B','b' : for ln := minbline to maxbline do
                            if not ( ln in calcset ) then
                               write (( ln - minbline + 1):8,
                                       titles [ ln ]:32 );
                'Z','z' : for ln := 8 to maxtline do
                            if not ( ln in calcset ) then
                               write ( ln:8, titles [ ln ]:32 );
              end;
              writeln;
           end;
        case edit_char of
          'A','a' : begin
                       if ( int > 0 ) and ( int <= 41 ) then ok := true;
                       ln := int + minaline - 1;
                    end;
          'B','b' : begin
                       if ( int > 0 ) and ( int <= 8 ) then ok := true;
                       ln := int + minbline - 1;
                    end;
          'Z','z' : begin
                       if ( int > 7 ) and ( int <= maxtline ) then
                          begin
                             ok := true;
                             ln := int;
                          end;
                    end;
        end;
     until ok;  {a valid line number has been requested}
     if ( ln in calcset ) then
        begin
           clear;
           writeln ( 'line ', int, ' is a calculated value and may not',
                        ' be edited ' );
           wait;
        end
     else edit_tline ( ln );
     gotoxy ( 0, 0 );
     eeol;
     write ( '       do you want to -->  C(ontinue   Q(uit' );
     repeat
        read ( keyboard, ch );
     until ch in [ 'C','c','Q','q' ];
  until ch in [ 'Q','q' ];
end;

begin  {edit}
   repeat
      clear;
      edit_char := edit_what;   {what form should be edited}
      if edit_char in [ 'F','f' ] then edit_spec
      else
         begin
            clear;
            write ( ' Edit Command-->' );
            write ( ' S(equentially, I(ndividual, Q(uit');
            repeat
               read ( keyboard, ch );
            until ch in [ 'S','s','I','i','Q','q' ];
            case ch of
              'S','s' : begin
                           case edit_char of
                            'A','a' : ed_sequent ( minaline, maxaline );
                            'B','b' : ed_sequent ( minbline, maxbline );
                            'Z','z' : ed_sequent ( 8, maxtline );
                           end;
                        end;
              'I','i' : ed_individual;
            end;
         end;
   until ch in [ 'Q','q' ];
end; {edit}


========================================================================================
DOCUMENT :usus Folder:VOL13:taxnames.text
========================================================================================

(*$S+*)
{From "FIT - A Federal Income Tax Program in UCSD Pascal" by Edward Heyman
 appearing in the Feburary 1982 issue of Byte magazine.  Copyright 1982
 Byte Publications, Inc.  Used with permission of Byte Publications, Inc.}
 
{This program is not EXACTLY the original, it has been patched is several
 places.  Specifically, some of the data in TAXTABLE.TEXT has been changed}
 

program taxnames;  {creates file of name of tax lines}
const   maxtline        = 115;
type    t               = array [ 1.. maxtline ] of string [ 30 ];
var     titles          : t;
        tfile           : file of t;

procedure wait;
var     ch      : char;
begin
   gotoxy ( 10, 23 );
   write ( 'Enter <esc> to continue' );
   repeat
      read ( keyboard, ch );
   until ch = chr ( 27 );
end;

procedure writefile;
begin
   rewrite ( tfile, 'linenams.ftax' );
   tfile^ := titles;
   put ( tfile );
   close ( tfile, lock );
end;

procedure readfile;
var     i       : 1..maxtline;
begin
   reset ( tfile, 'linenams.ftax' );
   titles := tfile^;
   for i := 1 to maxtline do
      begin
         writeln ( titles [ i ] );
         if i mod 16 = 0 then
            begin
               wait;
               gotoxy ( 0,0 );
               write ( chr ( 27 ), chr ( 69 ) );  {clear screen for H-19}
            end;
      end;
end;

procedure init1;
begin
   titles [  1 ] := 'Filing Status                 ';
   titles [  2 ] := 'Filing Status                 ';
   titles [  3 ] := 'Filing Status                 ';
   titles [  4 ] := 'Filing Status                 ';
   titles [  5 ] := 'Filing Status                 ';
   titles [  6 ] := 'Exemptions                    ';
   titles [  7 ] := 'Exemptions                    ';
   titles [  8 ] := 'Wages, Salaries, etc          ';
   titles [  9 ] := 'Interest income               ';
   titles [ 10 ] := 'Dividends                     ';
   titles [ 11 ] := 'Income Tax Refunds            ';
   titles [ 12 ] := 'Alimony Received              ';
   titles [ 13 ] := 'Business Income               ';
   titles [ 14 ] := 'Capital Gain                  ';
   titles [ 15 ] := 'Capital Gain Dist             ';
   titles [ 16 ] := 'Supplemental Gains            ';
   titles [ 17 ] := 'Taxable Pensions & Annuities  ';
   titles [ 18 ] := 'Pensions, Rents, Roys, Partner';
   titles [ 19 ] := 'Farm Income                   ';
   titles [ 20 ] := 'Unemployment                  ';
   titles [ 21 ] := 'Other Income                  ';
   titles [ 22 ] := 'Total Income                  ';
   titles [ 23 ] := 'Moving Expense                ';
   titles [ 24 ] := 'Emp Business Expense          ';
   titles [ 25 ] := 'Payments to IRA               ';
   titles [ 26 ] := 'Payments to Keogh             ';
end;

procedure init2;
begin
   titles [ 27 ] := 'Interest Penalty              ';
   titles [ 28 ] := 'Alimony Paid                  ';
   titles [ 29 ] := 'Disability Income             ';
   titles [ 30 ] := 'Total Adjustments             ';
   titles [ 31 ] := 'Adjusted Gross Income         ';
   titles [ 32 ] := 'Adjusted Gross Income         ';
   titles [ 33 ] := 'Deductions                    ';
   titles [ 34 ] := '32 - 33                       ';
   titles [ 35 ] := 'Tax                           ';
   titles [ 36 ] := 'Additional Taxes              ';
   titles [ 37 ] := 'Total Taxes                   ';
   titles [ 38 ] := 'Political Contributions       ';
   titles [ 39 ] := 'Credit for Elderly            ';
   titles [ 40 ] := 'Child and Dependant           ';
   titles [ 41 ] := 'Investment Credit             ';
   titles [ 42 ] := 'Foreign Tax Credit            ';
   titles [ 43 ] := 'Work Incentive                ';
   titles [ 44 ] := 'Jobs Credit                   ';
   titles [ 45 ] := 'Energy Credits                ';
   titles [ 46 ] := 'Total Credits (lines 38 to 45)';
   titles [ 47 ] := 'Balance (line 37 - line 46)   ';
   titles [ 48 ] := 'Self Employment Tax           ';
   titles [ 49 ] := 'Minimum Tax                   ';
end;

procedure init3;
begin
   titles [ 50 ] := 'Tax from Prior Year Inv-Credit';
   titles [ 51 ] := 'FICA and RRTA Taxes           ';
   titles [ 52 ] := 'Tax on IRA                    ';
   titles [ 53 ] := 'Advance EIC Paymts Received   ';
   titles [ 54 ] := 'Balance (lines 47 to 53)      ';
   titles [ 55 ] := 'Total FICA Withheld           ';
   titles [ 56 ] := '1980 Estimated Tax Payments   ';
   titles [ 57 ] := 'Earned Income Credit          ';
   titles [ 58 ] := 'Amount Paid with Form 4868    ';
   titles [ 59 ] := 'Excess FICA and RRTA Tax Paid ';
   titles [ 60 ] := 'Credit for Fed Tax on SP Fuel ';
   titles [ 61 ] := 'Regulated Investment Co Credit';
   titles [ 62 ] := 'Total (line 55 to 61)         ';
   titles [ 63 ] := 'Overpaid                      ';
   titles [ 64 ] := 'To be Refunded to You         ';
   titles [ 65 ] := 'Applied to Est 1981 Tax       ';
   titles [ 66 ] := 'Balance Due                   ';
end;

procedure init4;
begin
   titles [ 67 ] := '50 % of Medical Ins Prems     ';
   titles [ 68 ] := 'Medicine and Drugs            ';
   titles [ 69 ] := '1% of line 31 Form 1040       ';
   titles [ 70 ] := 'Sub Total line 3 - line 2     ';
   titles [ 71 ] := 'Balance of Ins Prems          ';
   titles [ 72 ] := 'Other Medical and Dental      ';
   titles [ 73 ] := 'Total (lines 4 to 6)          ';
   titles [ 74 ] := '3% of line 31 Form 1040       ';
   titles [ 75 ] := 'Line 7 - Line 8               ';
   titles [ 76 ] := 'Total Medical and Dental      ';
   titles [ 77 ] := 'State & Local Income Tax      ';
   titles [ 78 ] := 'Real Estate Taxes             ';
   titles [ 79 ] := 'General Sales Taxes           ';
   titles [ 80 ] := 'Personal Property Taxes       ';
   titles [ 81 ] := 'Other Taxes                   ';
   titles [ 82 ] := 'Total Taxes lines 11 to 15    ';
   titles [ 83 ] := 'Home Mortgage Interest        ';
   titles [ 84 ] := 'Credit & Charge Cards         ';
   titles [ 85 ] := 'Other Interest                ';
   titles [ 86 ] := 'Total Int (lines 16 to 19)    ';
end;

procedure init5;
begin
   titles [ 87 ] := 'Cash Contributions            ';
   titles [ 88 ] := 'Other Cash Contributions      ';
   titles [ 89 ] := 'Carryover                     ';
   titles [ 90 ] := 'Total Contributions           ';
   titles [ 91 ] := 'Loss Before Insurance         ';
   titles [ 92 ] := 'Insurance Reinbursement       ';
   titles [ 93 ] := 'Line 25 - Line 26             ';
   titles [ 94 ] := '$100 or Line 27               ';
   titles [ 95 ] := 'Total Casualty or Theft       ';
   titles [ 96 ] := 'Union Dues                    ';
   titles [ 97 ] := 'Other Misc Deductions         ';
   titles [ 98 ] := 'Total Miscellaneous           ';
   titles [ 99 ] := 'Total Medical & Dental        ';
   titles [100 ] := 'Total Taxes                   ';
   titles [101 ] := 'Total Interest                ';
   titles [102 ] := 'Total Contributions           ';
   titles [103 ] := 'Total Casualty or Theft       ';
   titles [104 ] := 'Total Miscellaneous           ';
   titles [105 ] := 'Sum (lines 33 to 38)          ';
   titles [106 ] := 'Adjustment                    ';
end;

procedure init6;
begin
   titles [107 ] := 'Line 39 - Line 40             ';
   titles [108 ] := 'Interest Income               ';
   titles [109 ] := 'Total Interest Income         ';
   titles [110 ] := 'Dividend Income               ';
   titles [111 ] := 'Total Dividend Income         ';
   titles [112 ] := 'Capital Gain Distribution     ';
   titles [113 ] := 'Nontaxable Distributions      ';
   titles [114 ] := 'Total (lines 5 & 6)           ';
   titles [115 ] := 'Dividends Berore Exclusions   ';
end;

begin
   init1;
   init2;
   init3;
   init4;
   init5;
   init6;
   writefile;
   wait;
   readfile;
end.


========================================================================================
DOCUMENT :usus Folder:VOL13:taxprint.text
========================================================================================

{From "FIT - A Federal Income Tax Program in UCSD Pascal" by Edward Heyman
 appearing in the Feburary 1982 issue of Byte magazine.  Copyright 1982
 Byte Publications, Inc.  Used with permission of Byte Publications, Inc.}
 
{This program is not EXACTLY the original, it has been patched is several
 places.  Specifically, some of the data in TAXTABLE.TEXT has been changed}
 

segment procedure printer;
var     detail  : boolean;
        lines   : integer;
        print_what,
        ch1     : char;

procedure print_date;
var     cmonth  : string [ 3 ];
begin
   case month of
      1 : cmonth := 'Jan';
      2 : cmonth := 'Feb';
      3 : cmonth := 'Mar';
      4 : cmonth := 'Apr';
      5 : cmonth := 'May';
      6 : cmonth := 'Jun';
      7 : cmonth := 'Jul';
      8 : cmonth := 'Aug';
      9 : cmonth := 'Sep';
     10 : cmonth := 'Oct';
     11 : cmonth := 'Nov';
     12 : cmonth := 'Dec';
   end;
   writeln ( p, day:2, ' ', cmonth, ' ', '19', year:2 );
end;
      
procedure heading ( title : filename );
begin
   line ( '*', 79 );
   writeln ( p );
   write ( p, tlines [ 6 ].name );
   write ( p, 'Tax year ':( 44 - length ( tlines [ 6 ].name )));
   writeln ( p, tlines [ 7 ].taxyear:4, title:29 );
   write ( p, 'Filing status ' );
   case tlines [ 7 ].fs of
     1 : write ( p, '1' );
     2 : write ( p, '2' );
     3 : write ( p, '3' );
     4 : write ( p, '4' );
     5 : write ( p, '5' );
   end;
   write ( p, '             exemptions ' );
   write ( p, tlines [ 7 ].exem, ' ':27 );
   print_date;
   line ( '*', 79 );
   writeln ( p );
   if fstat in [ 2, 3 ] then
      writeln ( p, ' ':40, ' Husband ':12, '   Wife   ':12, '  Total   ':12 )
   else writeln ( p );
   lines := 4;
end;

procedure detail_print ( first, last : tline_num; title : filename );
{prints an item by tax line}
var     ln      : tline_num;
        obj,
        hdol,
        wdol,
        tdol    : string [ 10 ];
        nextptr : pointer;

begin
   obj := '';
   if screen then clear;
   heading ( title );
   for ln := first to last do
      if tlines [ ln ].iptr <> nil then
         begin   {do not bother unless line has an item}
            case print_what of
              'A','a' : write ( p, ( ln - minaline + 1 ):2 );
              'B','b' : write ( p, ( ln - minbline + 1 ):2 );
              'Z','z' : write ( p, ( ln ):2 );
            end;
            writeln ( p, ' ', titles [ ln ] );  {print name of line}
            lines := succ ( lines );            {increment the line counter}
            nextptr := tlines [ ln ].iptr;      {first pointer}
            while nextptr <> nil do             {until the last item}
               begin
                  with nextptr^ do
                     begin
                        write ( p, name );
                        pdol ( amt, obj );      {convert long int to string}
                        case whose of
                          h_own : begin
                                     write ( p, 'Hus':( 25 - length ( name )));
                                     writeln ( p, obj:25 );
                                  end;
                          w_own : begin
                                     write ( p, 'Wif':( 25 - length ( name )));
                                     writeln ( p, obj:38 );
                                  end;
                          t_own : begin
                                     write ( p, 'Tot':( 25 - length ( name )));
                                     writeln ( p, obj:51 );
                                  end;
                        end;
                        lines := succ ( lines );
                        nextptr := nptr;
                     end;
               end;
      with tlines [ ln ] do
         begin
            pdol ( hus, hdol );         
            pdol ( wif, wdol );
            pdol ( tot, tdol );
            if fstat in [ 2, 3 ] then
               writeln ( p, 'Total', hdol:45, wdol:13, tdol:13 )
            else writeln ( p, 'Total', ' ':58, tdol:13 );
            writeln ( p );
            lines := succ ( lines );
         end;
      if screen then
         if ( 16 - lines ) < 0 then
            begin
               wait;
               clear;
               lines := 0;
            end
         else if ( 54 - lines ) < 0 then
            begin
               write ( p, chr ( 12 ) );
               heading ( title );
            end;
      end;
   if screen then wait;
   write ( p, chr ( 12 ));
end;


procedure print ( first, last : tline_num; title : filename );
const   s1      = '  ----------  ----------  ----------';

var     ln      : tline_num;
        hdol,
        wdol,
        tdol    : string [ 10 ];
begin
   hdol := '';
   wdol := '';
   tdol := '';
   if screen then clear;
   heading ( title );
   for ln := first to last do
      with tlines [ln ] do
         begin
            pdol ( hus, hdol );
            pdol ( wif, wdol );
            pdol ( tot, tdol );
            case print_what of
               'A','a' : write ( p, ( ln - minaline + 1 ):2 );
               'B','b' : write ( p, ( ln - minbline + 1 ):2 );
               'Z','z' : write ( p, ( ln ):2 );
            end;
            writeln ( p, '  ', titles [ ln ], ' ':5, hdol:12, wdol:12, 
                      tdol:12);
            if ln in dlineset then writeln ( p, s1:79 );
            if ln in slineset then 
               begin
                  line ( '=', 79 );
                  writeln ( p );
               end;
            if screen and ( ln in spageset ) then
               begin
                  wait;
                  clear;
               end;
            if ( not screen ) and ( ln = 37 ) then
               begin
                  write ( p, chr ( 12 ) );
                  heading ( title );
               end;
         end;
      if print_what in [ 'Z', 'z' ] then
         begin
            write ( p, '  Maximum Tax Bracket', ' ':18 );
            writeln ( p, max_tax [ h_own ]:12, max_tax [ w_own ]:12,
                         max_tax [ t_own ]:12 );
         end;
      if screen then wait;
      write ( p, chr ( 12 ) );
end;


begin  {printer}
   {a separate line is printed after a line in slineset}
   slineset := [ 22, 30, 37, 47, 54, 62, 66, 76, 82, 86, 90, 95, 98,
                 107, 109, 111 ];
   {a dashed line is printed after a line slineset}
   dlineset := [ 21, 29, 33, 36, 45, 46, 53, 61, 69, 72, 81, 85, 89,
                 92, 94, 97, 106, 113 ];
   {last lines in a screen page are in spageset}
   spageset := [ 22, 37, 54, 76, 90, 98 ];
   clear;
   mem;
   repeat
      detail := false;   {contro to print deatil}
      clear;
      write ( 'Printer Command --> A(sched A  B(sched B  Z(form 1040 ' );
      write ( ' #(for detail   Q(uit ' );
      repeat
         read ( keyboard, print_what );
         if print_what = '#' then detail := true;
      until print_what in [ 'A','a','B','b','Z','z','Q','q' ];
      if not ( print_what in [ 'Q','q' ] ) then
         begin
            writeln;
            write ( 'Do you want to output to --> P(rinter  S(creen  ' );
            repeat
               read ( keyboard, ch1 );
            until ch1 in [ 'P','p','S','s' ];
            close ( p );
            if ch1 in [ 'S','s' ] then
               begin
                  screen := true;
                  rewrite ( p, 'console:' );
               end
            else 
               begin
                  screen := false;
                  rewrite ( p , 'printer:' );
               end;
            if detail then
               case print_what of
                 'A','a' : detail_print ( 67, 107, 'Schedule A' );
                 'B','b' : detail_print ( 108, 115, 'Schedule B' );
                 'Z','z' : detail_print ( 8, 66, 'Form 1040' );
               end
            else case print_what of
                   'A','a' : print ( 67, 107, 'Schedule A' );
                   'B','b' : print ( 108, 115, 'Schedule B' );
                   'Z','z' : print ( 8, 66, 'Form 1040' );
                 end;
        end;
   close ( p );
   until print_what in [ 'Q','q' ];
end;  {printer}
               

========================================================================================
DOCUMENT :usus Folder:VOL13:taxrw.text
========================================================================================

{From "FIT - A Federal Income Tax Program in UCSD Pascal" by Edward Heyman
 appearing in the Feburary 1982 issue of Byte magazine.  Copyright 1982
 Byte Publications, Inc.  Used with permission of Byte Publications, Inc.}
 
{This program is not EXACTLY the original, it has been patched is several
 places.  Specifically, some of the data in TAXTABLE.TEXT has been changed}
 

segment procedure rw ( ch : char );
{reads or writes Files of tlines and items}
var     fl      : file of tls;
        fi      : file of item;

function lookup ( fn : string ) : boolean;
{checks to see if file is on disk}
var     ior     : 0..15;
begin
   {$I-}
   reset ( p, fn );
   ior := ioresult;
   close ( p );
   {$I+}
   if ior = 0 then lookup := true 
   else 
      begin
          lookup := false;
          if ior <> 10 then writeln ( 'ioresult for file ', fn, ' is ',
                                        ior );
      end;
end;

procedure reader;       {reads files of tlines and items}
const   fn1     = '.line';
        fn2     = '.item';
var     st      : string;
        fn      : filename;

procedure read_tlines ( fn : filename );
var     i       : tline_num;
begin
   if not lookup ( fn ) then
      begin
         clear;
         gotoxy ( 12, 20 );
         writeln ( 'File ', fn, ' not found' );
         wait;
         exit ( read_tlines );
      end;
   reset ( fl, fn );
   tlines := fl^;
   close ( fl );
   for i := 8 to maxline do tlines [ i ].iptr := nil;
   writeln ( 'File ', fn, ' read. ');
end;

procedure read_items ( fn : filename );
var     ch      : char;
        pt,
        newpt   : pointer;
begin
   if not lookup ( fn ) then
      begin
         clear;
         gotoxy ( 10, 10 );
         write ( 'File ', fn, ' not found.' );
         wait;
         exit ( read_items );
      end;
   reset ( fi, fn );
   write ( 'Reading file ', fn );
   while not eof ( fi ) do
      begin
         new ( newpt );
         newpt^ := fi^;
         newpt^.nptr := nil;
         if ( tlines [ newpt^.tlnum ].iptr = nil ) then
            tlines [ newpt^.tlnum ].iptr := newpt
         else 
            begin
               pt := tlines [ newpt^.tlnum ].iptr;
               while ( pt^.nptr <> nil ) do pt := pt^.nptr;
               pt^.nptr := newpt;
            end;
         get ( fi );
         write ( '.' );
      end;
   close ( fi );
end;

begin {reader}
   namer ( 'File to be read ', st, 8 );
   fn := concat ( st, fn1 );
   read_tline ( fn );
   fn := concat ( st, fn2 );
   read_items ( fn );
   wait;
end; { reader }

procedure writer;   {writes file of tlines and items}
const   fn1     = '.line';
        fn2     = '.item';
var     st      : string;
        fn      : filename;

procedure write_tlines ( fn : filename );
var     ch      : char;
        ln      : tline_num;
begin
   if lookup ( fn ) then
      begin
         clear;
         gotoxy ( 0 , 20 );
         writeln ( 'Do you wand to remove the old file y/n ' );
         repeat 
            read ( keyboard, ch );
         until ch in [ 'Y','y','N','n' ];
         if ch in [ 'N','n' ] then exit ( writer );
      end;
   rewrite ( fl, fn );
   fl^ := tlines;
   put ( fl );
   close ( fl, lock );
end;

procedure write_items ( fn : filename );
var     ch      : char;
        pt      : pointer;
        ln      : tline_num;
begin
   rewrite ( fi, fn );
   for ln := 8 to maxline do
      if not ( ln in calcset ) then
         begin
            if tlines [ ln ].iptr <> nil then
               begin
                  pt := tlines [ ln ].iptr;
                  while ( pt <> nil ) do
                     begin
                        fi^ := pt^;
                        put ( fi );
                        pt := pt^.nptr
                     end;
               end;
         end;
    close ( fi, lock );
end;

begin  {writer}
   namer ( 'File to be written ', st, 8 );
   fn := concat ( st, fn1 );
   write_tline ( fn );
   fn := concat ( st, fn2 );
   write_items ( fn );
end; {writer}

begin  {rw}
   case ch of
      'R' : reader;
      'W' : writer;
   end;
end; {rw}


========================================================================================
DOCUMENT :usus Folder:VOL13:taxstart.text
========================================================================================

{From "FIT - A Federal Income Tax Program in UCSD Pascal" by Edward Heyman
 appearing in the Feburary 1982 issue of Byte magazine.  Copyright 1982
 Byte Publications, Inc.  Used with permission of Byte Publications, Inc.}
 
{This program is not EXACTLY the original, it has been patched is several
 places.  Specifically, some of the data in TAXTABLE.TEXT has been changed}
 

segment procedure start;  {sets up the variables}

procedure initialize;
{inserts nul values in tlines}
var i   : 1..maxline;
    empty : tline;
begin
   max_tax [ h_own ] := 0;
   max_tax [ w_own ] := 0;
   max_tax [ t_own ] := 0;
   with empty do 
      begin
         iptr := nil;
         hus := 0;
         wif := 0;
         tot := 0;
      end;
   for i := 8 to maxline do
      begin 
         tlines [ i ] := empty;
         tlines [ i ].tag := 1;
      end;
   with tlines [ 7 ] do
      begin
         d1 := 1;
         d2 := 1;
         d3 := 80;
         taxyear := ' ';
         fs := 0;
         exem := 0;
      end;
   with tlines [ 6 ] do name := ' ';
end;

procedure readfactors;
{reads the tax factor file into the array taxray}
var     tfile : file of factorarray;
        ttlable : tax_table;
begin
  reset ( tfile, 'factors.ftax' );
  for ttable := x to z do
     begin
        taxray [ ttable ] := tfile^;
        write ( '.' );
        get ( tfile );
     end;
  close ( tfile );
end;

procedure readnames;
{reads the line names into the array titles}
type    t       = array  [ 1..maxline ] of string [ 30 ];
var     tnames  : file of t;
begin
   reset ( tnames, 'linenams.ftax' );
   titles := tnames^;
end;

procedure getdate;
{gets the system date from drive 4}
var     dummy   : packed array [ 1..22 ] of char;
        high, low : integer;
begin
   unitread ( 4, dummy, 24 ,2 );
   high := ord ( dummy [ 22 ] );
   low := ord ( dummy [ 21 ] );
   day := ( high mod 2 ) * 16 + ( low div 16 );
   month := low mod 16;
   year := high div 2;
end;

begin
   getdate;
   {the following set contains line numbers of lines requiring calculation}
   calcset := [ 9,10,22,20,31,32,33,34,35,37,46,47,54,62..66,69,70,
                73..76,82,86,88,90,93..95,98..107,109,111,114,115];
   single := true;  {needs a value to start}
   screen := true;  {most times it is}
   initialize;
   readfactors;
   readnames;
end;
   

========================================================================================
DOCUMENT :usus Folder:VOL13:taxtable.text
========================================================================================

(*$S+*)
{From "FIT - A Federal Income Tax Program in UCSD Pascal" by Edward Heyman
 appearing in the Feburary 1982 issue of Byte magazine.  Copyright 1982
 Byte Publications, Inc.  Used with permission of Byte Publications, Inc.}
 
{This program is not EXACTLY the original, it has been patched is several
 places.  Specifically, some of the data in TAXTABLE.TEXT has been changed}
 

program taxtable;
type    tfactors        = ( lower, upper, base, per );
        factorray       = array [ 1..16, tfactors ] of integer [ 9 ];
        t               = array [ 1..4 ] of factorray;
var     ty              : t;
        tfile           : file of t;

procedure writefile;
begin
   rewrite ( tfile, 'factors.ftax' );
   tfile^ := ty;
   put ( tfile );
   close ( tfile, lock );
end;

procedure init1a;
{schedule X single tax payers lower bracket limit}
begin
    ty [ 1,  1, lower ] := 230000;
    ty [ 1,  2, lower ] := 340000;
    ty [ 1,  3, lower ] := 440000;
    ty [ 1,  4, lower ] := 650000;
    ty [ 1,  5, lower ] := 850000;
    ty [ 1,  6, lower ] := 1080000;
    ty [ 1,  7, lower ] := 1290000;
    ty [ 1,  8, lower ] := 1500000;
    ty [ 1,  9, lower ] := 1820000;
    ty [ 1, 10, lower ] := 2350000;
    ty [ 1, 11, lower ] := 2880000;
    ty [ 1, 12, lower ] := 3410000;
    ty [ 1, 13, lower ] := 4150000;
    ty [ 1, 14, lower ] := 5530000;
    ty [ 1, 15, lower ] := 8180000;
    ty [ 1, 16, lower ] := 10830000;
 end;
 
 procedure init1b;
 {schedule X single taxpayers upper limit bracket}
 begin
    ty [ 1,  1, upper ] := 340000;
    ty [ 1,  2, upper ] := 440000;
    ty [ 1,  3, upper ] := 650000;
    ty [ 1,  4, upper ] := 850000;
    ty [ 1,  5, upper ] := 1080000;
    ty [ 1,  6, upper ] := 1290000;
    ty [ 1,  7, upper ] := 1500000;
    ty [ 1,  8, upper ] := 1820000;
    ty [ 1,  9, upper ] := 2350000;
    ty [ 1, 10, upper ] := 2880000;
    ty [ 1, 11, upper ] := 3410000;
    ty [ 1, 12, upper ] := 4150000;
    ty [ 1, 13, upper ] := 5530000;
    ty [ 1, 14, upper ] := 8180000;
    ty [ 1, 15, upper ] := 10830000;
    ty [ 1, 16, upper ] := 999999999;
 end;

procedure init1c;
{schedule X single taxpayers base tax}
begin
    ty [ 1,  1, base ] := 00;
    ty [ 1,  2, base ] := 15400; 
    ty [ 1,  3, base ] := 31400; 
    ty [ 1,  4, base ] := 62900; 
    ty [ 1,  5, base ] := 107200; 
    ty [ 1,  6, base ] := 155500; 
    ty [ 1,  7, base ] := 205900; 
    ty [ 1,  8, base ] := 260500; 
    ty [ 1,  9, base ] := 356500; 
    ty [ 1, 10, base ] := 536700; 
    ty [ 1, 11, base ] := 743400; 
    ty [ 1, 12, base ] := 976600; 
    ty [ 1, 13, base ] := 1339200;
    ty [ 1, 14, base ] := 2098200;
    ty [ 1, 15, base ] := 3767700; 
    ty [ 1, 16, base ] := 5569700;  
 end;
    
 
procedure init1d;
{schedule X single taxpayers tax rate}
begin
    ty [ 1,  1, per ] := 14;
    ty [ 1,  2, per ] := 16;    
    ty [ 1,  3, per ] := 18;    
    ty [ 1,  4, per ] := 19;    
    ty [ 1,  5, per ] := 21;     
    ty [ 1,  6, per ] := 24;     
    ty [ 1,  7, per ] := 26;     
    ty [ 1,  8, per ] := 30;     
    ty [ 1,  9, per ] := 34;     
    ty [ 1, 10, per ] := 39;     
    ty [ 1, 11, per ] := 44;     
    ty [ 1, 12, per ] := 49;     
    ty [ 1, 13, per ] := 55;     
    ty [ 1, 14, per ] := 63;     
    ty [ 1, 15, per ] := 68; 
    ty [ 1, 16, per ] := 70;       
 end;
 
 procedure init2a;
 {schedule Y married taxpayers lower bracket limit}
 begin
    ty [ 2,  1, lower ] := 340000;
    ty [ 2,  2, lower ] := 550000;
    ty [ 2,  3, lower ] := 760000;
    ty [ 2,  4, lower ] := 1190000;
    ty [ 2,  5, lower ] := 1600000;
    ty [ 2,  6, lower ] := 2020000;
    ty [ 2,  7, lower ] := 2460000;
    ty [ 2,  8, lower ] := 2990000;
    ty [ 2,  9, lower ] := 3520000;
    ty [ 2, 10, lower ] := 4580000;
    ty [ 2, 11, lower ] := 6000000;
    ty [ 2, 12, lower ] := 8560000;
    ty [ 2, 13, lower ] := 10940000;
    ty [ 2, 14, lower ] := 16240000;
    ty [ 2, 15, lower ] := 21540000;
    ty [ 2, 16, lower ] := 99999999;
 end;
 
 procedure init2b;
 begin
    ty [ 2,  1, upper ] := 550000;
    ty [ 2,  2, upper ] := 760000;
    ty [ 2,  3, upper ] := 1190000;
    ty [ 2,  4, upper ] := 1600000;
    ty [ 2,  5, upper ] := 2020000;
    ty [ 2,  6, upper ] := 2460000;
    ty [ 2,  7, upper ] := 2990000;
    ty [ 2,  8, upper ] := 3520000;
    ty [ 2,  9, upper ] := 4580000;
    ty [ 2, 10, upper ] := 6000000;
    ty [ 2, 11, upper ] := 8560000;
    ty [ 2, 12, upper ] := 10940000;
    ty [ 2, 13, upper ] := 16240000;
    ty [ 2, 14, upper ] := 21540000;
    ty [ 2, 15, upper ] := 999999999;
    ty [ 2, 16, upper ] := 999999999;
 end;
 
 procedure init2c;
 begin
    ty [ 2,  1, base ] := 00;
    ty [ 2,  2, base ] := 29400; 
    ty [ 2,  3, base ] := 63000;  
    ty [ 2,  4, base ] := 140040; 
    ty [ 2,  5, base ] := 226500; 
    ty [ 2,  6, base ] := 327300; 
    ty [ 2,  7, base ] := 450500; 
    ty [ 2,  8, base ] := 620100; 
    ty [ 2,  9, base ] := 816200; 
    ty [ 2, 10, base ] := 1272000;
    ty [ 2, 11, base ] := 1967800;
    ty [ 2, 12, base ] := 3350200; 
    ty [ 2, 13, base ] := 4754400; 
    ty [ 2, 14, base ] := 8146400; 
    ty [ 2, 15, base ] := 11750400; 
    ty [ 2, 16, base ] := 11750400; 
 end;
    
procedure init2d;
begin
    ty [ 2,  1, per ] := 14;
    ty [ 2,  2, per ] := 16; 
    ty [ 2,  3, per ] := 18; 
    ty [ 2,  4, per ] := 21; 
    ty [ 2,  5, per ] := 24; 
    ty [ 2,  6, per ] := 28; 
    ty [ 2,  7, per ] := 32; 
    ty [ 2,  8, per ] := 37; 
    ty [ 2,  9, per ] := 43; 
    ty [ 2, 10, per ] := 49;
    ty [ 2, 11, per ] := 54;
    ty [ 2, 12, per ] := 59; 
    ty [ 2, 13, per ] := 64; 
    ty [ 2, 14, per ] := 68; 
    ty [ 2, 15, per ] := 70; 
    ty [ 2, 16, per ] := 70; 
 end;
 
procedure init3a;
{schedule YS married taxpayers filing separately}
begin
    ty [ 3,  1, lower ] := 170000;
    ty [ 3,  2, lower ] := 275000;
    ty [ 3,  3, lower ] := 380000;
    ty [ 3,  4, lower ] := 595000; 
    ty [ 3,  5, lower ] := 800000; 
    ty [ 3,  6, lower ] := 1010000;
    ty [ 3,  7, lower ] := 1230000;
    ty [ 3,  8, lower ] := 1495000;
    ty [ 3,  9, lower ] := 1760000;
    ty [ 3, 10, lower ] := 2290000;
    ty [ 3, 11, lower ] := 3000000;
    ty [ 3, 12, lower ] := 4280000;
    ty [ 3, 13, lower ] := 5470000; 
    ty [ 3, 14, lower ] := 8120000; 
    ty [ 3, 15, lower ] := 10770000;
    ty [ 3, 16, lower ] := 99999999;
 end;

procedure init3b;
begin
    ty [ 3,  1, upper ] := 275000;
    ty [ 3,  2, upper ] := 380000;
    ty [ 3,  3, upper ] := 595000; 
    ty [ 3,  4, upper ] := 800000; 
    ty [ 3,  5, upper ] := 1010000;
    ty [ 3,  6, upper ] := 1230000;
    ty [ 3,  7, upper ] := 1490000;
    ty [ 3,  8, upper ] := 1760000;
    ty [ 3,  9, upper ] := 2290000;
    ty [ 3, 10, upper ] := 3000000;
    ty [ 3, 11, upper ] := 4280000;
    ty [ 3, 12, upper ] := 5470000; 
    ty [ 3, 13, upper ] := 8120000; 
    ty [ 3, 14, upper ] := 10770000;
    ty [ 3, 15, upper ] := 99999999;
    ty [ 3, 16, upper ] := 99999999;
 end;

procedure init3c;
begin
    ty [ 3,  1, base ] := 00;
    ty [ 3,  2, base ] := 14700; 
    ty [ 3,  3, base ] := 31500;  
    ty [ 3,  4, base ] := 70200;  
    ty [ 3,  5, base ] := 113250; 
    ty [ 3,  6, base ] := 163650; 
    ty [ 3,  7, base ] := 225250; 
    ty [ 3,  8, base ] := 310050; 
    ty [ 3,  9, base ] := 408100; 
    ty [ 3, 10, base ] := 636000; 
    ty [ 3, 11, base ] := 983900; 
    ty [ 3, 12, base ] := 1675100; 
    ty [ 3, 13, base ] := 2377200; 
    ty [ 3, 14, base ] := 4073200; 
    ty [ 3, 15, base ] := 5875200;  
    ty [ 3, 16, base ] := 5875200;  
 end;

procedure init3d;
begin
    ty [ 3,  1, per ] := 14;
    ty [ 3,  2, per ] := 16; 
    ty [ 3,  3, per ] := 18; 
    ty [ 3,  4, per ] := 21; 
    ty [ 3,  5, per ] := 24; 
    ty [ 3,  6, per ] := 28; 
    ty [ 3,  7, per ] := 32; 
    ty [ 3,  8, per ] := 37; 
    ty [ 3,  9, per ] := 43; 
    ty [ 3, 10, per ] := 49;
    ty [ 3, 11, per ] := 54;
    ty [ 3, 12, per ] := 59; 
    ty [ 3, 13, per ] := 64; 
    ty [ 3, 14, per ] := 68; 
    ty [ 3, 15, per ] := 70; 
    ty [ 3, 16, per ] := 70; 
 end;

procedure init4a;
{schedule Z head of household}
begin
    ty [ 4,  1, lower ] := 230000;
    ty [ 4,  2, lower ] := 440000;
    ty [ 4,  3, lower ] := 650000;
    ty [ 4,  4, lower ] := 870000;  
    ty [ 4,  5, lower ] := 1180000; 
    ty [ 4,  6, lower ] := 1500000;
    ty [ 4,  7, lower ] := 1820000;
    ty [ 4,  8, lower ] := 2350000;
    ty [ 4,  9, lower ] := 2880000;
    ty [ 4, 10, lower ] := 3410000;
    ty [ 4, 11, lower ] := 4470000;
    ty [ 4, 12, lower ] := 6060000;
    ty [ 4, 13, lower ] := 8180000; 
    ty [ 4, 14, lower ] := 10800000;
    ty [ 4, 15, lower ] := 16130000;
    ty [ 4, 16, lower ] := 99999999;
 end;

procedure init4b;
begin
    ty [ 4,  1, upper ] := 440000;
    ty [ 4,  2, upper ] := 650000;
    ty [ 4,  3, upper ] := 870000;
    ty [ 4,  4, upper ] := 1180000; 
    ty [ 4,  5, upper ] := 1500000; 
    ty [ 4,  6, upper ] := 1820000;
    ty [ 4,  7, upper ] := 2350000;
    ty [ 4,  8, upper ] := 2880000;
    ty [ 4,  9, upper ] := 3410000;
    ty [ 4, 10, upper ] := 4470000;
    ty [ 4, 11, upper ] := 6060000;
    ty [ 4, 12, upper ] := 8180000;
    ty [ 4, 13, upper ] := 10830000;
    ty [ 4, 14, upper ] := 16130000;
    ty [ 4, 15, upper ] := 99999999;
    ty [ 4, 16, upper ] := 99999999;
 end;

procedure init4c;
begin
    ty [ 4,  1, base ] := 00;
    ty [ 4,  2, base ] := 29400; 
    ty [ 4,  3, base ] := 63000; 
    ty [ 4,  4, base ] := 102600; 
    ty [ 4,  5, base ] := 170800; 
    ty [ 4,  6, base ] := 247600; 
    ty [ 4,  7, base ] := 330800; 
    ty [ 4,  8, base ] := 495100; 
    ty [ 4,  9, base ] := 685900; 
    ty [ 4, 10, base ] := 908500; 
    ty [ 4, 11, base ] := 1396100;
    ty [ 4, 12, base ] := 2254700; 
    ty [ 4, 13, base ] := 3505500; 
    ty [ 4, 14, base ] := 5175000; 
    ty [ 4, 15, base ] := 8779000;  
    ty [ 4, 16, base ] := 9999999; 
 end;

procedure init4d;
begin
    ty [ 4,  1, per ] := 14;
    ty [ 4,  2, per ] := 16; 
    ty [ 4,  3, per ] := 18; 
    ty [ 4,  4, per ] := 22; 
    ty [ 4,  5, per ] := 24; 
    ty [ 4,  6, per ] := 26; 
    ty [ 4,  7, per ] := 31; 
    ty [ 4,  8, per ] := 36; 
    ty [ 4,  9, per ] := 43; 
    ty [ 4, 10, per ] := 46;
    ty [ 4, 11, per ] := 54;
    ty [ 4, 12, per ] := 59; 
    ty [ 4, 13, per ] := 63; 
    ty [ 4, 14, per ] := 68; 
    ty [ 4, 15, per ] := 70; 
    ty [ 4, 16, per ] := 70; 
 end;

begin
   init1a;
   init1b;
   init1c;
   init1d;
   init2a;
   init2b;
   init2c;
   init2d;
   init3a;
   init3b;
   init3c;
   init3d;
   init4a;
   init4b;
   init4c;
   init4d;
   writefile;
end.


========================================================================================
DOCUMENT :usus Folder:VOL13:tech_doc.text
========================================================================================


.comment                !---------------------------------!   
.comment                !                                 !
.comment                !        RUNON documentation      !
.comment                !       Technical description     ! 
.comment                !                                 !
.comment                !---------------------------------!


.title " Technical Description " .page .center " ^&Data Structures\& "  

.noautopara .skip 1
The following are the main data structures of the program:
.skip 1
There are three main storage areas for text. These are known as the
<&input, <&internal, and <&output buffers:
 
.skip 2 .center " ^^input buffer\^ "
 
This is used to store a line of up to 132 characters from the
input file.  The .ST index points at the first character of
scannable text.  The .EN index points at the last character.
 
.skip 2 .center " ^^internal buffer\^ "
 
This contains the scanned version of the input buffer.  All of
the special commands have been processed, and are no longer  
present in the text.  The text is represented as an array of
records, each of which contains: a character; the 'visible length'
of the character, in spaces; a set of attributes (characteristics)
the character possesses; and a 'malleability' value that says
whether or not the character, if it is a space, can be expanded
during justification.  Thus, malleability really has meaning only
for space characters.  When in filling mode, the .ST index always
points at one past the end of the word just placed into the output buffer.
The .EN index points at the last record of the buffer.  <^runon
uses the condition (.ST > .EN) to signify the emptiness of
the buffer.  This is also true of the output buffer.
 
.skip 2 .center " ^^output buffer\^ "
 
This buffer is of the same type as the internal buffer. When <^runon is in non-
filling mode, they are identical. In filling and justification modes, however,
the output buffer contains a justifiable copy of the internal buffer, with all 
extra blanks removed. <^runon places as many words as it can into the output
buffer, and then, if we are in justification mode rather than filling mode,
justifies it.
 
.skip 2
The other data structures are:
 
.skip 3 .center " <^sysvars "
 
This record contains all of the global values that affect
filling. These are the values that need to be protected by the
Time-warp effect.  The fields are:
 
.skip 1 .testpage 3
<^version:
.break
'Points to' current set of values (see Time-warp section).
.skip 1
<^fill__mode:
.break
States whether in justify, fill, or nofill mode.
.skip 1
<^paging:
.break
States whether or not the output file is to be broken into
pages.
.skip 1
<^numbering:
.break
Pages numbered / unnumbered.
.skip 1
<^lm, <^rm:
.break
These are the values of the left and right margins, respectively.
They represent columns on the page.
.skip 1
<^ap__skip:
.break
Contains the number of lines to drop down when executing an automatic 
paragraph.
.skip 1
<^ap__indent:
.break
Contains the number of spaces to skip as the indent for an auto-paragraph.
.skip 1
<^paper__width:
.break
Width in columns of the paper.
.skip 1
<^paper__length:
.break
Length in lines of the paper.
.skip 1
<^chars__in__line:
.break
Number of visible characters in output buffer between
left and right margins. Used solely by <^move__word.
.skip 1
<^printable__lines:
.break
Number of usable lines on page (page length minus border size).
.skip 1
<^spacing:
.break
Standard typewriter spacing, e.g. spacing 1 yields no blank lines
on output.
 
.skip 3 .center " <^pageinfo "
 
This record contains miscellaneous information pertaining to the
page.
.skip 1
<^currline:
.break
Number of lines from bottom of header.
.skip 1
<^currpage:
.break
Current page number.
.skip 1
<^figure__set:
.break
Indicates that there is a figure to put out, and it may be
put out immediately.
.skip 1
<^figure__pending:
.break
Indicates that program is waiting to output figure at top of 
next page.
.skip 1
<^figure__size:
.break
Contains size of next figure to be output.
.skip 1
<^title:
.break
String representing current document title.
 
.skip 3 .center " ^^File Stack\^ "
 
The File__stack is a structure consisting of .PTR, which is the pointer to the
current top-of-stack, and .STACK, which is an array of ^^stack__entry\^s. Each
<^stack__entry consists of a <^.name, a <^.line, and an <^.in__buf.  The
<^.name contains the name of an included file, the <^.line contains the line
number of the file that was being processed when <^.name was included. The
<^.in__buf is a copy of the current input buffer when <^.name was included.
This allows the dot-command processor to continue with any other commands on
the line when the file was included.
 
.autopara .autoset 2 5 .page .center " ^&Time-warp Effect\& "

  When in fill mode, it is possible for an incomplete line of text to be
accumulated in the output buffer, and then to encounter a dot command, such as   
<^rightmargin, which would cause the output buffer to be changed and otherwise
wrongly processed. The problem is caused by commands which affect the line- or
paper-width after the output buffer has started to be processed.

  In order to get around this little snafu, <^runon keeps two
versions of <^sysvars, and a 'pointer' to the one currently in effect.
This 'pointer' can assume two values, <^new and
<^old.  If a new output line has been started, and a dot command
is then received, only the values in <^sysvars[new] are changed.
The version pointer is changed to point at the version containing
the pre-dot command values.  When the line is finished, the
version pointer is changed to <^new.

  The pointer to the current values is kept in <^sysvars[new].version,
so if we use this value as an 'indirect address', we can easily
reference the correct field of <^sysvars.  Using a construction
of the type
.nofill

   ^^sysvars[sysvars[new].version].\^field
 
.justify
allows you to reference field 'field' of the current values.


========================================================================================
DOCUMENT :usus Folder:VOL13:types.text
========================================================================================


{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}
{                                      }
{ TYPES.TEXT begins here               }
{                                      }
{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}
{                                      }
{ Pascal Screen Code Generator         }
{ by Lee Meador -- Copyright (c) 1981  }
{                                      }
{ Type definitions:                    }
{ Use by putting these lines in program}
{                                      }
{ TYPE                                 }
{ (*$I WBTC1:TYPES.TEXT *)             }
{                                      }
{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}

  DisplayType = (Normal,Inverse, Flash);
  
  Item = RECORD
            ItemValid       :BOOLEAN;
            ItemLabel       :STRING;
            ItemLength      :INTEGER;
            ItemX,
            ItemY           :INTEGER;
            ItemEdit        :Boolean;
            ItemDefault,
            ItemName,
            ItemType        :STRING;
            ItemDisplayType :DisplayType;
         END;
         
  Scrn = ARRAY [1..60] OF Item;
        


========================================================================================
DOCUMENT :usus Folder:VOL13:vol13.doc.text
========================================================================================

                         Volume 13 of the USUS library
                        RUNON, FIT, and some small stuff
                        
DECLARE.TEXT      22    include files of RUNON  
INITC.TEXT        26      ditto
DOPAGE.TEXT       34      ditto
READNU.TEXT       30      ditto
READLN.TEXT       16      ditto
MAIN.TEXT         22    RUNON main program.  A nice fast text formatter.
SYSGEN.TEXT        4    Compile this file to make RUNON.
RUNON_DOC.TEXT     4    RUNON documentation in un-formatted form.
INTRO_DOC.TEXT    10      an include file of the documentation.
HOWTO_DOC.TEXT    12      ditto
DOT_DOC.TEXT      26      ditto
DEFALT_DOC.TEXT    4      ditto
SPEC_DOC.TEXT     10      ditto
ERR_DOC.TEXT      12      ditto
TECH_DOC.TEXT     16      ditto
TAXNAMES.TEXT     18    Generates form line names for FIT.
TAXTABLE.TEXT     24    Generates an out-of-date tax table for FIT.  
TAXCALC.TEXT      20    an include file for FIT. The Federal Income Tax Program
TAXSTART.TEXT      8      ditto
TAXRW.TEXT        10      ditto
TAXPRINT.TEXT     16      ditto
TAXEDIT.TEXT      22      ditto
FIT.TEXT          20    The main program of FIT, hand typed by yours truly.
STARTUP.TEXT      22    A version II.0 startup program with date and prefix set
PDATE.TEXT         4      a unit for STARTUP
ERRORDATA          1    This data file should have been on Volume 8.
SCREDIT.TEXT      36    A screen form generator, simple but it works.
SCRGEN.TEXT       18    Converts output of SCREDIT to Pascal soruce
TYPES.TEXT         6      an include file for SCREDIT and SCRGEN
VOL13.DOC.TEXT     6    You're reading it.
30/30 files<listed/in-dir>, 491 blocks used, 3 unused, 3 in largest

Please transfer the text below to a disk label if you copy this volume.

    USUS Volume 13 -***- USUS Software Library
                         
   For not-for-profit use by USUS members only.
  May be used and distributed only according to 
      stated policy and the author's wishes.



This volume was assembled by George Schreyer from material collected by
the Library committee.

__________________________________________________________________________

Some notes from the editor:

                                     RUNON

     This is a fairly nice imbedded command type text formatter submitted by
Wynn Newhouse and Herb Jellinek.  It is several times faster than PROSE which  
was on volume 3 and RUNON does just as many things.  It could use a little 
improvement in the user interface, it seems to reject some legal filename 
constructs such as *FARB but after it gets going it works fine.

                                      FIT

     This is my hand typed version of FIT from a past issue of BYTE.  I never 
got my version working (I left out a critical line) until Edward Heyman sent 
me a disk with the original on it and I went through the thing line by line.  
However in the process of trying to find my one bug, I found several rough 
edges which got fixed, so instead of using the original, I used my version. I
found some problems with the data in TAXTABLE and I have changed it.  Also
be aware that the tables are for a past tax year and will have to be updated
with current information before you try to do your taxes on it!

                                    STARTUP

     I got tired of always having to go back to the F(iler to reset my prefix 
after hard crashing the system, so I wrote a startup program to do it for me.  
I also had a tendency to forget to set the date so I made the startup program 
force me to enter a date (or simply <return> if it is not to be changed).  It 
also displays a banner message to identify itself.  This program uses the II.0 
globals in a separate unit to access the system data and will not work in 
IV.0. There is IV.0 version on volume 12.

                               SCREDIT and SCRGEN

     These programs, by Lee Meador, allow you to define a screen form and then
convert the definition to Pascal source.  The documentation is sort of lacking
but after some fumbling, I got the hang of it. 

                                   ERRORDATA

     This is a data file for the SCREENUNIT which is on Volume 8.  It got 
replaced by an older version of the file by accident.

     regards - george schreyer


========================================================================================
DOCUMENT :usus Folder:VOL14:8080conv.text
========================================================================================


(************************************************************************)
(*                                                                      *)
(*      Author:         David Parrish                                   *)
(*                      Medical College of Georgia                      *)
(*                      Augusta, Georgia   30912                        *)
(*                                                                      *)
(*      Date:           June  14, 1980                                  *)
(*                                                                      *)
(*                                                                      *)
(******* This program is part of the MCG Pascal utilities library *******)
(*                                                                      *)
(*      This program takes an assembly language program written         *)
(*        with Intel 8080 opcodes and translates them to Zilog          *)
(*        Z-80 opcodes.                                                 *)
(*                                                                      *)
(*                  Limitations to the program:                         *)
(*                                                                      *)
(*      1. Opcodes and operands must be in upper-case letters.          *)
(*      2. Labels must be within columns 1 to 16.                       *)
(*      3. Opcodes and pseudo-ops must start in column 17               *)
(*           ( The second 8 column tab stop ).                          *)
(*      4. The pseudo-ops are those of the UCSD assembler.              *)
(*      5. Comments must start in column 1 or 33 (4th tab).             *)
(*      6. Everything past column 32 is ignored.                        *)
(*      7. If the Z-80 opcode and operand is longer than 16             *)
(*           columns, the characters past that limit are lost.          *)
(*      8. No multiple operations per line.                             *)
(*      9. Labels that contain 'SP' or 'PSW' will cause the line to     *)
(*           not be translated. This can be solved by changing the      *)
(*           label's name, or by using lower-case letters. (i.e. 'sp')  *)
(*                                                                      *)
(*                                                                      *)
(*      The characters '#' and '$' in the translation table represent   *)
(*   respectivily no operand with the opcode and a literally translated *)
(*   operand. The lines in the program that start with '{*}' are for    *)
(*   program tracing and debugging and may be removed to speed up       *)
(*   execution. As far as I know, there are no other limitations or     *)
(*   bugs in the program. This program was a quick-fix for a problem    *)
(*   and may be helpful for others. Hopefully, it will serve as a       *)
(*   spring-board for better translation programs. (i.e. a free format  *)
(*   parser, TDL to UCSD assembler translation, etc.)                   *)
(*                                                                      *)
(*                                                                      *)
(************************************************************************)


Program conv;
  const  tablesize  = 237;
  
  type  tblrectype  = record
                        Intlops : string[12];
                        Zopc    : string[4];
                        Zopr    : string[8]
                      end;
  
  var infile, outfile   : text;
      error, hitend     : boolean;
      tableloc,k,j      : integer;
      len, errnum       : integer;
      orgstr,substr     : string;
      table             : array [1..tablesize] of tblrectype;
      registers         : set of char;
      Zoperand          : string;
      opcode, operand   : string;
      asc1, asc2        : string;
      
  Procedure tableload;
    type rectype  = record
                      a8opc : string[4];
                      a8opr : string[8];
                      aZopc : string[4];
                      aZopr : string[8]
                    end;
    var recfile : file of rectype;
        temprec : rectype;
              i : integer;
    begin
{*}   writeln('begin tableload');
      reset(recfile,'look.up.table');
      for i := 1 to tablesize do begin
        temprec := recfile^;
        get(recfile);
        table[i].Intlops := concat(temprec.a8opc,temprec.a8opr);
        table[i].Zopc := temprec.aZopc;
        table[i].Zopr := temprec.aZopr
        end;
{*}   writeln('end tableload');
      close(recfile)
    end; (* tableload *)
  
  Procedure setfiles;
    var tempstr : string;
    begin
      write('Input file name > ');
      readln(tempstr);
      reset(infile,tempstr);
      write('Output file name > ');
      readln(tempstr);
{*}   writeln('end setfiles');
      rewrite(outfile,tempstr)
    end; (* setfiles *)
      
  Procedure splitcode; 
                    (* takes orginal string and extracts opcode and operand *)
  
   var i, j  : integer;
    begin
{*}   writeln('begin splitcodes');
      substr := '';
      if length(orgstr) > 32 then
         substr := copy(orgstr,17,16)
        else
         substr := copy(orgstr,17,(length(orgstr)-16));
{*}   writeln(' orgstr *',orgstr,'*');
{*}   writeln(' substr *',substr,'*');
      substr := concat(substr,'        ');
      j := length(substr);
      i := pos(' ',substr);
      if i = 0 then
       begin opcode := substr; operand := '#' end (* I know, I just haven't *)
      else begin                                  (* removed it yet....     *)
        opcode := copy(substr,1,(i-1));
        while substr[j] = ' ' do
          j := j-1;
        while (substr[i] = ' ') and ( i <= j ) do
          i := i+1;
        if i > j then operand := '#'
                 else operand := copy(substr,i,(j-i+1))
        end;
{*}     writeln('opcode *',opcode,'*');
{*}     writeln('operand *',operand,'*');
{*}     writeln('end splitcodes')
    end; (* splitcode *)
  
  Function search : integer;       (* Binary table search *)
    var found : boolean;
        sertbl, seropc: string;
        i, j, k       : integer;
        
    procedure normalize;        (* takes opcode and operand from splitcodes *)
      var i, k : integer;       (* and converts to form of table elements.  *)
      begin
{*}     writeln('begin normalize');
        seropc := '             ';
        insert(opcode, seropc,1);
        k := length(operand);
        i := 0;
        while i < k do
          begin
           i := i+1;
           if operand[i] = ' ' then
             begin
              k := k-1;
              delete(operand,i,1)
             end
          end;
        if length(operand) = 1 then
          begin
          if (operand[1] in registers) or ( operand[1] = '#' ) then
             seropc[5] := operand[1]
            else
             seropc[5] := '$';
{*}       writeln('>A<>',seropc,'<')
          end
         else
          begin
          if (pos('SP',operand)<>0) then
            begin
            if length(operand)=2 then insert('SP',seropc,5)
              else
               if operand[3] = ',' then insert('SP,$',seropc,5)
                                   else insert('$',seropc,5);
{*}         writeln('>D<>',seropc,'<')
            end
           else
            if pos('PSW',operand) <> 0 then
              begin
              if length(operand)=3 then insert('PSW',seropc,5);
{*}           writeln('>E<>',seropc,'<')
              end
             else
              seropc[5] := '$';
          if (operand[1] in registers) and (operand[2] = ',') then
            begin
              if     (operand[3] in registers)
                 and (length(operand) = 3) then
                begin
                insert(operand,seropc,5);
                delete(seropc,(pos('$',seropc)),1);
{*}             writeln('>B<>',seropc,'<')
                end
               else
                begin
                asc1 := copy(operand,1,2);
{*}             writeln('asc1 *',asc1,'*');
                insert(asc1,seropc,5);
{*}             writeln('>C<>',seropc,'<')
                end
             end;
            end;    (* if length = 1 else *)
        seropc := copy(seropc,1,12);
{*}     writeln('seropc *',seropc,'*');
{*}     writeln('end normalize ')
      end; (* normalize *)
              
    
    begin
{*}  writeln('begin search ');
     normalize;
     i := 1; j:=tablesize; found := false;
     repeat k:=(i+j) div 2;
       sertbl := table[k].Intlops;
{*}    writeln('sertbl > ',sertbl);
       if sertbl = seropc then found := true
                          else if sertbl < seropc then i:=k+1
                                                  else j:=k-1
     until (found or (i>j));
     if i>j then k:= 0;
     search := k;
{*}  writeln('end search ')
    end; (* search *)
  
  Procedure insertcode; (* Puts Z-80 codes into original string. *)
    begin
{*}  writeln('begin insertcode ');
     substr := concat(table[tableloc].Zopc,' ',Zoperand,'                  ');
     substr := copy(substr,1,16);
     if length(orgstr) > 32 then delete(orgstr,17,16)
                            else delete(orgstr,17,(length(orgstr)-16));
     insert(substr,orgstr,17);
     writeln(outfile,orgstr);
{*}  writeln('end insertcode')
    end; (* insertcode *)
        
         
         
Begin (* main line *)
 registers := ['A','B','C','D','E','H','L','M'];
 hitend := false;
 errnum := 0;
 error := false;
 tableload;
 setfiles;
 readln(infile,orgstr);
 repeat
{*}writeln(' Begin loop ');
  len := length(orgstr);
  if len = 0 then insert(' ',orgstr,1);
  if (orgstr[1] = ';') or (len < 17) or (orgstr[17] = '.') then
     begin
       writeln(outfile,orgstr);
       if     (pos('.END',orgstr)=17) (* check for end of source *)
          and (pos('.ENDC',orgstr)=0)
          and (pos('.ENDM',orgstr)=0)
            then hitend := true
     end
    else
     begin
      splitcode;
      tableloc := search;
      if tableloc = 0 then 
        begin writeln(outfile,'**** ',orgstr);
          errnum := errnum +1;
          error := true;
          write(chr(7))
        end
       else
        begin    (* Decoding section *)
{*}      writeln(' Decoding section ');
         Zoperand := table[tableloc].Zopr;
         j := pos('$',Zoperand);
         if Zoperand[1] = '#' then Zoperand[1] := ' ';
         if pos(',',operand) = 0 then
           begin                     (* zero and one operands *)
             if pos('$',table[tableloc].Intlops) = 0 then
               insertcode
              else
               begin                 (* replace literal from operand *)
               delete(Zoperand,j,1);
               insert(operand,Zoperand,j);
               insertcode
               end
           end    (* 0 & 1 operands *)
          else
           begin  (* 2 operands *)
             if j = 0 then
               insertcode
              else
               begin
               delete(Zoperand,j,1);
               k := pos(',',operand);
               delete(operand,1,k);
               insert(operand,Zoperand,j);
               insertcode
               end
           end
        end      (* Decoding section *)
     end;
  readln(infile,orgstr);
{*}writeln(' After readln ')
 until hitend;
{*}writeln('hit eof ');
 if error then writeln('There were ',errnum,' error(s).')
          else writeln('No errors encountered');
 close(infile);
 close(outfile, lock)
End. (* main line *)


========================================================================================
DOCUMENT :usus Folder:VOL14:banner.text
========================================================================================

(*  By David Mundie for Culinary Software Systems.  *)
(*  Types four lines of 32 characters on a hard-copy device.  *)

{as modified by george schreyer}


PROGRAM banner;
CONST   AbsMaxLine = 5;          {Maximum lines of text -1}
        MaxChPerLn = 31;         {Max chars per line - 1}
        ColPerCh = 5;            {Columns of dots per character}
        ColPChM1 = 4;            {above -1}
        RowPerCh = 8;            {Rows of dots per character}
        RowPChM1 = 7;            {above -1}
        MaxPixels = 39;          {Dots per character (RowPerCh X ColPerCh -1)}
        HasDiablo = false;        {if so, uses 1/2 linefeeds to fill in char's}

TYPE    pixel = 0..MaxPixels;    {MOD ColPerCh = Column; DIV RowPerCh = Row}
{SO a character grid (upright) looks like:  0  1  2  3  4
                                            5  6  7  8  9
...and on its side:                        10 11 12 13 14
35 30 25 20 15 10  5  0                    15 16 17 18 19
36 31 26 21 16 11  6  1                    20 21 22 23 24
37 32 27 22 17 12  7  2 (top)              25 26 27 28 29
38 33 28 23 18 13  8  3                    30 31 32 33 34
39 34 29 24 19 14  9  4                    35 36 37 38 39   }

        pixset = set of pixel;

VAR     c: char;
        MaxLine, LinesTyped, n, m: integer;
        SizeFactor: 1..10;
        filename: string;
        message: ARRAY [0..AbsMaxLine,0..MaxChPerLn] OF pixset;
        textin: ARRAY [0..AbsMaxLine] OF string;
        table : ARRAY [' '..'z'] OF pixset;
        list: text;

procedure cr;
begin
write ( list, chr ( 128 + 13 ) );  {sends cr with parity bit set so OS won't
                                        add a lf    gws}
end;


PROCEDURE initialize;
BEGIN
  table['!'] := [2,7,12,17,32];
  table['A'] := [1..3,5,10,9,14,15..19,20,25,30,24,29,34];
  table['B'] := [0..3,5,10,9,14,15..18,20,25,30,24,29,30..33];
  table['C'] := [1..3,5,10,15,20,25,31..33,29,9];
  table['D'] := [0..2,5,10,15,20,25,30..32,28,24,19,14,8];
  table['E'] := [0..4,5,10,15..19,20,25,30..34];
  table['F'] := [0..4,5,10,15..18,20,25,30];
  table['G'] := [1..4,5,10,15,20,25,31..34,29,24,18..19];
  table['H'] := [0,5,10,15,20,25,30,4,9,14,19,24,34,29,16..18];
  table['I'] := [1..3,7,12,22,17,12,27,31..33];
  table['J'] := [0..4,8,13,18,23,28,31..32,25];
  table['K'] := [0,5,10,15,20,25,30,16,12,8,4,22,28,34];
  table['L'] := [0,5,10,15,20,25,30..34];
  table['M'] := [0,5,10,15,20,25,30,4,9,14,19,24,29,34,6,8,12,17];
  table['N'] := [0,5,10,15,20,25,30,4,9,14,19,24,29,34,11,17,23];
  table['O'] := [1..3,31..33,5,10,15,20,25,9,14,19,24,29];
  table['P'] := [0..3,5,10,15,20,25,30,16..18,14,9];
  table['Q'] := [1..3,5,10,15,20,25,31,32,34,28,22,24,19,14,9,4];
  table['R'] := [0..3,5,9,10,14,19,15..18,20,25,30,22,28,34];
  table['S'] := [1..4,30..33,16..18,5,10,24,29];
  table['T'] := [0..4,7,12,17,22,27,32];
  table['U'] := [0,5,10,15,20,25,31..33,29,24,19,14,9,4];
  table['V'] := [0,5,10,15,20,26,32,28,24,19,14,9,4];
  table['W'] := [0,5,10,15,20,25,31,33,27,22,17,29,24,19,14,9,4];
  table['X'] := [0,5,25,30,4,9,29,34,21,17,13,11,17,23];
  table['Y'] := [0,5,10,16,22,27,32,18,14,9,4];
  table['Z'] := [0..4,30..34,25,21,17,13,9];
  table[' '] :=[];
  
  table['a'] := [11..14,19,21..24,25,29,31..34];
  table['b'] := [0,5,10,20,25,15..18,30..33,24,29];
  table['c'] := [11..13,15,20,25,31..33];
  table['d'] := [4,9,14,15,16..19,31..34,20,25,24,29];
  table['e'] := [11,12,15,18,20..23,25,31,32];
  table['f'] := [2,6,8,11,15..17,21,26,31];
  table['g'] := [11,12,15,18,20,23,26..28,33,36,37];
  table['h'] := [0,5,10,15,20,25,30,16,17,23,28,33];
  table['i'] := [7,16,17,22,27,31..33];
  table['j'] := [8,18,23,28,33,31,37];
  table['k'] := [0,5,10,15,20,25,30,21,17,27,33];
  table['l'] := [1,2,7,12,17,22,27,31..33];
  table['m'] := [11,13,15,17,19,20,22,24,25,29,30,34];
  table['n'] := [11,12,15,18,20,23,25,28,30,33];
  table['o'] := [11,12,15,18,20,23,25,28,31,32];
  table['p'] := [10..12,15,18,20,23,25..27,30,35];
  table['q'] := [11..13,15,18,20,23,26..28,33,38,39];
  table['r'] := [10,12,13,15,16,20,25,30];
  table['s'] := [11..13,15,21..23,29,31..33];
  table['t'] := [6,10..12,16,21,26,32];
  table['u'] := [10,13,15,18,20,23,25,28,31..34];
  table['v'] := [10,14,15,19,20,24,26,28,32];
END;


PROCEDURE Init2;
BEGIN
  table['w'] := [10,14,15,17,19,20,22,24,25,27,29,31,33];
  table['x'] := [10,14,16,18,22,26,28,30,34];
  table['y'] := [10,13,15,18,20,23,26..28,33,36,37];
  table['z'] := [10..14,18,22,26,30..34];
  table['-'] := [16,17,18];
  table['*'] := [7,12,17,22,27,16,18,10,14,20,24];
  table['?'] := [1..3,5,9,13,17,22,32];
  table['.'] := [29,34];
  table[','] := [28,33,37];
  table[':'] := [12,17,27,32];
  table[';'] := table[':'] + [36];
  table['1'] := [36..38,2,7,12,17,22,27,32,6];
  table['2'] := [35..39,30,31,27,23,19,14,9,1..3,5];
  table['3'] := [36..38,30,17..19,1..3,5,9,14,24,29,34];
  table['4'] := [20..24,15,11,7,3,8,13,18,28,33,38];
  table['5'] := [0..4,9,5,10,15,21..23,29,34,36..38,30];
  table['6'] := [36..38,21..23,1..3,9,5,10,15,20,25,30,29,34];
  table['7'] := [5,0..4,9,14,19,23,27,31,35];
  table['8'] := [1..3,21..23,36..38,9,14,19,29,34,5,10,15,25,30];
  table['9'] := [1..3,16..18,36..38,30,9,14,19,24,29,34,5,10];
  table['0'] := [1..3,36..38,5,10,15,20,25,30,9,14,19,24,29,34,24,26,22,18];
  END;


PROCEDURE Show;
VAR     i,CCount,Col,Lines,Row, Size:integer;
        maxlen:integer;
        DotNum : integer;
        DotOn : Packed Array [0..223] of Boolean;

PROCEDURE WriteDot;
VAR     x, y: integer;
BEGIN
  FOR y := 1 TO SizeFactor DO
    BEGIN
      DotOn [ DotNum ] := true;
      DotNum := Dotnum + 1;
    END
END;


PROCEDURE WriteBlank;
VAR     i: integer;
BEGIN FOR i := 1 TO SizeFactor DO 
   begin
      DotOn [ DotNum ] := false;
      DotNum := DotNum + 1;
   end;
END;


FUNCTION FillLeft: boolean;
VAR     x,              {current pixel}
        y: integer;     {1 pixel to left}
        TCh: pixset;
BEGIN
  IF Row >= RowPChM1 THEN FillLeft := false
  ELSE BEGIN
    TCh := message[Lines,CCount];  x := Row*ColPerCh + Col;  y := x + ColPerCh;
    IF NOT(y IN TCh) THEN FillLeft := false
    ELSE IF Col <= 0 THEN FillLeft := ((x + 1) IN TCh) AND NOT ((y + 1) IN TCh)
    ELSE IF Col >= ColPChM1
      THEN FillLeft := ((x - 1) IN TCh) AND NOT ((y - 1) IN TCh)
    ELSE FillLeft := (((x + 1) IN TCh) AND NOT ((y + 1) IN TCh))
      OR (((x - 1) IN TCh) AND NOT ((y - 1) IN TCh))
  END
END;


FUNCTION FillRight: boolean;
VAR     x,              {current pixel}
        y: integer;     {1 pixel to right}
        TCh: pixset;
BEGIN
  IF Row <= 0 THEN FillRight := false
  ELSE BEGIN
    TCh := message[Lines,CCount];  x := Row*ColPerCh + Col;  y := x - ColPerCh;
    IF NOT(y IN TCh) THEN FillRight := false
    ELSE IF Col <= 0 THEN FillRight := ((x + 1) IN TCh) AND NOT ((y + 1) IN TCh)
    ELSE IF Col >= ColPChM1
      THEN FillRight := ((x - 1) IN TCh) AND NOT ((y - 1) IN TCh)
    ELSE FillRight := (((x + 1) IN TCh) AND NOT ((y + 1) IN TCh))
      OR (((x - 1) IN TCh) AND NOT ((y - 1) IN TCh))
  END
END;

Procedure Strike( ch : char );
 
 
            
 var j : integer;
SPACE : PACKED ARRAY [0..1] OF CHAR;
CHARX : PACKED ARRAY [0..1] OF CHAR;

BEGIN
   SPACE[1]:=CHR(32);
   CHARX[1]:=CH;
   FOR j :=1 TO DotNum-1 DO IF DotOn[j] THEN UNITWRITE(6,CHARX[1],1,0,1) 
        ELSE UNITWRITE(6,SPACE[1],1,0,1);
   CR;
END;

    
BEGIN
  DotNum := 1;
  maxlen := 0;
  FOR i := 0 TO LinesTyped-1 DO
    IF length(textin[i]) > maxlen THEN maxlen := length(textin[i]);
  FOR CCount := 1 TO maxlen DO
    BEGIN
      FOR Col := 0 TO 4 DO FOR Size := 1 TO SizeFactor DO
        BEGIN
          FOR Lines := LinesTyped-1 DOWNTO 0 DO
            BEGIN
              FOR Row := 7 DOWNTO 0 DO
                BEGIN
                  IF Row * ColPerCh + Col IN message[Lines,CCount]
                    THEN FOR i := 1 TO 2 DO WriteDot
                  ELSE IF FillLeft THEN BEGIN WriteDot;  WriteBlank END
                  ELSE IF FillRight THEN BEGIN WriteBlank;  WriteDot END
                  ELSE FOR i := 1 TO 2 DO WriteBlank
                END;
              FOR i := 1 TO 2 DO WriteBlank  {space between lines}
            END;
          Strike('8');
          Strike('#');
          DotNum := 1;
          Writeln(list)
        END;
      Writeln(list)
    END;
END;


BEGIN
  FOR n := 0 TO AbsMaxLine DO
    BEGIN
      FOR m := 0 TO 31 DO message[n,m] := [];  textin[n] := ''
    END;
  Initialize;  Init2;  SizeFactor := 1;
  Write(
'By what factor (1 to 8) do you wish to multiply the size of the letters? ');
  Readln(SizeFactor);  
  IF SizeFactor > 1 then MaxLine := AbsMaxLine DIV SizeFactor + 1 
    ELSE MaxLine := AbsMaxLine;
  Writeln(
    'Enter your message (up to ',MaxLine,' lines of up to 32 characters): ');
  n := 0;  
  REPEAT
    Readln(textin[n]);  m := Length(textin[n]);
    IF m > MaxChPerLn THEN DELETE(Textin[n],MaxChPerLn, m - MaxChPerLn + 1);
    n := n + 1
  UNTIL (n > MaxLine-1) OR (textin[n-1] = ' ') OR (textin[n-1] = '');
  IF (textin[n-1] = ' ') OR (textin[n-1] = '')
    THEN LinesTyped := n-1 ELSE LinesTyped := n;
       REWRITE(LIST,'PRINTER:');
       page(list);
       (*write(list,CHR(27),'PH',CHR(27),'\');   {set  8   lpi}
       WRITE(LIST,CHR(27),'PD\');              {set 16.5 cpi}*) {for TI-820}
       FOR n := 0 TO LinesTyped-1 DO FOR m := 1 TO length(textin[n]) DO
         message[n,m] := table[textin[n,m]];
       Show;
       page(list);
       (*WRITE(LIST,CHR(27),'PC\');   {set 10 cpi}
       WRITE(LIST,CHR(27),'PA\');   {set  6 lpi}*)  {for TI-820}
       CLOSE(list,lock);
END.


========================================================================================
DOCUMENT :usus Folder:VOL14:bondystuff.text
========================================================================================

     This is a note from Jon bondy which describes his submissions. -gws
     
     The COPVOL and COPFILE programs should be easy to understand: they ask
for source and destination volumes/files and perform a copy by reading the
source into one buffer, writing that buffer to the destination, reading the
destination into a second buffer, and then comparing the buffers. In COPVER,
if the file *SYSTEM.PDP11 does not exist, it is assumed that the program is
running on an 8080 or a Z-80 and the COPVER.ASM 8080 assembly routines are
executed to copy the booter tracks using CP/M BIOS routines: I know this will
not work for everyone, but it is better than nothing at all, and there is no
sector read mode in I.5.

     The COMPFILE program reads the two files and compares them bit for bit: if
there are discrepancies, the block and byte number is calculated and displayed.
The other compare program in the library is probably much better for TEXT
files, but to compare binary/data files, this program is useful.

     The disk SCANNER program allows you to scan an entire volume rapidly
searching for the occurance of one of a number of character strings.  If the
strings are found anywhere, the directory is searched to see in what file the
string was located.  Then the file name and the string found, along with the
context in which it was found, is displayed on the screen.  This program is
useful if you have a number of disks with similar data and you want to find a
particular file but don't know the name: I use it to locate TeleMail files on
my archive disks.  The program looks for SCAN.DATA.TEXT for the list of search
strings.

     The GAME program is a simple game with demons and a maze.  The screen is
used as a playing field, with "-", "|", and "+" used as maze obstacles: the
player is a 'P' and the "demons" which try to kill him/her are 'D's.  A player
can kill a demon by landing on top of him; demons do the same for the player. 
This results in a 50/50 chance of success if a player makes a head-long rush
towards a demon: more subtle approaches are required to insure winning (like
sneaking up on him from behind).  One feature of the game is the board edit
mode, in which the player can create his/her own maze. 

     At the top level, one has the choice of changing the demon M(ode, starting
to P(lay a game, changing the L(evel of difficulty of play, and entering S(etup
(the game board editor).  All commands are single key strokes, with both upper
and lower case characters accepted.

     The Demons operate in one of two "modes": Inertial mode or Heat-Seeking
mode.  In Inertial mode, they chose a random direction and go in that
direction until they hit an obstacle (or kill a Player!): they then make a
random decision and continue in a new direction until they hit something else.
In Heat-Seeking mode, they know the direction of the Player, and they try to get
to him/her, although they do not know enough to go around walls.  Typing "M" at
the top level or during game play toggles the mode.
     
     In Heat-Seeking mode, the Player hasn't got a chance to win on a 2 MHz 
Z-80, so I added the playing difficulty levels, from 0 to 9: at level 0, the
game runs so fast you can't keep up, while at level 9 it is fairly easy to win
once you have some experience.

     During game play you can move the player up, down, left, or right (they
keys for these actions are defined in the program), entering Hyper-Space by
typing an "H" (puts you in a random position on the board), toggling the Demon
Mode by typing an "M", changing the levels by typing the numeric digits from
"0" to "9", or quiting. 

      Setup mode allows the player to G(et or P(ut a game board (maze), alter
the N(umber of demons at the start of the game from 1 to 9, or E(dit the game
board.  G(etting a non-existant game board will have the side-effect of
clearing the game board, allowing easy generation of a new one in E(dit mode.
The Edit mode allows the creation or deletion of all walls/corridors in the
maze.  The default direction is specified by pressing any of the up, down, t
left, or right keys: thereafter the other keys ("+", "-", "|") will be inserted
in the game board in the same direction.  This allows easy creation of vertical
walls.

     A few things must be set up by the user before the Game program will work.
The first is to create a "key_hit" routine which returns "true" when there is a
character ready from the keyboard.  I have done this in my program by using a
"port_read" routine which reads the keyboard status register and detects the
ready bit (I include this routine for the 8080/Z-80 as GAME.ASSEM.TEXT).  The
user must also modify the "eeoln" routine to provide the correct erase-to-end-
of-line sequence for his/her terminal.  (Reviewer' note : I did these 
modifications for the H-89 and they are included also. - gws) Finally, if the
user wants to use different cursor control keys than I have (I use the "star"
shaped cluster of "f", "g", "v", and "t"), s/he must modify the CONST part of
the program where indicated.

                                   Jon Bondy

========================================================================================
DOCUMENT :usus Folder:VOL14:calendar.text
========================================================================================

{Program Author:  Walter I. Hess
                 1460 Seven Pines Rd.
                 Schaumberg, IL 60193
                 
Assumes Heath H19 or VT-52 CRT}

PROGRAM CALENDAR;
{Version "O"  W.I.H.  1/7/80}
{Program will provide a calendar month in any year from 1753 on.}

CONST
  {The Gregorian Calendar was adopted in the U.S. in 1752}
  STARTYR = 1753;
  STARTDAY = 1;

TYPE
  SHINT = 0..255;

VAR
  CH,ESCH : CHAR;
  MONTH : SHINT;
  DAY,YEAR,J : INTEGER;

PROCEDURE CALCDAY;
{Procedure calculates the day of the week for the first day of the 
 desired month. "0" is Sunday and "6" is Saturday. STARTDAY is the day
 of the week (Monday) of January 1, 1753.}

BEGIN
  DAY := STARTDAY;
  FOR J := STARTYR TO YEAR - 1 DO
    IF ((J MOD 4 = 0) AND (J MOD 100 <> 0)) OR (J MOD 400 = 0)
      THEN DAY := DAY + 2
      ELSE DAY := DAY + 1;
  CASE MONTH OF
    2: DAY := DAY + 31;
    3: DAY := DAY + 59;
    4: DAY := DAY + 90;
    5: DAY := DAY + 120;
    6: DAY := DAY + 151;
    7: DAY := DAY + 181;
    8: DAY := DAY + 212;
    9: DAY := DAY + 243;
    10: DAY := DAY + 273;
    11: DAY := DAY + 304;
    12: DAY := DAY + 334;
  END; {Case}
  IF (MONTH > 2) AND (((YEAR MOD 4 = 0) AND (YEAR MOD 100 <> 0))
                                                 OR (YEAR MOD 400 = 0))
    THEN DAY := DAY + 1;
  DAY := DAY MOD 7;
END; {Calcday}

PROCEDURE CLEARPRM;
{Procedure clears the "prompt" line.}

BEGIN
  WRITE(ESCH,'Y8 ');
  WRITE(ESCH,'l');
END; {Clearprm}

PROCEDURE PREPSCR;
{Procedure draws the calendar outline on the screen}

VAR
  J,K : SHINT;
  
  PROCEDURE HLINE (LINE : SHINT);

  BEGIN
    GOTOXY(5,LINE);
    FOR K := 5 TO 73 DO
      WRITE('a');
  END; {Hline}

BEGIN
  WRITE(ESCH,'E',ESCH,'F');
  HLINE(3);
  FOR J := 0 TO 6 DO
    HLINE(5 + 3 * J);
  FOR J := 0 TO 7 DO
    FOR K := 4 TO 22 DO
      BEGIN
        GOTOXY(4 + 10 * J, K);
        WRITE('`');
      END;
  GOTOXY(4,3);WRITE('f');
  GOTOXY(4,23);WRITE('e');
  GOTOXY(74,3);WRITE('c');
  GOTOXY(74,23);WRITE('d');
  FOR J := 0 TO 5 DO
    BEGIN
      GOTOXY(4, 5 + J * 3);WRITE('v');
      GOTOXY(74, 5 + J * 3);WRITE('t');
    END;
  FOR J := 0 TO 5 DO
    BEGIN
      GOTOXY(14 + 10 * J, 3);
      WRITE('s');
      GOTOXY(14 + 10 * J, 23);
      WRITE('u');
      FOR K := 0 TO 5 DO
        BEGIN
          GOTOXY(14 + 10 * J, 5 + 3 * K);
          WRITE('b');
        END;
    END;
    WRITE(ESCH,'G');
    GOTOXY(7,4);WRITE('SUNDAY');
    GOTOXY(17,4);WRITE('MONDAY');
    GOTOXY(26,4);WRITE('TUESDAY');
    GOTOXY(35,4);WRITE('WEDNESDAY');
    GOTOXY(46,4);WRITE('THURSDAY');
    GOTOXY(57,4);WRITE('FRIDAY');
    GOTOXY(66,4);WRITE('SATURDAY');
END; {Prepscr}

PROCEDURE CLEARMON;
{Procedure clears the dates in preparation for a new month.}

VAR
  J,K,L : SHINT;

BEGIN
  GOTOXY(0,1);WRITE(ESCH,'l');
  FOR J := 0 TO 6 DO
    FOR K := 0 TO 5 DO
      FOR L := 0 TO 1 DO
        BEGIN
          GOTOXY(5 + J * 10, 6 + K * 3 + L);
          WRITE('         ');
        END;
END; {Clearmon}

PROCEDURE DISPMONT;
{Procedure displays the new month.}

VAR
  DAYS,J,K : SHINT;

BEGIN
  CASE MONTH OF
    1: BEGIN
         GOTOXY(33,1);WRITE('JANUARY ');
         DAYS := 31;
       END;
    2: BEGIN
         GOTOXY(32,1);WRITE('FEBRUARY ');
         IF ((YEAR MOD 4 = 0) AND (YEAR MOD 100 <> 0)) OR (YEAR MOD 400 = 0)
           THEN DAYS := 29
           ELSE DAYS := 28;
       END;
    3: BEGIN
         GOTOXY(34,1);WRITE('MARCH ');
         DAYS := 31;
       END;
    4: BEGIN
         GOTOXY(34,1);WRITE('APRIL ');
         DAYS := 30;
       END;
    5: BEGIN
         GOTOXY(35,1);WRITE('MAY ');
         DAYS := 31;
       END;
    6: BEGIN
         GOTOXY(34,1);WRITE('JUNE ');
         DAYS := 30;
       END;
    7: BEGIN
         GOTOXY(34,1);WRITE('JULY ');
         DAYS := 31;
       END;
    8: BEGIN
         GOTOXY(35,1);WRITE('AUGUST ');
         DAYS := 31;
       END;
    9: BEGIN
         GOTOXY(32,1);WRITE('SEPTEMBER ');
         DAYS := 30;
       END;
    10: BEGIN
          GOTOXY(33,1);WRITE('OCTOBER ');
          DAYS := 31;
        END;
    11: BEGIN
          GOTOXY(33,1);WRITE('NOVEMBER ');
          DAYS := 30;
        END;
    12: BEGIN
          GOTOXY(33,1);WRITE('DECEMBER ');
          DAYS := 31;
        END;
  END; {Case}
  WRITE(YEAR);
  K := 6;
  FOR J := 1 TO DAYS DO
    BEGIN
      GOTOXY(5 + DAY * 10, K);
      WRITE(J:2);
      DAY := DAY + 1;
      IF DAY = 7
        THEN
          BEGIN
            DAY := 0;
            K := K + 3;
          END;
    END;
END; {Dispmont}

BEGIN {Calendar}
  ESCH := CHR(27);
  WRITE(ESCH,'E',ESCH,'x1',ESCH,'x5',ESCH,'y6');
  PREPSCR;
  REPEAT
    CLEARPRM;
    WRITE('ENTER YEAR OR "0" TO TERMINATE PROGRAM    ');
    READLN(YEAR);
    IF YEAR >= STARTYR 
      THEN
        BEGIN
          REPEAT
            CLEARPRM;
            WRITE('ENTER MONTH (1 TO 12 FOR JANUARY TO DECEMBER)   ');
            READLN(MONTH);
          UNTIL (MONTH > 0 ) AND (MONTH < 13);
          CLEARMON;
          CALCDAY;
          DISPMONT;
        END;
  UNTIL YEAR = 0;
  WRITE(ESCH,'z');
END. {Calendar}
          

========================================================================================
DOCUMENT :usus Folder:VOL14:compfile.text
========================================================================================

program compfile;
  { compare file utility program.
    written by Jon Bondy Feb 1982 }
  const 
    { number of retries for reading and writing }
    readretries = 1;
    writeretries = 3;
    buffsize = 32; { blocks }
    bs = 8;
  type
    block = packed array [1..512] of char;
  var
    buff1, buff2 : array[1..buffsize] of block;
    retrycount : integer;
    file_1, file_2 : file;
    fname : string;
    ch : char;
      
  procedure do_compare;
    var
       startblock : integer;
       size : integer;
       retrycount : integer;
       i : integer;
       error : boolean;
    
    procedure read_1(var size : integer; startblock : integer);
      var
        retrycount : integer;
      begin
      retrycount := 0;
      repeat
        if (ioresult <> 0) then 
          writeln('Attempting to re-try reading file 1 after block ',
             startblock,'.');
        { obtain actual amount of data read here for use later on }
        {$I-} size := blockread(file_1,buff1,buffsize,startblock); {$I+}
        retrycount := retrycount + 1;
        until (ioresult = 0) or (retrycount > readretries);
      if (ioresult <> 0) then begin
        writeln('Unrecoverable error reading file 1 after block ',
           startblock,'.');
        exit(do_compare);
        end;
      end; { read_1 }
          
    procedure read_2(size, startblock : integer);
      var
        retrycount, size_read : integer;
      begin
      retrycount := 0;
      repeat
        if (ioresult <> 0) then 
          writeln('Attempting to re-try reading file 2 after block ',
             startblock,'.');
        {$I-} size_read := blockread(file_2,buff2,size,startblock); {$I+}
        retrycount := retrycount + 1;
        until ((ioresult = 0) and (size_read = size)) or 
          (retrycount > readretries);
      if (ioresult <> 0) or (size_read <> size) then begin
        writeln('Unrecoverable error reading file 2 after block ',startblock,'.');
        exit(do_compare);
        end;
      end; { read_2 }
          
    procedure compare_buffers(size, startblock : integer);
      var
        i, j : integer;
      begin
      for i := 1 to size do
        if (buff1[i] <> buff2[i]) then begin
           writeln('Compare error in block ', (startblock + i - 1), '.');
           for j := 1 to 512 do
             if (buff1[i][j] <> buff2[i][j]) then begin
                writeln('Compare error in  byte ', j, '.');
                exit(do_compare);
                end; { if }
           end; { if }
      end; { compare_buffers }
        
    begin { do_compare }
    startblock := 0;
    repeat
      size := buffsize; { try to fill buffer each time }
      write('Comparing block ',startblock:4,'    ');
      for i := 1 to 24 do write(chr(bs));
      read_1(size,startblock);
      read_2(size,startblock);
      compare_buffers(size,startblock);
      startblock := startblock + buffsize;
      until (size < buffsize);
    writeln;
    writeln('Comparison completed successfully.');
    end; { do_compare }
    
  begin { main }
  repeat
    writeln('Compare File Utility.  Written by Jon Bondy, 2/82.');
    repeat
      write('Enter first file name : ');
      readln(fname);
      close(file_1); {$I-} reset(file_1,fname); {$I+}
      until (ioresult = 0);
    repeat
      write('Enter second file name : ');
      readln(fname);
      close(file_2); {$I-} reset(file_2,fname); {$I+}
      until (ioresult = 0);
    do_compare;
    write('Do you wish to make another comparison? ');
    read(ch); writeln;
    until (ch = 'n') or (ch = 'N');
  write('Press <CR> when system disk is in Unit 4 again.');
  readln(ch);
  end.



========================================================================================
DOCUMENT :usus Folder:VOL14:copfile.text
========================================================================================

program copfile;
  { copy verify file utility program.
    written by Jon Bondy Feb 1982 }
  const 
    { number of retries for reading and writing }
    readretries = 1;
    writeretries = 3;
    buffsize = 32; { blocks }
    bs = 8;
  type
    block = packed array [0..255] of integer;
  var
    buff1, buff2 : array[1..buffsize] of block;
    retrycount : integer;
    source, dest : file;
    fname : string;
    ch : char;
    proceed : boolean;
      
  procedure docopy;
    var
      startblock : integer;
      size : integer;
      error : boolean;
      i : integer;
      
    procedure doread(var size : integer; startblock : integer);
      var
        retrycount : integer;
      begin
      retrycount := 0;
      repeat
        if (ioresult <> 0) then 
          writeln('Attempting to re-try source read after block ',
            startblock,'.');
        { obtain actual amount of data read here for use later on }
        {$I-} size := blockread(source,buff1,buffsize,startblock); {$I+}
        retrycount := retrycount + 1;
        until (ioresult = 0) or (retrycount > readretries);
      if (ioresult <> 0) then begin
        writeln('Unrecoverable error reading source file after block ',
          startblock,'.');
        exit(docopy);
        end;
      end; { doread }
        
    procedure dowrite(size, startblock : integer);
      var
        retrycount, size_read : integer;
      begin
      retrycount := 0;
      repeat
        if (ioresult <> 0) then 
          writeln('Attempting to re-try write after block ',startblock,'.');
        {$I-} size_read := blockwrite(dest,buff1,size,startblock); {$I+}
        retrycount := retrycount + 1;
        until ((ioresult = 0) and (size_read = size)) or 
          (retrycount > writeretries);
      if (ioresult <> 0) or (size_read <> size) then begin
        writeln('Unrecoverable error writing destination file after block ',
          startblock,'.');
        exit(docopy);
        end;
      end; { dowrite }
        
    function docompare(size, startblock : integer) : boolean;
      { return true if compare error }
      var
        retrycount, size_read : integer;
        i : integer;
        error : boolean;
      begin
      retrycount := 0;
      repeat
        if (ioresult <> 0) then 
          writeln('Attempting to re-try destination read after block ',
            startblock,'.');
        {$I-} size_read := blockread(dest,buff2,size,startblock); {$I+}
        retrycount := retrycount + 1;
        until ((ioresult = 0) and (size_read = size)) or 
          (retrycount > readretries);
      if (ioresult <> 0) or (size_read <> size) then begin
        writeln('Error re-reading destination file after block ',
          startblock,'.');
        docompare := true; { signal error }
        exit(docompare);
        end;
      error := false;
      for i := 1 to size do
        error := error or (buff1[i] <> buff2[i]);
      if error then writeln('Compare error after block ',startblock,'.');
      docompare := error;
      end; { docompare }
        
    begin { docopy }
    startblock := 0;
    repeat
      size := buffsize; { try to fill buffer each time }
      retrycount := 0;
      repeat
        write('Copying block ',startblock:4,'    ');
        for i := 1 to 22 do write(chr(bs));
        doread(size,startblock);
        dowrite(size,startblock);
        error := docompare(size,startblock);
        { true if error on compare }
        if error then writeln('Retrying copy starting at block ',startblock);
        retrycount := retrycount + 1;
        until not error or (retrycount > readretries);
      if error then begin
        writeln; writeln('Unable to copy due to unrecoverable errors.');
        exit(docopy);
        end;
      startblock := startblock + buffsize;
      until (size < buffsize);
    writeln;
    close(dest,lock);
    writeln('Copy completed successfully.');
    end; { docopy }
    
  begin { main }
  repeat
    writeln('Copy/Verify File Utility.  Written by Jon Bondy, 2/82.');
    repeat
      write('Enter source file name : ');
      readln(fname);
      close(source); {$I-} reset(source,fname); {$I+}
      until (ioresult = 0);
    repeat
      write('Enter destination file name : ');
      readln(fname); close(dest); 
      { try to open for read } {$I-} reset(dest,fname); {$I+}
      if (ioresult = 0) then begin { file found }
         write('File exists: destroy it ? ');
         read(ch); writeln;
         if (ch = 'y') or (ch = 'Y') then begin
            close(dest,purge);
            proceed := true;
            end
         else proceed := false; { prevent copy }
         end
      else proceed := true; { file not found }
      close(dest); 
      if proceed then {$I-} rewrite(dest,fname); {$I+}
      until (ioresult = 0);
    if proceed then docopy;
    write('Do you wish to make another copy? ');
    read(ch); writeln;
    until (ch = 'n') or (ch = 'N');
  write('Press <CR> when system disk is in Unit 4 again.');
  readln(ch);
  end.



========================================================================================
DOCUMENT :usus Folder:VOL14:copver.asm.text
========================================================================================

        
SELDSK  .EQU     1BH
SETTRK  .EQU     1EH
SETSEC  .EQU     21H
SETDMA  .EQU     24H
READ    .EQU     27H
WRITE   .EQU     2AH


        .FUNC READSECTOR,4
        POP     IX              ;return address
        POP     IY              ;POP TWO WORDS OF ZEROS
        POP     IY              ;POP TWO WORDS OF ZEROS
        
        POP     BC              ;memory write address
        LD      HL,(0001H)      ;PICK UP MS-BYTE OF BIOS ADDRESS
        LD      L,SETDMA
        LD      DE,TAG1
        PUSH    DE
        JP      (HL)            ;CALL SETDMA
        
TAG1    POP     BC              ;disk number
        LD      HL,(0001H)      ;PICK UP MS-BYTE OF BIOS ADDRESS
        LD      L,SELDSK
        LD      DE,TAG2
        PUSH    DE
        JP      (HL)            ;CALL SELDSK
                
TAG2    POP     BC              ;track number 
        LD      HL,(0001H)      ;PICK UP MS-BYTE OF BIOS ADDRESS
        LD      L,SETTRK
        LD      DE,TAG3
        PUSH    DE
        JP      (HL)            ;CALL SETTRK
        
TAG3    POP     BC              ;sector number
        LD      HL,(0001H)      ;PICK UP MS-BYTE OF BIOS ADDRESS
        LD      L,SETSEC
        LD      DE,TAG4
        PUSH    DE
        JP      (HL)            ;CALL SETSEC
        
TAG4    LD      HL,(0001H)      ;PICK UP MS-BYTE OF BIOS ADDRESS
        LD      L,READ
        LD      DE,TAG5
        PUSH    DE
        JP      (HL)            ;CALL READ
        
TAG5    LD      BC,0FFFFH
        JP      NZ,TAG6
        LD      BC,00000H
TAG6    PUSH    BC              ;FUNCTION RETURN VALUE
        JP      (IX)            ;restore return address
        
        .FUNC WRITESECTOR,4
        POP     IX              ;return address
        POP     IY              ;POP TWO WORDS OF ZEROS
        POP     IY              ;POP TWO WORDS OF ZEROS
        
        POP     BC              ;memory write address
        LD      HL,(0001H)      ;PICK UP MS-BYTE OF BIOS ADDRESS
        LD      L,SETDMA
        LD      DE,TAG1
        PUSH    DE
        JP      (HL)            ;CALL SETDMA
        
TAG1    POP     BC              ;disk number
        LD      HL,(0001H)      ;PICK UP MS-BYTE OF BIOS ADDRESS
        LD      L,SELDSK
        LD      DE,TAG2
        PUSH    DE
        JP      (HL)            ;CALL SELDSK
                
TAG2    POP     BC              ;track number 
        LD      HL,(0001H)      ;PICK UP MS-BYTE OF BIOS ADDRESS
        LD      L,SETTRK
        LD      DE,TAG3
        PUSH    DE
        JP      (HL)            ;CALL SETTRK
        
TAG3    POP     BC              ;sector number
        LD      HL,(0001H)      ;PICK UP MS-BYTE OF BIOS ADDRESS
        LD      L,SETSEC
        LD      DE,TAG4
        PUSH    DE
        JP      (HL)            ;CALL SETSEC
        
TAG4    LD      HL,(0001H)      ;PICK UP MS-BYTE OF BIOS ADDRESS
        LD      L,WRITE
        LD      DE,TAG5
        PUSH    DE
        JP      (HL)            ;CALL WRITE
        
TAG5    LD      BC,0FFFFH
        JP      NZ,TAG6
        LD      BC,00000H
TAG6    PUSH    BC              ;FUNCTION RETURN VALUE
        JP      (IX)            ;restore return address
        
        .END
                                ; FILE IS COPVER.ASM.TEXT


========================================================================================
DOCUMENT :usus Folder:VOL14:copvol.text
========================================================================================

program copver;
  { copy verify utility program.
    written by Jon Bondy 1981 }
  const 
    { number of retries for reading and writing }
    readretries = 1;
    writeretries = 3;
    { unit numbers }
    source = 4;
    dest = 5;
    buffsize = 32; { blocks }
    bs = 8;
  type
    block = packed array [0..255] of integer;
  var
    buff1, buff2 : array[1..buffsize] of block;
    totalblocks : integer;
    retrycount : integer;
    { to allow one to read the directory to find the volume id }
    dir : record
      trash1, trash2, trash3 : integer;
      volid : string[7];
      eovblk : integer;
      end;
    ch : char;
      
  function readsector(sect, track, disk : integer; var mem_addr : integer) : 
      integer; external;
  function writesector(sect, track, disk : integer; var mem_addr : integer) : 
      integer; external;
  
  procedure docopy;
    var
      startblock : integer;
      size : integer;
      error : boolean;
      i : integer;
      
    procedure copy_booter;
      var
        interleave : array[1..26] of integer;
      
      procedure read_booter;
        var
          track, sector, addr, buffer, i : integer;
          error : boolean;
        begin
        write('Reading boot tracks.');
        for i := 1 to 20 do write(chr(bs));
        addr := 0; buffer := 1; error := false;
        for track := 0 to 1 do
          for sector := 1 to 26 do begin
            error :=  error or 
            (readsector(interleave[sector],track,0,buff1[buffer,addr]) <> 0);
            addr := addr + 64;
            if (addr = 256) then begin
               addr := 0; buffer := buffer + 1; end
            end;
        if error then begin
          writeln('Unable to read boot tracks.'); exit(docopy); end;
        end; { read_booter }
      
      procedure write_booter;
        var
          track, sector, addr, buffer, i : integer;
          error : boolean;
        begin
        write('Writing boot tracks.');
        for i := 1 to 20 do write(chr(bs));
        addr := 0; buffer := 1; error := false;
        for track := 0 to 1 do
          for sector := 1 to 26 do begin
            error :=  error or 
            (writesector(interleave[sector],track,1,buff1[buffer,addr]) <> 0);
            addr := addr + 64;
            if (addr = 256) then begin
               addr := 0; buffer := buffer + 1; end
            end;
        if error then begin
          writeln('Unable to write boot tracks.'); exit(docopy); end;
        end; { write_booter }
      
      procedure compare_booter;
        var
          track, sector, addr, buffer, i : integer;
          error : boolean;
        begin
        write('Comparing boot tracks.');
        for i := 1 to 22 do write(chr(bs));
        addr := 0; buffer := 1; error := false;
        for track := 0 to 1 do
          for sector := 1 to 26 do begin
            error :=  error or 
            (readsector(interleave[sector],track,1,buff2[buffer,addr]) <> 0);
            addr := addr + 64;
            if (addr = 256) then begin
               addr := 0; buffer := buffer + 1; end
            end;
        if error then begin
          writeln('Unable to re-read boot tracks.'); exit(docopy); end;
        error := false;
        for i := 1 to 13 do
          error := error or (buff1[i] <> buff2[i]);
        if error then begin 
          writeln('Boot tracks compare error.'); exit(docopy); end
        end; { compare_booter }
      
      begin { copy_booter }
      interleave[1] := 1; interleave[2] := 3; interleave[3] := 5;
      interleave[4] := 7; interleave[5] := 9; interleave[6] := 11;
      interleave[7] := 13; interleave[8] := 15; interleave[9] := 17;
      interleave[10] := 19; interleave[11] := 21; interleave[12] := 23;
      interleave[13] := 25; interleave[14] := 2; interleave[15] := 4;
      interleave[16] := 6; interleave[17] := 8; interleave[18] := 10;
      interleave[19] := 12; interleave[20] := 14; interleave[21] := 16;
      interleave[22] := 18; interleave[23] := 20; interleave[24] := 22;
      interleave[25] := 24; interleave[26] := 26;
      read_booter;
      write_booter;
      compare_booter;
      end; { copy_booter }
      
    procedure doread(size, startblock : integer);
      var
        retrycount : integer;
      begin
      retrycount := 0;
      repeat
        if (ioresult <> 0) then 
          writeln('Attempting to re-try read after block ',startblock,'.');
        {$I-} unitread(source,buff1,size,startblock); {$I+}
        retrycount := retrycount + 1;
        until (ioresult = 0) or (retrycount > readretries);
      if (ioresult <> 0) then begin
        writeln('Unrecoverable error reading Unit 4 after block ',startblock,'.');
        exit(docopy);
        end;
      end; { doread }
        
    procedure dowrite(size, startblock : integer);
      var
        retrycount : integer;
      begin
      retrycount := 0;
      repeat
        if (ioresult <> 0) then 
          writeln('Attempting to re-try write after block ',startblock,'.');
        {$I-} unitwrite(dest,buff1,size,startblock); {$I+}
        retrycount := retrycount + 1;
        until (ioresult = 0) or (retrycount > writeretries);
      if (ioresult <> 0) then begin
        writeln('Unrecoverable error writing Unit 5 after block ',startblock,'.');
        exit(docopy);
        end;
      end; { dowrite }
        
    function docompare(size, startblock : integer) : boolean;
      { return true if compare error }
      var
        retrycount : integer;
        i : integer;
        error : boolean;
      begin
      retrycount := 0;
      repeat
        if (ioresult <> 0) then 
          writeln('Attempting to re-try re-read after block ',startblock,'.');
        {$I-} unitread(dest,buff2,size,startblock); {$I+}
        retrycount := retrycount + 1;
        until (ioresult = 0) or (retrycount > readretries);
      if (ioresult <> 0) then begin
        writeln('Error re-reading Unit 5 after block ',startblock,'.');
        docompare := true; { signal error }
        exit(docompare);
        end;
      error := false;
      for i := 1 to (size div 512) do
        error := error or (buff1[i] <> buff2[i]);
      if error then writeln('Compare error after block ',startblock,'.');
      docompare := error;
      end; { docompare }
        
    begin { docopy }
    copy_booter;
    startblock := 0;
    repeat
      size := totalblocks - startblock;
      if (size > buffsize) then size := sizeof(buff1)
      else size := size * 512;
      retrycount := 0;
      repeat
        write('Copying block ',startblock:4,'    ');
        for i := 1 to 22 do write(chr(bs));
        doread(size,startblock);
        dowrite(size,startblock);
        error := docompare(size,startblock);
        { true if error on compare }
        if error then writeln('Retrying copy starting at block ',startblock);
        retrycount := retrycount + 1;
        until not error or (retrycount > readretries);
      if error then begin
        writeln; writeln('Unable to copy due to unrecoverable errors.');
        exit(docopy);
        end;
      startblock := startblock + buffsize;
      until (startblock > totalblocks);
    writeln;
    writeln('Copy completed successfully.');
    end; { docopy }
    
  begin
  repeat
    writeln('Copy/Verify Utility.  Written by Jon Bondy, 1/81.');
    writeln('Place disk to be copied in Unit 4; new copy disk in Unit 5.');
    write('Press <CR> to start copying');
    readln(ch);
    unitread(source,dir,sizeof(dir),2); { read in directory }
    if (length(dir.volid) <= 7) then writeln('Copying Volume ',dir.volid)
    else writeln('Source diskette is not a UCSD Volume.');
    totalblocks := dir.eovblk;
    write('Copy ',totalblocks,' blocks? ');
    read(ch); writeln;
    if (ch <> 'y') and (ch <> 'Y') then begin
      repeat
        write('How many blocks do you want to copy? ');
        {$I-} readln(totalblocks); {$I+}
        until (ioresult = 0);
      end;
    unitread(dest,dir,sizeof(dir),2); { read directory }
    if (length(dir.volid) <= 7) then begin
      write('Is it OK to destroy volume ',dir.volid,': ? ');
      read(ch); writeln;
      if (ch = 'y') or (ch = 'Y') then docopy;
      end
    else { not valid UCSD Volume } docopy;
    write('Do you wish to make another copy? ');
    read(ch); writeln;
    until (ch = 'n') or (ch = 'N');
  write('Press <CR> when system disk is in Unit 4 again.');
  readln(ch);
  end.



========================================================================================
DOCUMENT :usus Folder:VOL14:crosses.gpat
========================================================================================

+-----------------------------------------------------------------------------+||                                                                             ||| +   +   +   +   +   +   +                                      +   +   +    |||   +   +   +   +   +   +   +                                      +   +   +  ||| +   +   +   +   +   +   +   +                                      +   +    |||   +   +   +   +   +   +   +   +                                      +   +  ||| +   +   +   +   +   +   +   +   +                                      +    |||   +   +   +   +   +   +   +   +   +                                      +  ||| +   +   +   +   +   +   +   +   +   +                                       |||   +   +   +   +   +   +   +   +   +   +                                     ||| +   +   +   +   +   +   +   +   +   +   +                                   |||   +   +   +   +   +   +   +   +   +   +   +                                 ||| +   +   +   +   +   +   +   +   +   +   +   +                               |||   +   +   +   +   +   +   +   +   +   +   +   +                             ||| +   +   +   +   +   +   +   +   +   +   +   +   +                           |||   +   +   +   +   +   +   +   +   +   +   +   +   +                         ||| +   +   +   +   +   +   +   +   +   +   +   +   +   +                       |||   +   +   +   +   +   +   +   +   +   +   +   +   +   +                     ||| +   +   +   +   +   +   +   +   +   +   +   +   +   +   +                   |||   +   +   +   +   +   +   +   +   +   +   +   +   +   +   +                 ||| +   +   +   +   +   +   +   +   +   +   +   +   +   +   +   +               |||                                                                             ||+-----------------------------------------------------------------------------+|                                                                                                                                                                                                                +-----------------------------------------------------------------------------+||                                                                             |||                -------- ---------------- -------                            |||            |                                     |            
========================================================================================
DOCUMENT :usus Folder:VOL14:dayofwk.text
========================================================================================

{Program Author:   Walter Hess
                   1460 Seven Pines Rd.
                   Schaumberg, IL 60193
                   
Assumes H19 CRT}

PROGRAM DAYOFWK;
{Version "A"  W.I.H.  1/30/80}

CONST
  {The Gregorian Calendar was adopted in the U.S. in 1752}
  STARTYR = 1753;
  STARTDAY = 1;

TYPE
  SHINT = 0..255;

VAR
  MONTH,DATE : SHINT;
  DAY,YEAR,J : INTEGER;

PROCEDURE CALCDAY;

BEGIN
  DAY := STARTDAY;
  FOR J := STARTYR TO YEAR - 1 DO
    IF ((J MOD 4 = 0) AND (J MOD 100 <> 0)) OR (J MOD 400 = 0)
      THEN DAY := DAY + 2
      ELSE DAY := DAY + 1;
  CASE MONTH OF
    1: ;
    2: DAY := DAY + 31;
    3: DAY := DAY + 59;
    4: DAY := DAY + 90;
    5: DAY := DAY + 120;
    6: DAY := DAY + 151;
    7: DAY := DAY + 181;
    8: DAY := DAY + 212;
    9: DAY := DAY + 243;
    10: DAY := DAY + 273;
    11: DAY := DAY + 304;
    12: DAY := DAY + 334;
  END; {Case}
  IF (MONTH > 2) AND (((YEAR MOD 4 = 0) AND (YEAR MOD 100 <> 0)) 
                                                      OR (YEAR MOD 400 = 0))
    THEN DAY := DAY + 1;
  DAY := DAY + DATE - 1;
  DAY := DAY MOD 7;
END; {Calcday}

BEGIN {Dayofwk}
  WRITELN('PROGRAM WILL CALCULATE THE DAY OF THE WEEK ANY DATE FALLS ON');
  WRITELN('FROM JANUARY 1, 1800 ON. ENTER "0" FOR YEAR TO TERMINATE.');
  WRITELN('ENTER MONTH AS 1 TO 12 FOR JANUARY TO DECEMBER');
  WRITELN;
  WRITE(CHR(27),'u');
  REPEAT
    WRITE('ENTER YEAR    ');
    READLN(YEAR);
    IF YEAR >= STARTYR 
      THEN
        BEGIN
          REPEAT
            WRITE('ENTER MONTH   ');
            READLN(MONTH);
          UNTIL (MONTH > 0 ) AND (MONTH < 13);
          REPEAT
            WRITE('ENTER DATE    ');
            READLN(DATE);
          UNTIL (DATE > 0) AND (DATE < 32);
          CALCDAY;
          WRITELN;
          WRITE('  IN ',YEAR);
          CASE MONTH OF
            1: WRITE(' JANUARY ');
            2: WRITE(' FEBRUARY ');
            3: WRITE(' MARCH ');
            4: WRITE(' APRIL ');
            5: WRITE(' MAY ');
            6: WRITE(' JUNE ');
            7: WRITE(' JULY ');
            8: WRITE(' AUGUST ');
            9: WRITE(' SEPTEMBER ');
            10: WRITE(' OCTOBER ');
            11: WRITE(' NOVEMBER ');
            12: WRITE(' DECEMBER ');
          END; {Case}
          WRITE(DATE,' IS A ');
          CASE DAY OF
            0: WRITELN('SUNDAY');
            1: WRITELN('MONDAY');
            2: WRITELN('TUESDAY');
            3: WRITELN('WEDNESDAY');
            4: WRITELN('THURSDAY');
            5: WRITELN('FRIDAY');
            6: WRITELN('SATURDAY');
          END; {Case}
          WRITELN;
        END;
  UNTIL YEAR = 0;
  WRITE(CHR(27),'z');
END. {Dayofwk}
          

========================================================================================
DOCUMENT :usus Folder:VOL14:default.gpat
========================================================================================

+---------------+------------------------------+------------------------------+||               |                              |                              ||| ------------- | ----------- | -------------- | ---------------------------- |||                             |                |                              ||+----------- | -------------- | ------------  -+-  -------------------------- |||            |                                 |                              ||| ---------- | ----- | --------------- | ----- | -----------------------------+||                    |                 |                                      ||+------------------- | ------ | ------ | ------------- | ---------------------+||                             |                        |                      ||+------------   ------------- | --------+------------- | -------------------- |||             |                         |                                     ||| +---+ --+---+---+---+-- +---+-+-----+ | --+-----+-----+-----+-----+-----+-- ||| |   |   |   |   |   |   |   | |     |     |     |     |     |     |     |   ||| | | | | | | | | | | | | | | |   +       + |    +   +     +    +    +    |   ||| | | | | | | | | | | | | | | |    +    +      +       +   +     +     +      ||| | | | | | | | | | | | | | | | +    +    +    +     +    +   +    +    +    -+|| | | | | | | | | | | | | | | |  +     +     +     +     +     +     +     +  ||| | | | | | | | | | | | | | | +-    +    +    +        +     +    +    +    + |||   |   |   |   |   |   |   | | +     +     +      +     +    +     +     +   ||| --+---+-- | --+---+---+---+ |    +    +    +    |    +    +    +    +    +  |||           |               |   |     |     |     |     |     |     |     |   ||+-------------------------------+-----+-----+-----+-----+-----+-----+-----+---+|                                                                                                                                                                                                                +-----------------------------------------------------------------------------+||                                                                             ||| +   +   +   +   +   +   +                                      +   +   +    |||   +   +   +   +   +   +   +                                      +   +   +  ||| +   +   +   +   +   +   +   +                                      +   +    |||   +   +   +   +   +   +   +   +                                      +   +  ||| +   +   +   +   +   +   +   + 
========================================================================================
DOCUMENT :usus Folder:VOL14:fastread.text
========================================================================================


{ FASTREAD - fast text file string read for UCSD pascal. }
{            dhd - PCD Systems, Inc.                     }

unit fastread;
  interface

{ file control block }
  
const
  bufsiz = 1024;
  linemax = 255;

type
  lineindex =   0..linemax;
  longstring =  string[linemax];
  ffile =       file;
  fcb = 
    record
      inlfn:    string[30];     { input file name }
      line:     longstring;     { current text line }
      bpos:     integer;        { buffer position }
      endfile:  boolean;        { true when end of file }
      buf:      packed array[0..bufsiz] of char;
      blknr:    integer;
    end;
  
  procedure getstring(var phyle: fcb; var infile: ffile; var s: longstring);
  procedure openfile(var phyle: fcb; var infile: ffile; var lfn: string);
    
implementation
  const
    cr = 13;
  
  procedure openfile{var phyle: fcb; var infile: ffile; var lfn: string};
  begin { openfile }
    with phyle do
      begin
        reset(infile, lfn);
        inlfn := lfn;
        line := '';
        bpos := bufsiz + 1;
        endfile := false;
        blknr := 2;
      end;
  end;  { openfile }
  
  procedure getstring{var phyle: fcb; var infile: ffile; var s: longstring};
    const
      dle = 16;
    var bcnt, chg: integer;
  begin { getstring } {$R- disable string range checks }
    with phyle do
      repeat
        if bpos >= bufsiz then { time for next buffer }
          begin bcnt := blockread(infile, buf[0], 2, blknr);
            bpos := 0; blknr := blknr + bcnt;
            if bcnt < 2 then { eof }
              begin endfile := true; EXIT(getstring) end;
          end;
        chg := scan(bufsiz-bpos, =chr(cr), buf[bpos]);
        if (bpos + chg) < bufsiz then { found a carriage return }
          begin moveleft(buf[bpos], S[1], chg);    { copy string except CR }
            S[0] := chr(chg); bpos := bpos + chg + 1;
          end
        else
          begin chg := scan(bufsiz-bpos, =chr(0), buf[bpos]); { look for null }
            if (bpos + chg) < bufsiz then
              begin moveleft(buf[bpos], S[1], chg-1); 
                S[0] := chr(chg); bpos := bufsiz;
              end;
          end;
      until chg > 0;
    if length(s) > 2 then
      if s[1] = chr(dle) then { insert leading blanks }
        begin chg := ord(s[2])-32;
          if chg > 2 then
            moveright(s[3], s[chg+1], length(s)-2)
          else
            moveleft (s[3], s[chg+1], length(s)-2);
          fillchar(s[1], chg, ' ');
          s[0] := chr(length(s)+chg-2);
        end;
  end;  { getstring } {$R+}
  
end. { of unit }
  

========================================================================================
DOCUMENT :usus Folder:VOL14:game.assem.text
========================================================================================

        .FUNC   PORTREAD,1      ;PARAM IS PORT NUMBER
        POP     IX              ;RETURN ADDRESS
        POP     IY              ;POP TWO WORDS OF ZEROS
        POP     IY              ;POP TWO WORDS OF ZEROS
        POP     BC              ;PORT NUMBER
        IN      E,(C)           ;READ PORT
        LD      D,0
        PUSH    DE
        JP      (IX)
        
        .END


========================================================================================
DOCUMENT :usus Folder:VOL14:game.text
========================================================================================

(*$S+*)
program game;
   (* This is a game by Jon Bondy.  I think it needs some work. I got it 
      to run on my H-89, but it seemed to ignore many of the movement 
      commands and I lost every time, oh well.  You will have to install your
      own keyboard status routine, Jon provides one of his own and I provide
      one for the H-89.  gws*)
   const
      { lengths }
      l_line = 78;
      l_screen = 23;
      home_x = 0;
      home_y = 1;

      { cursor direction keys as ORDs }
      ord_up = 116;        { t }
      ord_down = 118;      { v }
      ord_right = 103;     { g }
      ord_left = 102;      { f }
      { obstacles as ORDs }
      ord_horiz = 45;      { - }
      ord_vert = 124;      { | }
      ord_intersect = 43;  { + }
      { misc chars in ORD form }
      ord_uc_i = 73;       { I }
      ord_lc_i = 105;      { i }
      ord_uc_q = 81;       { Q }
      ord_lc_q = 113;      { q }
      ord_uc_h = 72;       { H }
      ord_lc_h = 104;      { h }
      ord_uc_m = 77;       { M }
      ord_lc_m = 109;      { m }
      ord_0 = 48;          { 0 }
      ord_1 = 49;          { 1 }
      ord_2 = 50;          { 2 }
      ord_3 = 51;          { 3 }
      ord_4 = 52;          { 4 }
      ord_5 = 53;          { 5 }
      ord_6 = 54;          { 6 }
      ord_7 = 55;          { 7 }
      ord_8 = 56;          { 8 }
      ord_9 = 57;          { 9 }
      ord_space = 32;
   
      max_demons = 9;
      
      { obstacles as CHARs }
      empty = ' ';
      v_wall = '|';
      h_wall = '-';
      intersect = '+';
      { demons/players as CHARs }
      demon = 'D';
      player = 'P';
   
   type
      t_obstacle = char;
      t_line = packed array [home_x..l_line] of t_obstacle;
   
   var
      pattern : file of t_line;
      board : array[home_y..l_screen] of t_line;
      old_random : integer;
      ch : char;
      i : integer;
      { location of player }
      player_x, player_y : integer;
      { used in delay loop to slow down game }
      speed_control : integer; 
      num_demons, num_live_demons : integer;
      { starts at 1: game over when decreased to 0 }
      num_players : integer; 
      { demon mode }
      demon_motion : (inertial_demon, heat_seeking_demon);
      demon_data : array[1..max_demons] of record
         { current position }
         x, y : integer;
         { current direction (inertial mode only): a cursor character }
         direction : char;
         alive : boolean;
         end;
      
   procedure eeoln;
      begin
      write(chr(27), 'K');  {H-19 specific   gws}
      end; { eeoln }
      
   function random : integer; { procedure }
      begin
      random := old_random;
      old_random := ((old_random * 32761) + 13) mod 32717;
      end; { random }
      
   procedure clear_board;
      var
         x, y : integer;
      begin
      { board is empty... }
      fillchar(board, sizeof(board), ord(empty));
      { ...with boarders established as walls }
      for x := home_x to l_line do begin
         board[home_y,x] := h_wall;
         board[l_screen,x] := h_wall;
         end;
      for y := home_y to l_screen do begin
         board[y,home_x] := v_wall;
         board[y,l_line] := v_wall;
         end;
      board[home_y,home_x] := intersect;
      board[home_y,l_line] := intersect;
      board[l_screen,home_x] := intersect;
      board[l_screen,l_line] := intersect;
      end;
      
   procedure show_board;
      var
         y, length : integer;
      begin
      gotoxy(home_x, home_y);
      length := l_line - home_x + 1;
      for y := home_y to l_screen do begin
         unitwrite(1,board[y],length);
         if (y <> l_screen) then writeln;
         end; { for y }
      gotoxy(home_x, home_y);
      end; { show_board }
      
   procedure go_prev_dir(prev_dir : char; var x, y : integer);
      { modify x,y so that motion continues in direction used last }
      begin
      case ord(prev_dir) of
         ord_up : if (y > home_y) then y := y - 1;
         ord_down : if (y < l_screen) then y := y + 1;
         ord_left : if (x > home_x) then x := x - 1;
         ord_right : if (x < l_line) then x := x + 1; 
         end; { case }
      end; { go_prev_dir }
      
   procedure edit;
      var
         x, y : integer;
         ch, prev_dir : char;
      begin
      gotoxy(0,0); eeoln;
      write('Edit: up, down, left, right, "-", "|", "+", " ", I(nit, Q(uit');
      x := home_x; y := home_y; prev_dir := chr(ord_right);
      repeat
         gotoxy(x,y);
         read(keyboard,ch);
         case ord(ch) of
            ord_up : begin 
               if (y > home_y) then y := y - 1; prev_dir := ch; end;
            ord_down : begin 
               if (y < l_screen) then y := y + 1; prev_dir := ch; end;
            ord_left : begin 
               if (x > home_x) then x := x - 1; prev_dir := ch; end;
            ord_right : begin 
               if (x < l_line) then x := x + 1; prev_dir := ch; end;
            ord_horiz : begin 
               board[y,x] := h_wall; write('-'); 
               go_prev_dir(prev_dir,x,y); 
               end;
            ord_vert : begin 
               board[y,x] := v_wall; write('|'); 
               go_prev_dir(prev_dir,x,y); 
               end;
            ord_intersect : begin 
               board[y,x] := intersect; write('+'); 
               go_prev_dir(prev_dir,x,y); 
               end;
            ord_space : begin 
               board[y,x] := empty; write(' '); 
               go_prev_dir(prev_dir,x,y); end;
            ord_lc_i, ord_uc_i : begin
               clear_board; show_board;
               end;
            end; { case }
         until (ch = 'q') or (ch = 'Q');
      end; { edit }
      
   procedure put_pattern;
      var
         fname : string;
         y : integer;
      begin
      gotoxy(0,0); eeoln;
      write('Write pattern to what file name (".GPAT" assumed) ? ');
      readln(fname);
      if (length(fname) > 0) then begin
         {$I-}
         rewrite(pattern,concat(fname,'.gpat'));
         {$I+}
         if (ioresult = 0) then begin
            for y := home_y to l_screen do begin
               pattern^ := board[y]; put(pattern); end;
            close(pattern,lock);
            gotoxy(0,0); eeoln;
            write('File written successfully.');
            { delay to allow message to be read }
            for y := 1 to 800 do begin end; 
            end;
         end;
      end; { put_pattern }
        
   procedure get_pattern;
      var
         fname : string;
         y : integer;
      begin
      gotoxy(0,0); eeoln;
      write('Read pattern from what file name (".GPAT" assumed) ? ');
      readln(fname);
      if (length(fname) > 0) then begin
         {$I-}
         reset(pattern,concat(fname,'.gpat'));
         {$I+}
         if (ioresult = 0) then
            for y := home_y to l_screen do begin
               board[y] := pattern^; get(pattern); end
         else clear_board;
         show_board;
         close(pattern);
         end;
      end; { get_pattern }
       
   procedure setup;
      var
         ch : char;
      begin
      repeat
        gotoxy(0,0); eeoln;
        write('Setup: E(dit, G(et, P(ut, S(how, N(umdemons, Q(uit : ');
        read(keyboard,ch);
        case ch of
           'e','E' : edit;
           'g','G' : get_pattern;
           'p','P' : put_pattern;
           's','S' : show_board;
           'n','N' : begin
              gotoxy(0,0); eeoln; write('Enter number of demons: '); read(ch); 
              if (ch in ['1'..'9']) then num_demons := ord(ch) - ord('0');
              ch := ' '; end;
           'q','Q' : begin end;
           end; { case }
        until (ch = 'q') or (ch = 'Q');
      end; { setup }
      
   (*function portread(port : integer) : integer; external; { procedure }*)
   function kbstat : boolean; external;  {my own keyboard status routine
                                                for an H-89}
   function key_hit : boolean; { procedure }
      begin
      {key_hit := odd(portread(0) div 2);}
      key_hit := kbstat;
      end; { key_hit }
   
   procedure update_board(x,y : integer; token : t_obstacle);
      begin
      gotoxy(x,y); write(token); gotoxy(0,0);
      board[y,x] := token;
      end; { update_board }
      
   procedure kill_demon(x_input,y_input : integer);
      var
         i : integer;
      begin
      for i := 1 to max_demons do with demon_data[i] do begin
         if alive and (x = x_input) and (y = y_input) then
            begin
            alive := false;
            num_live_demons := num_live_demons - 1;
            update_board(x,y,empty);
            gotoxy(70,0); write('Demons: ', num_live_demons);
            end;
         end;
      end; { kill_demon }
      
   procedure hyperspace(var x, y : integer; token : t_obstacle);
      { put "token" in random board position and return position in x/y }
      var
         done : boolean;
      begin
      done := false; update_board(x,y,empty);
      repeat
         x := random mod l_line; y := (random mod (l_screen - 1)) + 1;
         if (board[y,x] = empty) then begin
            update_board(x,y,token);
            done := true;
            end;
         until done;
      end; { hyperspace }
      
   procedure move_player(var quit : boolean);
      var
         ch : char;
         board_element : t_obstacle;
      begin
      read(keyboard,ch);
      update_board(player_x, player_y, empty);
      case ord(ch) of
         ord_right : begin
            board_element := board[player_y,player_x+1];
            if (board_element = empty) then player_x := player_x + 1
            else if (board_element = demon) then begin
               player_x := player_x + 1;
               kill_demon(player_x,player_y);
               end;
            end;
         ord_left : begin
            board_element := board[player_y,player_x-1];
            if (board_element = empty) then player_x := player_x - 1
            else if (board_element = demon) then begin
               player_x := player_x - 1;
               kill_demon(player_x,player_y);
               end;
            end;
         ord_up : begin
            board_element := board[player_y-1,player_x];
            if (board_element = empty) then player_y := player_y - 1
            else if (board_element = demon) then begin
               player_y := player_y - 1;
               kill_demon(player_x,player_y);
               end;
            end;
         ord_down : begin
            board_element := board[player_y+1,player_x];
            if (board_element = empty) then player_y := player_y + 1
            else if (board_element = demon) then begin
               player_y := player_y + 1;
               kill_demon(player_x,player_y);
               end;
            end;
         ord_lc_q, ord_uc_q : quit := true;
         ord_lc_h, ord_uc_h : hyperspace(player_x, player_y, player);
         ord_lc_m, ord_uc_m : if (demon_motion = inertial_demon) then
            demon_motion := heat_seeking_demon
            else demon_motion := inertial_demon;
         ord_0 : speed_control := 0;
         ord_1 : speed_control := 10;
         ord_2 : speed_control := 20;
         ord_3 : speed_control := 30;
         ord_4 : speed_control := 40;
         ord_5 : speed_control := 50;
         ord_6 : speed_control := 60;
         ord_7 : speed_control := 70;
         ord_8 : speed_control := 80;
         ord_9 : speed_control := 90;
         end; { case }
      update_board(player_x,player_y,player); 
      end; { move_player }
      
   procedure change_direction(x,y : integer; var direction : char);
      { when an inertial demon hits something, this routine figurs out
        what direction to send him in next }
      var
         new_direction : char;
         num_free_directions : integer;
         empty_player : set of t_obstacle;
      begin
      num_free_directions := 0; empty_player := [empty,player];
      { determine what directions are possible -- establish "new_direction"
        in case there is only one such }
      if (board[y-1,x] in empty_player) then begin
         num_free_directions := num_free_directions + 1;
         new_direction := chr(ord_up);
         end;
      if (board[y+1,x] in empty_player) then begin
         num_free_directions := num_free_directions + 1;
         new_direction := chr(ord_down);
         end;
      if (board[y,x+1] in empty_player) then begin
         num_free_directions := num_free_directions + 1;
         new_direction := chr(ord_right);
         end;
      if (board[y,x-1] in empty_player) then begin
         num_free_directions := num_free_directions + 1;
         new_direction := chr(ord_left);
         end;
      if (num_free_directions > 1) then begin
         { there is more than one possible new direction: select randomly }
         new_direction := empty;
         repeat
            case (random mod 4) of
               0 : if (board[y-1,x] in empty_player) then
                  if (direction <> chr(ord_down)) then
                  new_direction := chr(ord_up);
               1 : if (board[y+1,x] in empty_player) then
                  if (direction <> chr(ord_up)) then
                  new_direction := chr(ord_down);
               2 : if (board[y,x-1] in empty_player) then
                  if (direction <> chr(ord_right)) then
                  new_direction := chr(ord_left);
               3 : if (board[y,x+1] in empty_player) then
                  if (direction <> chr(ord_left)) then
                  new_direction := chr(ord_right);
               end; { case }
            until (new_direction <> empty);
         end; { if }
      direction := new_direction;
      end; { change_direction }
      
      
      (*$I game1.text*)
      

========================================================================================
DOCUMENT :usus Folder:VOL14:game1.text
========================================================================================

   (* included from game.text*)
   procedure init_play;
      var
         i : integer;
      begin
      num_players := 1; player_x := home_x + 1; player_y := home_y + 1; 
      hyperspace(player_x, player_y, player); { position randomly }
      num_live_demons := num_demons;
      for i := 1 to num_live_demons do with demon_data[i] do begin
      { position randomly }
         x := home_x + 1; y := home_y + 1; hyperspace(x,y,demon);
         { establish initial inertial direction randomly }
         direction := empty; change_direction(x,y,direction);
         alive := true;
         end;
      { "kill" the other demons }
      for i := (num_live_demons + 1) to max_demons do
         demon_data[i].alive := false;
      gotoxy(70,0); write('Demons: ', num_live_demons);
      end; { init_play }
      
   procedure kill_player;
      begin
      num_players := num_players - 1;
      end; { kill_player }
   
   function demon_right(var x,y : integer) : boolean;
      { try to move demon right: return true if successful }
      var
         board_element : t_obstacle;
      begin
      demon_right := true;
      board_element := board[y,x+1];
      if (board_element = empty) then x := x + 1
      else if (board_element = player) then begin
         x := x + 1; kill_player; end
      else if (board_element = demon) then hyperspace(x,y,demon)
      else demon_right := false;
      end; { demon_right }
   
   function demon_left(var x,y : integer) : boolean;
      { try to move demon left: return true if successful }
      var
         board_element : t_obstacle;
      begin
      demon_left := true;
      board_element := board[y,x-1];
      if (board_element = empty) then x := x - 1
      else if (board_element = player) then begin
         x := x - 1; kill_player; end
      else if (board_element = demon) then hyperspace(x,y,demon)
      else demon_left := false;
      end; { demon_left }
   
   function demon_up(var x,y : integer) : boolean;
      { try to move demon up: return true if successful }
      var
         board_element : t_obstacle;
      begin
      demon_up := true;
      board_element := board[y-1,x];
      if (board_element = empty) then y := y - 1
      else if (board_element = player) then begin
         y := y - 1; kill_player; end
      else if (board_element = demon) then hyperspace(x,y,demon)
      else demon_up := false;
      end; { demon_up }
   
   function demon_down(var x,y : integer) : boolean;
      { try to move demon down: return true if successful }
      var
         board_element : t_obstacle;
      begin
      demon_down := true;
      board_element := board[y+1,x];
      if (board_element = empty) then y := y + 1
      else if (board_element = player) then begin
         y := y + 1; kill_player; end
      else if (board_element = demon) then hyperspace(x,y,demon)
      else demon_down := false;
      end; { demon_down }
   
   procedure move_same_direction(demon_num : integer);
      { move demon inertially }
      begin
      with demon_data[demon_num] do begin
         update_board(x,y,empty);
         case ord(direction) of
            ord_right : if not demon_right(x,y) then begin
               change_direction(x,y,direction); 
               move_same_direction(demon_num); 
               end;
            ord_left : if not demon_left(x,y) then begin
               change_direction(x,y,direction); 
               move_same_direction(demon_num); 
               end;
            ord_up : if not demon_up(x,y) then begin
               change_direction(x,y,direction); 
               move_same_direction(demon_num); 
               end;
            ord_down : if not demon_down(x,y) then begin
               change_direction(x,y,direction); 
               move_same_direction(demon_num); 
               end;
            end; { case }
         update_board(x,y,demon);
         end; { with }
      end; { move_same_direction }
      
   procedure move_towards_player(demon_num : integer);
      { move demon towards player }
      var
         index : integer;
         trash : boolean;
      begin
      with demon_data[demon_num] do begin
         update_board(x,y,empty);
         index := 0;
         { right two quadrants }
         if (player_x > x) then index := index + 1
         { vertically adjacent }
         else if (player_x = x) then index := index + 2;
         { upper two quadrants }
         if (player_y > y) then index := index + 4
         { horizontally adjacent }
         else if (player_y = y) then index := index + 8;
         { angle is between +/- 45 degrees or between 135 and 225 degrees }
         if (abs(player_x - x) > abs(player_y - y)) then index := index + 16;
         case index of
            0 : if not demon_up(x,y) then trash := demon_left(x,y);
            1 : if not demon_up(x,y) then trash := demon_right(x,y);
            2 : if not demon_up(x,y) then 
                if not demon_right(x,y) then trash := demon_left(x,y);
            4 : if not demon_down(x,y) then trash := demon_left(x,y);
            5 : if not demon_down(x,y) then trash := demon_right(x,y);
            6 : if not demon_down(x,y) then
                if not demon_left(x,y) then trash := demon_right(x,y);
            16 : if not demon_left(x,y) then trash := demon_up(x,y);
            17 : if not demon_right(x,y) then trash := demon_up(x,y);
            20 : if not demon_left(x,y) then trash := demon_down(x,y);
            21 : if not demon_right(x,y) then trash := demon_down(x,y);
            24 : if not demon_left(x,y) then 
                 if not demon_down(x,y) then trash := demon_up(x,y);
            25 : if not demon_right(x,y) then 
                 if not demon_down(x,y) then trash := demon_up(x,y);
            3, 7, 8, 9, 10, 11, 12, 13, 14, 15, 18, 19, 22, 23, 26 :
             writeln('case selector error ', index);
            end; { case }
         update_board(x,y,demon);
         end; { with }
      end; { move_towards_player }
      
   procedure move_demon(demon_num : integer);
      begin
      case demon_motion of
         inertial_demon : move_same_direction(demon_num);
         heat_seeking_demon : move_towards_player(demon_num);
         end; { case }
      end; { move_demon }
   
   procedure play_game;
      var
         quit : boolean;
         i, demon_num : integer;
         ch : char;
      begin
      gotoxy(0,0); eeoln;
      write('Play: up, down, right, left, H(yper, M(ode, 0..9=Level, Q(uit');
      quit := false;
      init_play;
      demon_num := 0;
      repeat
         { delay if necessary for slow player }
         for i := 1 to speed_control do begin end;
         if key_hit then move_player(quit);
         repeat
            demon_num := demon_num + 1; 
            if (demon_num > max_demons) then demon_num := 1;
            if demon_data[demon_num].alive then move_demon(demon_num);
            until demon_data[demon_num].alive or (num_live_demons = 0);
         until (num_live_demons = 0) or (num_players = 0) or quit;
      if key_hit then read(keyboard,ch);
      gotoxy(0,0); eeoln;
      if (num_live_demons = 0) then write('Congratulations: you win!')
      else if (num_players = 0) then write('Too bad: the Demons gotcha!');
      update_board(player_x,player_y,empty);
      for i := 1 to max_demons do with demon_data[i] do
         if alive then update_board(x,y,empty);
      if not quit then 
         for i := 1 to 4500 do begin end; { delay }
      end; { play_game }
   
   procedure initialize;
      var
         y : integer;
      begin
      writeln('Video Game Program. Jon Bondy. 11/81.');
      for y := 1 to 800 do begin end;
      old_random := 13157;
      {$I-}
      reset(pattern,'default.gpat');
      {$I+}
      if (ioresult <> 0) then clear_board
      else for y := home_y to l_screen do begin
        board[y] := pattern^; get(pattern); end;
      show_board;
      close(pattern);
      num_demons := 5;
      demon_motion := inertial_demon;
      speed_control := 50;
      end; { initialize }
   
   begin { game }
   initialize;
   repeat
      gotoxy(0,0); eeoln;
      write('GAME: S(etup, demon M(ode');
      if (demon_motion = inertial_demon) then write('(I)')
      else if (demon_motion = heat_seeking_demon) then write('(H)');
      write(', L(evel(', speed_control div 10,'), P(lay, Q(uit : ');
      repeat
         i := random; { more randomness! }
         until key_hit;
      read(ch);
      case ch of
         's','S' : setup;
         'm','M' : if (demon_motion = inertial_demon) then
            demon_motion := heat_seeking_demon
            else demon_motion := inertial_demon;
         'l','L' : begin
            gotoxy(0,0); eeoln; write('Enter level (0..9) [9 is slowest] : ');
            repeat read(ch) until (ch in ['0'..'9']);
            speed_control := (ord(ch) - ord('0')) * 10;
            end;
         '0' : speed_control := 0;
         '1' : speed_control := 10;
         '2' : speed_control := 20;
         '3' : speed_control := 30;
         '4' : speed_control := 40;
         '5' : speed_control := 50;
         '6' : speed_control := 60;
         '7' : speed_control := 70;
         '8' : speed_control := 80;
         '9' : speed_control := 90;
         'p','P' : play_game;
         'q','Q' : begin end;
         end; { case }
      until (ch = 'q') or (ch = 'Q');
   end. { game }


========================================================================================
DOCUMENT :usus Folder:VOL14:hexdump.text
========================================================================================

PROGRAM dump;                                                                                                                                                                   
 LABEL 0,1,2,3;
 VAR disk: FILE OF  
            RECORD
             buffer : PACKED ARRAY[1..512] OF CHAR;
            END;
     disk2: FILE OF 
             RECORD
              buffer2 : PACKED ARRAY[1..2] OF CHAR;
             END;   
     sblock,linumber,nblocks,chrnumber,recnumber,temp,rec: INTEGER;   
     chrs : PACKED ARRAY[1..65] OF CHAR;
     ch : CHAR;
     infilename,outfilename : STRING[20];  
     tinput,scrfilname : STRING[20]; 
     tchrs,fchrs : STRING; 
         
(*$G+*) 

FUNCTION val (instr : STRING) : INTEGER;    
 VAR temp,chrat,fin : INTEGER;                                                                           
     nchrs : PACKED ARRAY[1..10] OF CHAR;                          
 BEGIN  
  val := 0;fin := 0;chrat := 0;nchrs := '0123456789'; 
  REPEAT   
   chrat := chrat + 1;temp := SCAN(10,=instr[chrat],nchrs);                 
   IF temp < 10 THEN
    BEGIN                  
     fin := fin * 10;fin := fin + temp;                                  
    END; 
  UNTIL (chrat = LENGTH(instr)) OR (chrat=6);   
  val := fin;            
 END;
 
 

PROCEDURE blank; 
 BEGIN
  WITH disk2^ DO 
   BEGIN
    buffer2 := '  '; PUT(disk2);     
   END;
 END;
 
PROCEDURE return;  
 BEGIN
  WITH disk2^ DO
   BEGIN
    buffer2[1] := CHR(00); buffer2[2] := CHR(13); PUT(disk2);
   END;
 END;
 
PROCEDURE header; 
 BEGIN
  chrs := '0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ. abcdefghijklmnopqrstuvwxyz:'; 
  fchrs := '0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ. abcdefghijklmnopqrstuvwxyz:';   
  scrfilname := '#2:                 ';                    
  WITH disk2^ DO 
  BEGIN {WITH}
   FOR temp := 1 to 12 DO blank; 
   FOR temp := 1 to 10 DO                              
    BEGIN
     buffer2 := '  '; tchrs := ' ';   
     tchrs := COPY(infilename,(temp*2-1),1);  
     IF POS(tchrs,fchrs)<>0 THEN buffer2[1] := chrs[POS(tchrs,fchrs)];
     tchrs := COPY(infilename,(temp*2),1);   
     IF POS(tchrs,fchrs)<>0 THEN buffer2[2] := chrs[POS(tchrs,fchrs)];   
     PUT(disk2);  
    END;
    return;
   FOR temp := 1 to 13 DO blank;  
   temp := recnumber + 1;buffer2 := 'Bl';PUT(disk2);     
   buffer2 := 'oc';PUT(disk2);buffer2 := 'k:';PUT(disk2); blank; 
   buffer2[1] := chrs[((recnumber+1) DIV 10)+1]; 
   buffer2[2] := chrs[((recnumber+1) MOD 10)+1];     
   PUT(disk2);return;return;blank;blank;chrnumber := 0;
   REPEAT
    BEGIN
     chrnumber := chrnumber + 1;buffer2[1] := chrs[chrnumber];   
     buffer2[2] := ':';PUT(disk2);blank; 
    END;
   UNTIL chrnumber=16;
   return;chrnumber := 0;buffer2 := '--';            
   REPEAT 
    BEGIN
     chrnumber := chrnumber + 1;PUT(disk2); 
    END;
   UNTIL chrnumber=34;  
   return;buffer2 := '0:';PUT(disk2);blank; 
  END {WITH};   
 END {header}; 
 
BEGIN {dump} 
 3:WRITE('Output filename -----> ');
 READLN (outfilename);
 IF LENGTH(outfilename)=0 THEN outfilename := '#2:';  
 REWRITE(disk2,outfilename);
 SEEK(disk2,0);
 1:WRITE ('Input filename -----> ');        
 READLN (infilename);   
 IF LENGTH(infilename)=0 THEN infilename := 'SYSTEM.WRK.CODE';
 RESET(disk,infilename);
 2:WRITE ('Starting Block -----> ');
 READLN (tinput);   
 IF LENGTH(tinput)=0 THEN sblock:=0 ELSE sblock:=Val(tinput);
 WRITE ('Ending Block -----> ');   
 READLN (tinput);   
 IF LENGTH(tinput)=0 THEN nblocks:=0 ELSE nblocks:=Val(tinput);  
 recnumber := sblock - 1;   
 REPEAT {block} 
  BEGIN {block}
   header; linumber := 0; recnumber := recnumber + 1;  
   SEEK(disk,recnumber); GET(disk); chrnumber := 0; 
    WITH disk^ DO
    REPEAT {chr}
     BEGIN {chr}
      chrnumber := chrnumber + 1;
      WITH disk2^ DO 
       BEGIN {WITH}
        buffer2 := '  '; temp := ORD(buffer[chrnumber]);   
        IF (temp > 255)  THEN GOTO 0;   
        buffer2[1] := chrs[(temp DIV 16)+1]; 
        buffer2[2] := chrs[(temp MOD 16)+1];          
        PUT(disk2);blank;    
       0:IF (chrnumber MOD 16 = 0) THEN   
           BEGIN {THEN}
            linumber := linumber + 1;return; 
            buffer2[1] := chrs[(linumber MOD 16)+1];        
            buffer2[2] := ':';     
            IF chrnumber <> 512 THEN
             BEGIN
              IF outfilename = scrfilname THEN READ(KEYBOARD,ch);
              PUT(disk2);
             END;   
            blank;
           END {THEN};
       END {WITH};    
     END {chr};
    UNTIL chrnumber = 512; 
    WITH disk2^ DO
     BEGIN {WITH} 
      chrnumber := 0; 
      REPEAT 
       IF outfilename <> '#2:' THEN return;   
       chrnumber := chrnumber + 1;    
      UNTIL chrnumber = 29;
     END {WITH};
  END {block};
 UNTIL recnumber = (nblocks);
 WRITE ('Anymore Blocks ? ');     
 READ (ch);WRITELN; IF ch IN ['y','Y'] THEN GOTO 2;  
 CLOSE(disk);
 WRITE ('Anymore Input ? ');
 READ (ch);WRITELN;IF ch IN ['y','Y'] THEN GOTO 1;
 CLOSE(disk2,LOCK);  
 WRITE('Anymore Output? ');READ(ch);
 WRITELN;IF ch IN ['y','Y'] THEN GOTO 3;
END {dump}.

========================================================================================
DOCUMENT :usus Folder:VOL14:home_loan.text
========================================================================================

PROGRAM HOME_LOAN;
VAR A,R,Y,RATE,P,R12,R1,NP,FR,CM,CM1: REAL;

procedure clear_screen;
begin
   write ( chr ( 27 ) , chr ( 69 ) );  {H-19 specific}
end;

FUNCTION INPUT_VALUE:REAL;

{
                                                 function by:  EDWARD J GRUNDLER
}

VAR I:INTEGER;
    INP:STRING;
    DEC,NEX,EX,NEG,OK:BOOLEAN;
    EXPO,J,X:REAL;
BEGIN
  REPEAT
    DEC:=FALSE;
    EX:=FALSE;
    READLN(INP);
    IF LENGTH(INP)=0 THEN INP:='0';
    OK:=NOT(INP[1]='E');
    IF LENGTH(INP)>1 THEN
      OK:=OK AND NOT((INP[1] IN ['+','-','.']) AND (INP[2]='E'));
    FOR I:=1 TO LENGTH(INP) DO
      BEGIN
        OK:=OK AND (INP[I] IN ['.','-','+','E','0'..'9']);
        IF (I>1) AND NOT EX THEN OK:=OK AND (INP[I] IN ['.','E','0'..'9']);
        OK:=OK AND NOT(DEC AND(INP[I]='.'));
        IF NOT DEC THEN DEC:=(INP[I]='.');
        OK:=OK AND NOT(EX AND (INP[I]='E'));
        IF NOT EX THEN EX:=(INP[I]='E');
        IF I>1 THEN
          OK:=OK AND NOT(EX AND (INP[I] IN ['+','-']) AND NOT(INP[I-1]='E'));
        OK:=OK AND NOT(EX AND (INP[I]='.'))
      END;
    OK:=OK AND (INP[LENGTH(INP)] IN ['0'..'9','.']);
    OK:=OK AND NOT(EX AND NOT(INP[LENGTH(INP)] IN ['0'..'9']));
    IF NOT OK THEN WRITE(CHR(31),'READ ERROR, TRY AGAIN ',CHR(29))
  UNTIL OK;
  X:=0;
  DEC:=FALSE;
  EXPO:=0;
  NEG:=FALSE;
  EX:=FALSE;
  J:=1;
  FOR I:=1 TO LENGTH(INP) DO
    BEGIN
      IF NOT DEC THEN DEC:=(INP[I]='.');
      IF NOT NEG THEN NEG:=NOT EX AND (INP[I]='-');
      IF NOT NEX THEN NEX:=EX AND (INP[I]='-');
      IF NOT EX THEN EX:=(INP[I]='E');
      IF EX AND NOT(INP[I] IN ['+','-','E']) THEN
        EXPO:=EXPO*10+ORD(INP[I])-ORD('0');
      IF NOT EX THEN
        BEGIN
          IF DEC AND NOT(INP[I] IN ['.','+','-']) THEN
            BEGIN
              J:=J/10;
              X:=X+(ORD(INP[I])-ORD('0'))*J
            END
          ELSE
            IF NOT(INP[I] IN ['.','+','-']) THEN X:=X*10+ORD(INP[I])-ORD('0')
        END
    END;
  IF EX AND NEX THEN EXPO:=-EXPO;X:=X*EXP(LN(10)*EXPO);
  IF NEG THEN INPUT_VALUE:=-X ELSE INPUT_VALUE:=X
END;

PROCEDURE GET_DATA;
VAR CH: CHAR;
BEGIN
  clear_screen;
  WRITE(' enter Q  to quit or SPACE-BAR to continue');
  READ(KEYBOARD,CH);
  IF CH='Q' THEN EXIT(HOME_LOAN);
  WRITELN;
  WRITE('Amt. of loan = '); A:=INPUT_VALUE;
  WRITE('annual percent interest rate = '); RATE:=INPUT_VALLUE;
  WRITE('Length of loan (years) = '); Y:=INPUT_VALUE;
END; { procedure GET_DATA }
  
PROCEDURE PAYMENT;
  FUNCTION POWER(A,B:REAL):REAL;
  BEGIN POWER:=EXP(B*LN(A)) END;
BEGIN
  R:=RATE/100;
  R12:=R/12;
  P:=A*R12/(1-POWER(1+R12,-12*Y))
END;

PROCEDURE DISPLAY;
VAR YR,MO,NEXTYR: INTEGER;
    BEGBAL,PAYINT,PAYPRIN,ENDBAL,TOTINT,TOTPRIN: REAL;
    CH: CHAR;
BEGIN
  clear_screen;
  WRITELN(' AMT OF LOAN = ',A:12:2);
  WRITELN(' INTEREST RATE = ',RATE:6:2,' PERCENT');
  WRITELN(' LENGHT OF LOAN = ',Y:6:2,' YEARS');
  WRITELN(' MONTHLY PAYMENT = ',P:8:2);
  R1:=RATE/1200+1;
  NP:=12*Y;
  FR:=0.5;
  CM:=NP+LN(1-FR*(1-EXP(-NP*LN(R1))))/LN(R1);
  WRITELN('THE LOAN IS ',(1-FR)*100:5:2,' PERCENT PAID OFF AT ',TRUNC(CM/12)+1,
               ' YEARS ',CM-12*TRUNC(CM/12):5:2,' MONTHS');
  CM1:=NP+LN(0.5)/LN(R1)+1;
  WRITELN('CROSS-OVER PAYMENT : ',TRUNC(CM1/12)+1,' YEARS ',
                CM1-12*TRUNC(CM1/12):5:2,' MONTHS');
  WRITELN('             BEGINNIG  PAYMENT APPLIED TO   ENDING');
  WRITELN(' YEAR MONTH  BALANCE   INTEREST  PRINCIPLE  BALANCE');
  YR:=1; MO:=1; BEGBAL:=A; 
  TOTINT:=0; TOTPRIN:=0;
  GOTOXY(0,8);
  WHILE BEGBAL>0 DO
    BEGIN
      PAYINT:=BEGBAL*R12;
      PAYPRIN:=P-PAYINT;
      ENDBAL:=BEGBAL-PAYPRIN;
      IF (YR=1) OR (YR=Y) OR (YR=NEXTYR) THEN
        begin
          WRITELN(YR:6,MO:6,BEGBAL:10:2,PAYINT:8:2,PAYPRIN:8:2,
                  '    ',ENDBAL:8:2);
          TOTINT:=TOTINT+PAYINT; TOTPRIN:=TOTPRIN+PAYPRIN;
          IF MO=12 THEN
            begin
              WRITELN;
              WRITELN('      TOTAL FOR YEAR  ',TOTINT:8:2,TOTPRIN:8:2);
              WRITE('enter next year you want printed ');
              NEXTYR:=TRUNC(INPUT_VALUE);
              TOTINT:=0; TOTPRIN:=0;
              GOTOXY(0,8)
            end;
        end;
      BEGBAL:=ENDBAL;
      IF MO<12 THEN MO:=MO+1
               ELSE begin MO:=1; YR:=YR+1 END;
    END;
END;


BEGIN { main program HOME_LOAN }
  REPEAT
    GET_DATA;
    PAYMENT;
    DISPLAY
  UNTIL FALSE;
END.


========================================================================================
DOCUMENT :usus Folder:VOL14:kbstat.text
========================================================================================

        .FUNC   KBSTAT,0        ; H-89 dependant keyboard status routine
        .PRIVATE RETADDR        ; reserve space for return address
RECRDY  .EQU    1               ; set up ready bit mask
        POP     HL              ; pop return address
        LD      (RETADDR),HL    ; and save it
        POP     HL              ; pop two words of trash off stack
        POP     HL              ;  second word
        LD      HL,1            ; set condition to ready (true) 
        IN      A,(237)         ; read keyboard line status register (355 octal)
        AND     RECRDY          ; and compare with bit mask (looking for bit 0)
        JP      NZ,DONE         ; branch if ready
        LD      HL,0            ; set condition to false if not ready
DONE    PUSH    HL              ; push condition on stack
        LD      HL,(RETADDR)    ; retrieve return address
        JP      (HL)            ; jump to return address
        .END


========================================================================================
DOCUMENT :usus Folder:VOL14:listinfo.text
========================================================================================


    { $L-remout:}
    (**************************************************************)
    (*                                                            *)
    (*      author:    David Parrish                              *)
    (*                 Medical College of Georgia                 *)
    (*                 Augusta, Georgia  30912                    *)
    (*                                                            *)
    (*      date:      April 30, 1980                             *)
    (*                                                            *)
    (** This program is part of the MCG Pascal utilities library **)
    (*                                                            *)
    (*      system.miscinfo parameter record definition           *)
    (*       by Ronald A. Parsons                                 *)
    (*                                                            *)
    (* defines terminal and screen parameters from the file       *)
    (* produced by setup for ucsd pascal version i.5.             *)
    (* also works for II.0 - gws                                  *)
    (* the following variables are associated with                *)
    (* the setup defined parameter.                               *)
    (* the full name of these variables is minfobuffer.xxxxx      *)
    (* e.g.,                                                      *)
    (*       minfobuffer.screenheight                             *)
    (* or                                                         *)
    (*       with minfobuffer do ... screenheight ... end;        *)
    (*                                                            *)
    (* ----- the following variables are type boolean.            *)
    (* hasclock            has clock                              *)
    (* has8510a            has 8510a                              *)
    (* haslowercase        has lower case                         *)
    (* hasrandom           has random cursor addressing           *)
    (* hasslow             has slow terminal                      *)
    (* student             student                                *)
    (* premcup             prefix [move cursor up]                *)
    (* premcright          prefix [move cursor right]             *)
    (* preereol            prefix [erase to end of line]          *)
    (* preereos            prefix [erase to end of screen]        *)
    (* premchome           prefix [move cursor home]              *)
    (* predcharacter       prefix [delete character]              *)
    (* preerscreen         prefix [erase screen]                  *)
    (* preerline           prefix [erase line]                    *)
    (* prekmcright         prefix [key for moving right]          *)
    (* prekmcleft          prefix [key for moving left]           *)
    (* prekmcup            prefix [key for moving up]             *)
    (* prekmcdown          prefix [key for moving down]           *)
    (* prenonprintchar     prefix [non-printing character]        *)
    (* prekeystop          prefix [key for stop]                  *)
    (* prekeybreak         prefix [key for break]                 *)
    (* prekeyflush         prefix [key for flush]                 *)
    (* prekeyendfile       prefix [key to end file]               *)
    (* preedescapekey      prefix [editor 'escape' key]           *)
    (* prekeydline         prefix [key to delete line]            *)
    (* prekeydcharacter    prefix [key to delete character]       *)
    (* preedacceptkey      prefix [editor 'accept' key]           *)
    (*                                                            *)
    (* ----- the following variables are type integer.            *)
    (* screenheight        screen height                          *)
    (* screenwidth         screen width                           *)
    (*                                                            *)
    (**************************************************************)
    {$P}
    (**************************************************************)
    (*                                                            *)
    (* ----- the follwing variables are type char.                *)
    (* leadintoscreen      lead-in to screen                      *)
    (* movecursorhome      move cursor home                       *)
    (* eraseeos            erase to end of screen                 *)
    (* eraseeol            erase to end of line                   *)
    (* movecright          move cursor right                      *)
    (* movecup             move cursor up                         *)
    (* backspace           backspace                              *)
    (* verticalmdelay      vertical move delay                    *)
    (* eraseline           erase line                             *)
    (* erasescreen         erase screen                           *)
    (* keytomcup           key to move cursor up                  *)
    (* keytomcdown         key to move cursor down                *)
    (* keytomcleft         key to move cursor left                *)
    (* keytomcright        key to move cursor right               *)
    (* keytoendfile        key to end file                        *)
    (* keyforflush         key for flush                          *)
    (* keyforbreak         key for break                          *)
    (* keyforstop          key for stop                           *)
    (* keytodcharacter     key to delete character                *)
    (* nonprintchar        non-printing character                 *)
    (* keytodline          key to delete line                     *)
    (* editorescapekey     editor 'escape' key                    *)
    (* leadincharacter     lead-in character from keyboard        *)
    (* editoracceptkey     editor 'accept' key                    *)
    (*                                                            *)
    (**************************************************************)

      
{$P}
{$S+}
Program listinfo;
  

  Const
    vmd  = 'vertical move delay       ';
    lns  = 'lead-in to screen         ';
    lnk  = 'lead-in from keyboard     ';
    mch  = 'move cursor home          ';
    eos  = 'erase to end of screen    ';
    eol  = 'erase to end of line      ';
    mcr  = 'move cursor right         ';
    mcu  = 'move cursor up            ';
    bs   = 'backspace                 ';
    el   = 'erase line                ';
    es   = 'erase screen              ';
    npc  = 'non-printing character    ';
    kmcu = 'key to move cursor up     ';
    kmcd = 'key to move cursor down   ';
    kmcl = 'key to move cursor left   ';
    kmcr = 'key to move cursor right  ';
    keof = 'key to end file           ';
    kf   = 'key for flush             ';
    kb   = 'key for break             ';
    ks   = 'key for stop              ';
    kdc  = 'key to delete a character ';
    kdl  = 'key to delete a line      ';
    eak  = 'editor accept key         ';
    eek  = 'editor escape key         ';


Type
   amiscinfo = packed record
      dummy1 : packed array [0..28] of integer;
      dummy2,dummy3,student,hasslow,hasrandom,haslowercase,
      has8510a,hasclock : boolean;
      dummy4 : integer;
      erasescreen,eraseline,verticalmdelay,backspace,
         movecup,movecright,eraseeol,eraseeos,movecursorhome,
         leadintoscreen : char;
      preerline,preerscreen,predcharacter,premchome,
         preereos,preereol,premcright,premcup : boolean;
      screenwidth,screenheight : integer;
      editoracceptkey,leadincharacter,editorescapekey,
         keytodline,nonprintchar,keytodcharacter,
         keyforstop,keyforbreak,keyforflush,keytoendfile,
         keytomcright,keytomcleft,keytomcdown,keytomcup : char;
      dummy5 : integer;
      dummy6,dummy7,predacceptkey,prekeydcharacter,
         prekeydline,preedescapekey,prekeyendfile,
         prekeyflush,prekeybreak,prekeystop,prenonprintchar,
         prekmcdown,prekmcup,prekmcleft,prekmcright : boolean;
      dummy8 : packed array [48..95] of integer;
      end;
   string8 = string[8];
   string5 = string[5];
   string6 = string[6];
    
{$P}
Var
   minfobuffer : amiscinforec;
   out         : text;
   mode        : integer;
   charfield   : string6;
   tffield     : string5;
   decfield    : integer;
   hexfield    : string8;
   asc         : char;

  Procedure clearfrom(y:integer);
    begin
      gotoxy(0,y);
      with minfobuffer do
        begin
          if preereos then write(leadintoscreen);
          write(eraseeos)
        end
    end;
    
  Procedure minfoinit; { initialize }
    var  minfofile : file of amiscinforec;
    begin
      reset (minfofile,'*system.miscinfo');
      get (minfofile);
      minfobuffer := minfofile^ ;
      close (minfofile);
    end;  { minfoinit }
  
  Procedure tf(tfval : boolean; var tfstring : string5);
    begin
      if tfval = true then tfstring := 'True '
                      else tfstring := 'False'
    end; { true-false }
    
  Procedure conv(charval : char; var astring : string6; 
                                 var ahex    : string8;
                                 var adec    : integer);
      var  charord : integer;
    procedure hexconv;
      VAR UD,LD : INTEGER;
      BEGIN
        ahex := '        ';
        UD := charord DIV 16;
        LD := charord MOD 16;
        IF UD > 9 THEN ahex[7] := CHR(UD+55)
                  ELSE ahex[7] := CHR(UD+48);
        IF LD > 9 THEN ahex[8] := CHR(LD+55)
                  ELSE ahex[8] := CHR(LD+48)
      END;  { hexconv }
  
    {$P}
    begin    { conv }
      astring := '      ';
      charord := ord(charval);
      hexconv;
      adec := charord;
      if (charord > 32) and (charord < 127) then
           astring[3] := charval
         else
           if charord = 127 then
               astring := 'DEL   '
             else
               case charord of
                  0: astring := 'NUL ^@';
                  1: astring := 'SOH ^A';
                  2: astring := 'STX ^B';
                  3: astring := 'ETX ^C';
                  4: astring := 'EOT ^D';
                  5: astring := 'ENQ ^E';
                  6: astring := 'ACK ^F';
                  7: astring := 'BEL ^G';
                  8: astring := 'BS  ^H';
                  9: astring := 'HT  ^I';
                 10: astring := 'LF  ^J';
                 11: astring := 'VT  ^K';
                 12: astring := 'FF  ^L';
                 13: astring := 'CR  ^M';
                 14: astring := 'SO  ^N';
                 15: astring := 'SI  ^O';
                 16: astring := 'DLE ^P';
                 17: astring := 'DC1 ^Q';
                 18: astring := 'DC2 ^R';
                 19: astring := 'DC3 ^S';
                 20: astring := 'DC4 ^T';
                 21: astring := 'NAK ^U';
                 22: astring := 'SYN ^V';
                 23: astring := 'ETB ^W';
                 24: astring := 'CAN ^X';
                 25: astring := 'EM  ^Y';
                 26: astring := 'SUB ^Z';
                 27: astring := 'ESC ^[';
                 28: astring := 'FS  ^\';
                 29: astring := 'GS  ^]';
                 30: astring := 'RS  ^^';
                 31: astring := 'US  ^_';
                 32: astring := 'SP    '
              end    { case and if's }
      end;      { conv }
  
 
  {$P}
  Procedure  seg1print;
   begin
    with minfobuffer do
    begin
    conv(verticalmdelay,charfield,hexfield,decfield);
     writeln(out,'   ',vmd ,'  ',charfield,'  ','-----',decfield:12,hexfield,'H');
    conv(leadintoscreen,charfield,hexfield,decfield);
     writeln(out,'   ',lns ,'  ',charfield,'  ','-----',decfield:12,hexfield,'H');
    conv(leadincharacter,charfield,hexfield,decfield);
     writeln(out,'   ',lnk ,'  ',charfield,'  ','-----',decfield:12,hexfield,'H');
    tf(premchome       ,tffield);
     conv(movecursorhome ,charfield,hexfield,decfield);
      writeln(out,'   ',mch ,'  ',charfield,'  ',tffield,decfield:12,hexfield,'H');
    tf(preereos        ,tffield);
     conv(eraseeos       ,charfield,hexfield,decfield);
      writeln(out,'   ',eos ,'  ',charfield,'  ',tffield,decfield:12,hexfield,'H');
    tf(preereol        ,tffield);
     conv(eraseeol       ,charfield,hexfield,decfield);
      writeln(out,'   ',eol ,'  ',charfield,'  ',tffield,decfield:12,hexfield,'H');
    end  { with }
  end;  {  seg1print }
  
  Procedure  seg2print;
   begin
    with minfobuffer do
    begin
    tf(premcright      ,tffield);
     conv(movecright     ,charfield,hexfield,decfield);
      writeln(out,'   ',mcr ,'  ',charfield,'  ',tffield,decfield:12,hexfield,'H');
    tf(premcup         ,tffield);
     conv(movecup        ,charfield,hexfield,decfield);
      writeln(out,'   ',mcu ,'  ',charfield,'  ',tffield,decfield:12,hexfield,'H');
    tf(predcharacter   ,tffield);
     conv(backspace      ,charfield,hexfield,decfield);
      writeln(out,'   ',bs  ,'  ',charfield,'  ',tffield,decfield:12,hexfield,'H');
    tf(preerline       ,tffield);
     conv(eraseline      ,charfield,hexfield,decfield);
      writeln(out,'   ',el  ,'  ',charfield,'  ',tffield,decfield:12,hexfield,'H');
    tf(preerscreen     ,tffield);
     conv(erasescreen    ,charfield,hexfield,decfield);
      writeln(out,'   ',es  ,'  ',charfield,'  ',tffield,decfield:12,hexfield,'H');
    tf(prenonprintchar ,tffield);
     conv(nonprintchar   ,charfield,hexfield,decfield);
      writeln(out,'   ',npc ,'  ',charfield,'  ',tffield,decfield:12,hexfield,'H');
    end  { with }
  end;  {  seg2print }
  
  {$P}
  Procedure  seg3print;
   begin
    with minfobuffer do
    begin
    tf(prekmcup        ,tffield);
     conv(keytomcup      ,charfield,hexfield,decfield);
      writeln(out,'   ',kmcu,'  ',charfield,'  ',tffield,decfield:12,hexfield,'H');
    tf(prekmcdown      ,tffield);
     conv(keytomcdown    ,charfield,hexfield,decfield);
      writeln(out,'   ',kmcd,'  ',charfield,'  ',tffield,decfield:12,hexfield,'H');
    tf(prekmcleft      ,tffield);
     conv(keytomcleft    ,charfield,hexfield,decfield);
      writeln(out,'   ',kmcl,'  ',charfield,'  ',tffield,decfield:12,hexfield,'H');
    tf(prekmcright     ,tffield);
     conv(keytomcright   ,charfield,hexfield,decfield);
      writeln(out,'   ',kmcr,'  ',charfield,'  ',tffield,decfield:12,hexfield,'H');
    tf(prekeyendfile   ,tffield);
     conv(keytoendfile   ,charfield,hexfield,decfield);
      writeln(out,'   ',keof,'  ',charfield,'  ',tffield,decfield:12,hexfield,'H');
    tf(prekeyflush     ,tffield);
     conv(keyforflush    ,charfield,hexfield,decfield);
      writeln(out,'   ',kf  ,'  ',charfield,'  ',tffield,decfield:12,hexfield,'H');
    end  { with }
  end;  {  seg3print }
  
  Procedure  seg4print;
   begin
    with minfobuffer do
    begin
    tf(prekeybreak     ,tffield);
     conv(keyforbreak    ,charfield,hexfield,decfield);
      writeln(out,'   ',kb  ,'  ',charfield,'  ',tffield,decfield:12,hexfield,'H');
    tf(prekeystop      ,tffield);
     conv(keyforstop     ,charfield,hexfield,decfield);
      writeln(out,'   ',ks  ,'  ',charfield,'  ',tffield,decfield:12,hexfield,'H');
    tf(prekeydcharacter,tffield);
     conv(keytodcharacter,charfield,hexfield,decfield);
      writeln(out,'   ',kdc ,'  ',charfield,'  ',tffield,decfield:12,hexfield,'H');
    tf(prekeydline     ,tffield);
     conv(keytodline     ,charfield,hexfield,decfield);
      writeln(out,'   ',kdl ,'  ',charfield,'  ',tffield,decfield:12,hexfield,'H');
    tf(predacceptkey   ,tffield);
     conv(editoracceptkey,charfield,hexfield,decfield);
      writeln(out,'   ',eak ,'  ',charfield,'  ',tffield,decfield:12,hexfield,'H');
    tf(preedescapekey  ,tffield);
     conv(editorescapekey,charfield,hexfield,decfield);
      writeln(out,'   ',eek ,'  ',charfield,'  ',tffield,decfield:12,hexfield,'H');
    end  { with }
  end;  {  seg4print }
        
  {$P}
  Procedure seg5print;
    begin
     with minfobuffer do
     begin
     writeln(out);
     tf(hasclock,tffield);
      writeln(out,'     has clock           ',tffield);
     tf(has8510a,tffield);
      writeln(out,'     has 8510A           ',tffield);
     tf(haslowercase,tffield);
      writeln(out,'     has lower case      ',tffield);
     tf(hasrandom,tffield);
      writeln(out,'     has random cursor   ',tffield);
     tf(hasslow,tffield);
      writeln(out,'     has slow terminal   ',tffield);
     tf(student,tffield);
      writeln(out,'     student setup       ',tffield);
     writeln(out);
     writeln(out,'   The screen size is ',screenheight:3,' high by ',
              screenwidth:3,' wide.')
     end   { with }
    end;   { seg5print }
    
  Procedure printbanner(pass : integer);
    begin
      if (mode =1) and (pass > 1) then begin
        gotoxy(0,23);
        write('Press any key to continue. ');
        read(asc)
        end;
      if mode = 1 then clearfrom(0);
      if (mode = 1) or (pass = 1) then begin
        writeln(out);
        write(out,'        Discription            Value Prefixed?    ');
        writeln(out,'Dec value Hex value')
        end
    end;    { print banner }
    
  {$P}
  Procedure setoutput;
    var itsdone : boolean;
        filname : string;
    begin
     repeat
      case mode of 
       1: filname := 'console:';
       2: filname := 'remout:';
       3: begin
           gotoxy(0,7);
           write('File name (include .text) > ');
           readln(filname)
          end
        end;  { case }
      {$I-}
      rewrite (out,filname);
      itsdone := (ioresult = 0)
      {$I+}
     until itsdone
    end;   { setoutput }
    

Begin   { MAIN LINE }
  minfoinit;
  repeat
    clearfrom(0);
    gotoxy(0,3);
    writeln('List SYSTEM.MISCINFO');
    repeat
     gotoxy(0,5);
     write('Miscinfo listing to [1] screen, [2] printer, ');
     write('[3] file [4] quit > [ ]');
     gotoxy(66,5);
     read(asc);
     mode := ord(asc)-48
    until (mode > 0) and (mode < 5);
    if mode < 4 then begin
      setoutput;
      printbanner(1);
      seg1print;
      seg2print;
      seg3print;
      printbanner(2);
      seg4print;
      seg5print;
      close(out, lock);
      if (mode =1) then begin
        gotoxy(0,23);
        write('Press any key to continue. ');
        read(asc)
        end
    end   { if mode < 4 }
  until mode = 4
End.     { MAIN LINE }


========================================================================================
DOCUMENT :usus Folder:VOL14:look.up.table
========================================================================================

ACI $       ADC a$        ADC A       ADC aA        ADC B       ADC aB        ADC C       ADC aC        ADC D       ADC aD        ADC E       ADC aE        ADC H       ADC aH        ADC L       ADC aL        ADC M       ADC a(HL)     ADD A       ADD aA        ADD B       ADD aB        ADD C       ADD aC        ADD D       ADD aD        ADD E       ADD aE        ADD H       ADD aH        ADD L       ADD aL        ADD M       ADD a(HL)     ADI $       ADD a$        ANA A       AND aA        ANA B       AND aB        ANA C       AND aC        ANA D       AND aD        ANA E       AND aE        ANA H       AND aH        ANA L       AND aL        ANA M       AND a(HL)     ANI $       AND a$        CALL$       CALLa$        CC  $       CALLaC,$      CM  $       CALLaM,$      CMA #       CPL a#        CMC #       CCF a#        CMP A       CP  aA        CMP B       CP  aB        CMP C       CP  aC        CMP D       CP  aD        CMP E       CP  aE        CMP H       CP  aH        CMP L       CP  aL        CMP M       CP  a(HL)     CNC $       CALLaNC,$     CNZ $       CALLaNZ,$     CP  $       CALLaP,$      CPE $       CALLaPE,$     CPI $       CP  a$        CPO $       CALLaPO,$     CZ  $       CALLaZ,$      DAA #       DAA a#        DAD B       ADD aHL,BC    DAD D       ADD aHL,DE    DAD H       ADD aHL,HL    DAD SP      ADD aHL,SP    DCR A       DEC aA        DCR B       DEC aB        DCR C       DEC aC        DCR D       DEC aD        DCR E       DEC aE        DCR H       DEC aH        DCR L       DEC aL        DCR M       DEC a(HL)     DCX B       DEC aBC       DCX D       DEC aDE       DCX H       DEC aHL       DCX SP      DEC aSP       DI  #       DI  a#        EI  #       EI  a#        HLT #       HALTa#        IN  $       IN  aA,$      INR A       INC aA        INR B       INC aB        INR C       INC aC        INR D       INC aD        INR E       INC aE        INR H       INC aH        INR L       INC aL        INR M       INC a(HL)     INX B       INC aBC       INX D       INC aDE       INX H       INC aHL       INX SP      INC aSP       JC  $       JP  aC,$      JM  $       JP  aM,$      JMP $       JP  a$        JNC $       JP  aNC,$     JNZ $       JP  aNZ,$     JP  $       JP  aP,$      JPE $       JP  aPE,$     JPO $       JP  aPO,$     JZ  $       JP  aZ,$      LDA $       LD  aA,($)    LDAXB       LD  aA,(BC)   LDAXD       LD  aA,(DE)   LHLD$       LD  aHL,($)   LXI B,$     LD  aBC,$     LXI D,$     LD  aDE,$     LXI H,$     LD  aHL,$     LXI SP,$    LD  aSP,$     MOV A,A     LD  aA,A      MOV A,B     LD  aA,B      MOV A,C     LD  aA,C      MOV A,D     LD  aA,D      MOV A,E     LD  aA,E      MOV A,H     LD  aA,H      MOV A,L     LD  aA,L      MOV A,M     LD  aA,(HL)   MOV B,A     LD  aB,A      MOV B,B     LD  aB,B      MOV B,C     LD  aB,C      MOV B,D     LD  aB,D      MOV B,E     LD  aB,E      MOV B,H     LD  aB,H      MOV B,L     LD  aB,L      MOV B,M     LD  aB,(HL)   MOV C,A     LD  aC,A      MOV C,B     LD  aC,B      MOV C,C     LD  aC,C      MOV C,D     LD  aC,D      MOV C,E     LD  aC,E      MOV C,H     LD  aC,H      MOV C,L     LD  aC,L      MOV C,M     LD  aC,(HL)   MOV D,A     LD  aD,A      MOV D,B     LD  aD,B      MOV D,C     LD  aD,C      MOV D,D     LD  aD,D      MOV D,E     LD  aD,E      MOV D,H     LD  aD,H      MOV D,L     LD  aD,L      MOV D,M     LD  aD,(HL)   MOV E,A     LD  aE,A      MOV E,B     LD  aE,B      MOV E,C     LD  aE,C      MOV E,D     LD  aE,D      MOV E,E     LD  aE,E      MOV E,H     LD  aE,H      MOV E,L     LD  aE,L      MOV E,M     LD  aE,(HL)   MOV H,A     LD  aH,A      MOV H,B     LD  aH,B      MOV H,C     LD  aH,C      MOV H,D     LD  aH,D      MOV H,E     LD  aH,E      MOV H,H     LD  aH,H      MOV H,L     LD  aH,L      MOV H,M     LD  aH,(HL)   MOV L,A     LD  aL,A      MOV L,B     LD  aL,B      MOV L,C     LD  aL,C      MOV L,D     LD  aL,D      MOV L,E     LD  aL,E      MOV L,H     LD  aL,H      MOV L,L     LD  aL,L      MOV L,M     LD  aL,(HL)   MOV M,A     LD  a(HL),A   MOV M,B     LD  a(HL),B   MOV M,C     LD  a(HL),C   MOV M,D     LD  a(HL),D   MOV M,E     LD  a(HL),E   MOV M,H     LD  a(HL),H   MOV M,L     LD  a(HL),L   MVI A,$     LD  aA,$      MVI B,$     LD  aB,$      MVI C,$     LD  aC,$      MVI D,$     LD  aD,$      MVI E,$     LD  aE,$      MVI H,$     LD  aH,$      MVI L,$     LD  aL,$      MVI M,$     LD  a(HL),$   NOP #       NOP a#        ORA A       OR  aA        ORA B       OR  aB        ORA C       OR  aC        ORA D       OR  aD        ORA E       OR  aE        ORA H       OR  aH        ORA L       OR  aL        ORA M       OR  a(HL)     ORI $       OR  a$        OUT $       OUT a$,A      PCHL#       JP  a(HL)     POP B       POP aBC       POP D       POP aDE       POP H       POP aHL       POP PSW     POP aPSW      PUSHB       PUSHaBC       PUSHD       PUSHaDE       PUSHH       PUSHaHL       PUSHPSW     PUSHaPSW      RAL #       RLA a#        RAR #       RRA a#        RC  #       RET aC        RET #       RET a#        RLC #       RLCAa#        RM  #       RET aM        RNC #       RET aNC       RNZ #       RET aNZ       RP  #       RET aP        RPE #       RET aPE       RPO #       RET aPO       RRC #       RRCAa#        RST $       RST a$        RZ  #       RET aZ        SBB A       SBC aA        SBB B       SBC aB        SBB C       SBC aC        SBB D       SBC aD        SBB E       SBC aE        SBB H       SBC aH        SBB L       SBC aL        SBB M       SBC a(HL)     SBI $       SBC a$        SHLD$       LD  a($),HL   SPHL#       LD  aSP,HL    STA $       LD  a($),A    STAXB       LD  a(BC),A   STAXD       LD  a(DE),A   STC #       SCF a#        SUB A       SUB aA        SUB B       SUB aB        SUB C       SUB aC        SUB D       SUB aD        SUB E       SUB aE        SUB H       SUB aH        SUB L       SUB aL        SUB M       SUB a(HL)     SUI $       SUB a$        XCHG#       EX  aDE,HL    XRA A       XOR aA        XRA B       XOR aB        XRA C       XOR aC        XRA D       XOR aD        XRA E       XOR aE        XRA H       XOR aH        XRA L       XOR aL        XRA M       XOR a(HL)     XRI $       XOR a$        XTHL#       EX  a(SP),HL                                                                                                                                                                                                                         O  ^                                                                                                                                                                                                                                                                                             
========================================================================================
DOCUMENT :usus Folder:VOL14:refer.inc.text
========================================================================================

  (* included from REFERENCE *)
  
  procedure printtree(root: ptrtoentry);
    var
      thiscell: listofusages;
      count: natural;
      
    procedure conditionalwrite(n: natural;
                               substitute: sixchars);
    begin { conditionalwrite }
      if n = 0 then
        write(outfile, substitute)
      else
        write(outfile, n:6);
    end;  { conditionalwrite }
  
    procedure namewrite(p: ptrtoentry);
      var len: integer; s: setrange;
    begin { namewrite }
      with p^ do
        begin len := length(procname);
          for s := 0 to len-1 do
            if s in caseset then
              write(outfile, chr(ord(procname[s+1])-uclcdisplacement))
            else
              write(outfile, procname[s+1]);
          end;
      if len < sigcharlimit then
        write(outfile, ' ':sigcharlimit-len);
    end;  { namewrite }
    
  begin { printtree }
    if root <> nil then
      with root^ do
        begin printtree(before); writeln(outfile);
          write(outfile, linenumber: 5); conditionalwrite(startofbody, '      ');
          case status of
            fwdhalf,notproc:
              write(outfile, '   eh?');
            formal:
              write(outfile, '   fml');
            outside:
              write(outfile, '   ext');
            shortform:
              write(outfile, '      ');
            allfwd:
              write(outfile, forwardblock:6);
          end;
          write(outfile, '  '); namewrite(root); write(outfile, ' :'); 
          thiscell := calls;
          count := 0;
          while thiscell <> nil do
            begin
              if ((count mod namesperline) = 0) and (count <> 0) then
                begin writeln(outfile); 
                  write(outfile, ' ':sigcharlimit+19, ' :'); 
                end;
              write(outfile, ' ');
              namewrite(thiscell^.what);
              thiscell := thiscell^.next;
              count := count + 1;
            end;
          writeln(outfile);
          
          printtree(after);
        end;
  end;  { printtree }
  
  procedure nexttoken;
  
    procedure ignorecomment(tail: string);
    
      procedure getdirective;
        var i: integer; found: boolean; inclfn: string[30];
      begin { getdirective }
        {$R- disable range checks }
        nextch;
        if ch = 'I' then { include }
          begin nextch;
            if ch = ' ' then
              begin nextch; i := 0; 
                while ch <> '}' do
                  begin i := i + 1;
                    inclfn[i] := ch;
                    nextch;
                  end;
                inclfn[0] := chr(i);    { set string length }
                {$I- disable IO checks }
                including := including + 1;
                with fcb[including] do
                  begin close(infile); reset(infile, inclfn);
                    found := ioresult = 0;
                    if not found  then { found the file }
                      begin inclfn := concat(inclfn, '.text');
                        reset(infile, inclfn); found := ioresult = 0;
                      end;
                    {$I+}
                    if found then
                      begin writeln('---opening: ', inclfn);
                        inlfn := inclfn; chno := 0; line := '';
                        bpos := bufsiz; endfile := false; blknr := 2;
                      end
                    else
                      begin writeln('---cannot find: ', inclfn);
                        close(infile);
                        including := including - 1;
                        with fcb[including] do
                          reset(infile, inlfn);
                      end;
                  end;
                end;
          end;
        {$R+}
      end;  { getdirective }
      
    begin { ignorecomment }
      nextch;
      if ch = '$' then
        getdirective;
      repeat
        while (ch <> tail[1]) do
          nextch;
        if ch = '*' then
          nextch;
      until (ch = tail[length(tail)]);
      nextch;
    end;  { ignorecomment }
    
    procedure ignorenumbers;
    begin { ignorenumbers }
      while ch in digits do
        nextch;
      with fcb[including] do
        if ch = '.' then
          begin
            if (line[chno+1] in digits) then
              begin nextch;
                while ch in digits do nextch;
              end;
          end;
      if (ch = 'E') or (ch = 'e') then
        begin nextch;
          if (ch = '+') or (ch = '-') then nextch;
          while ch in digits do nextch;
        end;
    end;  { ignorenumbers }
    
    procedure readident;
      var j: integer;
    begin { readident }
      {$R- disable range check to store string length }
      token := namesy; symbol := spaces; symbolcase := []; j := 0;
      while (j < sigcharlimit) and (ch in alphanums) do
        begin j := j + 1;
          if ch in uppercase then
            begin symbol[j] := chr(ord(ch)+uclcdisplacement);
              symbolcase := symbolcase + [j-1];
            end
          else symbol[j] := ch;
          nextch;
        end;
      symbol[0] := chr(j);
      {$R+}
      while ch in alphanums do
        nextch;
    end;  { readident }
    
  begin { nexttoken }
    token := othersy;
    repeat
      if ch in usefulchars then
        begin
          case ch of
            ')':
              begin nextch; token := rparensy; end;
            
            '(':
              begin nextch;
                if ch = '*' then ignorecomment('*)')
                else token := lparensy;
              end;
            
            '{':
              ignorecomment('}');
            
            '''':
              begin nextch;
                while ch <> '''' do nextch; nextch;
              end;
            
            '0', '1', '2', '3', '4', '5', '6', '7', '8', '9':
              ignorenumbers;
            
            ':':
              begin nextch;
                if ch = '=' then
                  begin token := assignsy; nextch; end
                else
                  token := colonsy;
              end;
            
            '.':
              begin nextch;
                if ch <> '.' then token := periodsy
                else begin token := subrangesy; nextch; end;
              end;
            
            ';':
              begin nextch; token := semicolsy; end;
            
            'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', 'K', 'L', 'M',
            'N', 'O', 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W', 'X', 'Y', 'Z',
            'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm',
            'n', 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', 'y', 'z':
              readident;
          end
        end
      else
        nextch
    until token <> othersy;
  end;  { nexttoken }
  
  procedure processunit(programid: boolean);
    var at: ptrtoentry;
  
    function nameisinscope: boolean;
      var
        llevel:         ptrtostackcell;
        discovered:     boolean;
        where:          ptrtoentry;
    begin { nameisinscope }
      llevel := stack;
      discovered := false;
      savesymbol := symbol;
      while (llevel <> nil) and not discovered do
        begin
          findnode(discovered, where, llevel^.scopetree);
          if not discovered then
            llevel := llevel^.substack;
        end;
      if discovered then
        nameisinscope := (where^.status <> notproc)
      else
        nameisinscope := false;
    end;  { nameisinscope }
  
    procedure processblock;
      var
        address:        ptrtoentry;
        
      procedure crossreferencer;
        var
          newcell:      listofusages;
          ptr:          listofusages;
          home:         ptrtoentry;
          slevel:       ptrtostackcell;
          found:        boolean;
        
        procedure findcell;
          var
            nextptr:    listofusages;
        begin { findcell }
          found := false;
          nextptr := stack^.current^.calls;
          if nextptr <> nil then
            repeat
              ptr := nextptr;
              found := (ptr^.what^.procname = savesymbol);
              nextptr := ptr^.next;
            until found or (nextptr = nil)
          else
            ptr := nil;
        end;  { findcell }
      
      begin { crossreferencer }
        slevel := stack; found := false;
        while (slevel <> nil) and not found do
          begin findnode(found, home, slevel^.scopetree);
            if not found then
              slevel := slevel^.substack
          end;
        if found then
          begin
            if home^.status <> notproc then
              begin findcell;
                if not found then
                  begin new(newcell);
                    if ptr <> nil then
                      ptr^.next := newcell
                    else
                      stack^.current^.calls := newcell;
                    newcell^.what := home;
                    newcell^.next := nil;
                  end;
              end;
          end;
      end;  { crossreferencer }
      
      procedure scanforname;
      begin { scanforname }
        nexttoken;
        while token <> namesy do
          nexttoken;
      end;  { scanforname }
      
  begin { processblock }
    while (symbol <> sbegin) do
      begin
        while (symbol <> sbegin) and (symbol <> sprocedure) and
              (symbol <> sfunction) and (symbol <> ssegment) do
          begin 
            scanforname;
            if nameisinscope then
              begin address := makeentry(false, false); end;
          end;
        if symbol <> sbegin then
          begin 
            if symbol = ssegment then
              nexttoken;
            processunit(false); scanforname; 
          end;
      end;
    depth := 1;
    stack^.current^.startofbody := lineno;
    nexttoken;
    while depth <> 0 do
      begin
        if token <> namesy then
          nexttoken
        else
          if (symbol = sbegin) or (symbol = scase) then
            begin depth := depth + 1; nexttoken end
          else
            if (symbol = send) then
              begin depth := depth - 1; nexttoken; end
            else
              begin savesymbol := symbol; nexttoken;
                if token <> assignsy then
                  crossreferencer
                else
                  nexttoken
              end;
      end;
  end;  { processblock }
  
  procedure scanparameters;
    var
      which: ptrtoentry;
      
    procedure scantillclose;
    begin { scantillclose }
      nexttoken;
      while token <> rparensy do
        begin
          if token = lparensy then
            scantillclose;
          nexttoken;
        end;
   end;  { scantillclose }
   
 begin { scanparameters }
   nexttoken;
   while token <> rparensy do
     begin
       if (token = namesy) then
         begin
           if (symbol = sprocedure) or (symbol = sfunction) then
             begin nexttoken;
               if token = namesy then
                 begin which := makeentry(false, true);
                   which^.status := formal; pop; nexttoken;
                   if token = lparensy then
                     scantillclose;
                 end
               else
                 begin error(2); nexttoken; end;
             end
           else
             begin
               if nameisinscope then
                 which := makeentry(false, false);
               nexttoken;
             end;
         end
       else
         nexttoken;
     end;
     nexttoken;
   end;  { scanparameters }
 
  begin { processunit }
    printflag := true;
    adjustment := first;
    nexttoken;
    if token <> namesy then
      error(2)
    else
      begin at := makeentry(programid, true);
        while not (token in [lparensy,semicolsy,colonsy]) do
          nexttoken;
        if token = lparensy then
          scanparameters;
        while token <> semicolsy do
          nexttoken;
        printline;
        printflag := false;
        writeln(outfile);
        nexttoken;
        if token <> namesy then
          error(3)
        else
          begin
            if (symbol <> slabel) and (symbol <> sconst) and (symbol <> stype)
                and (symbol <> sprocedure) and (symbol <> sfunction)
                and (symbol <> svar) and (symbol <> sbegin) 
                and (symbol <> suses) and (symbol <> ssegment) then
              begin
                if symbol = sforward then
                  at^.status := fwdhalf
                else
                  at^.status := outside;
                pop
              end
            else
              begin processblock; pop end
          end
      end;
  end;  { processunit }
  
  procedure printheading;
  begin { printheading }
    writeln(outfile, 'procedural cross-refrencer - version s-02.01');
    writeln(outfile, '============================================');
    writeln(outfile);
  end;  { printheading }


========================================================================================
DOCUMENT :usus Folder:VOL14:reference.text
========================================================================================

{
        program referencer
        Copyright (C) 1979
        A.H. Sale
        Southhamptom, England
        
        See Pascal News #17
        
        Permission is granted to copy this program, store it in 
        a computer system, and distribute it provided that this
        header comment is retained in all copies
}
{$S+ allow compiler to swap }
program refrencer;
const
  
  sigcharlimit = 10;
  setlimit = 09;
  uclcdisplacement = 32;
  linelimit = 200;
  linewidth = 80;
  indentation = 4;
  
  bufsiz = 1024;
  cr = 13;    { carriage return }
  
  sprogram =    'program';
  sprocedure =  'procedure';
  sfunction =   'function';
  slabel =      'label';
  sconst =      'const';
  stype =       'type';
  svar =        'var';
  sbegin =      'begin';
  scase =       'case';
  send =        'end';
  sforward =    'forward';
  suses =       'uses';
  ssegment =    'segment';
  spaces =      '';
  
type
  natural       = 0..maxint;
  positive      = 1..maxint;
  
  sixchars      = packed array[1..6] of char;
  
  sigcharrange  = 1..sigcharlimit;
  setrange      = 0..setlimit;
  
  pseudostring  = string[sigcharlimit];
  stringcases   = set of setrange;
  
  linesize      = 1..linelimit;
  lineindex     = 0..linelimit;
  
  setofchar     = set of char;
  
  prockind      = (fwdhalf,allfwd,shortform,formal,outside,notproc);
  
  ptrtoentry    = ^entry;
  
  listofusages  = ^usagecell;
  
  ptrtostackcell = ^stackcell;
  
  tokentype     = (othersy,namesy,lparensy,rparensy,colonsy,
                   semicolsy,periodsy,assignsy,subrangesy);
                   
  entry =
        record
          procname:     pseudostring;
          caseset:      stringcases;
          linenumber:   natural;
          startofbody:  natural;
          left,right:   ptrtoentry;
          before,after: ptrtoentry;
          calls:        listofusages;
          localtree:    ptrtoentry;
          case status: prockind of
            fwdhalf,shortform,formal,outside,notproc:
              ();
            allfwd:
              (forwardblock: natural);
        end;
        
  usagecell =
        record
          what: ptrtoentry;
          next: listofusages
        end;
        
  stackcell =
        record
          current: ptrtoentry;
          scopetree: ptrtoentry;
          substack: ptrtostackcell;
        end;
  
  longstring = STRING[255];

var
  lineno:       natural;
  depth:        natural;
  level:        -1..maxint;
  pretty:       natural;
  onscreen:     boolean;
  
  adjustment:   (first,other);
  movement:     integer;
  
  printflag:    boolean;
  errorflag:    boolean;
  
  ch:           char;
  
  token:        tokentype;
  
  symbol:       pseudostring;
  symbolcase:   stringcase;
  
  savesymbol:   pseudostring;
  
  superroot:    ptrtoentry;
  
  stack:        ptrtostackcell;
  
  alphabet:     set of char;
  alphanums:    setofchar;
  uppercase:    setofchar;
  
  digits:       setofchar;
  
  usefulchars:  setofchar;
  
  namesperline: positive;
  
  outlfn:       string[30];
  outfile:      text;
  
  { include file stuff }
  
  including:    integer;        { include file nest level }
  
  { file control block }
  
  infile:       file;           { input file }
  
  fcb: array[0..1] of
    record
      chno:     lineindex;      { current char index }
      inlfn:    string[30];     { input file name }
      line:     longstring;     { current text line }
      bpos:     integer;        { buffer position }
      endfile:  boolean;        { true when end of file }
      buf:      packed array[0..bufsiz] of char;
      blknr:    integer;
    end;
    
  procedure getstring(VAR S: longstring);
    const
      dle = 16;
    var bcnt, chg: integer;
  begin { getstring } {$R- disable string range checks }
    with fcb[including] do
      repeat
        if bpos >= bufsiz then { time for next buffer }
          begin bcnt := blockread(infile, buf[0], 2, blknr);
            bpos := 0; blknr := blknr + bcnt;
            if bcnt < 2 then { eof }
              begin endfile := true; EXIT(getstring) end;
          end;
        chg := scan(bufsiz-bpos, =chr(CR), buf[bpos]);
        if (bpos + chg) < bufsiz then { found a carriage return }
          begin moveleft(buf[bpos], S[1], chg);    { copy string except CR }
            S[0] := chr(chg); bpos := bpos + chg + 1;
          end
        else
          begin chg := scan(1024-bpos, =chr(0), buf[bpos]);   { look for null }
            if (bpos + chg) < bufsiz then
              begin moveleft(buf[bpos], S[1], chg-1); 
                S[0] := chr(chg); bpos := 1024;
              end;
          end;
      until chg > 0;
    if s[1] = chr(dle) then
      begin s[1] := ' '; s[2] := ' ' end;
  end;  { getstring } {$R+}
  
procedure printline;
    var i: linesize;
  begin { printline }
    write(outfile, lineno:5, '   '); i := 1;
    with fcb[including] do
      if adjustment = first then
        begin
          while (i < length(line)) and (line[i] = ' ') do
            i := succ(i);
          movement := (level * indentation) - (i - 1);
          adjustment := other;
          if level > 0 then
            write(outfile, ' ':(level*indentation));
        end
      else
        begin
          if movement > 0 then
            write(outfile, ' ': movement)
          else if movement < 0 then
            while (i < length(line)) and (line[i] = ' ') and (i <= -movement) do
              i := succ(i);
        end;
    with fcb[including] do
      while i < length(line) do
        begin write(outfile, line[i]); i := succ(i); end;
    writeln(outfile);
  end;  { printline }
  
  procedure error(e: positive );
  begin { error }
    errorflag := true;
    write(outfile, 'FATAL ERROR - ');
    case e of
      1: write(outfile, 'no "program" word');
      2: write(outfile, 'no identifier after prog/proc/func');
      3: write(outfile, 'token after heading unexpected');
      4: write(outfile, 'lost "." check begin/case/ends');
      5: write(outfile, 'same name, but not forward declared');
      6: write(outfile, 'cannot nest include files');
      7: write(outfile, 'file not found');
    end;
    writeln(outfile, ' - at following line');
    adjustment := first;
    printline;
    writeln(outfile, 'Last symbol: "', symbol, '"');
  end;  { error }
  
  procedure nextch;
  begin { nextch }
    with fcb[including] do
      if (including > 0) and endfile then
        begin close(infile); including := including -1; 
          with fcb[including] do
            begin reset(infile, inlfn);
              writeln('--- re-opening ', inlfn)
            end;
        end;
    with fcb[including] do
      if chno = length(line) then
        begin if printflag then printline;
          getstring(line); line := concat(line, ' ');
          lineno := lineno + 1; chno := 1; ch := line[1];
          if not onscreen then write('.');
        end
      else
        begin chno := succ(chno); ch := line[chno]; end;
  end;  { nextch }
  
  procedure push(newscope: ptrtoentry);
    var
      newlevel: ptrtostackcell;
  begin { push }
    new(newlevel);
    newlevel^.current := newscope;
    newlevel^.scopetree := nil;
    newlevel^.substack := stack;
    stack := newlevel;
    level := level + 1;
  end;  { push }
  
  procedure pop;
    var oldcell: ptrtostackcell;
  begin { pop }
    stack^.current^.localtree := stack^.scopetree;
    oldcell := stack;
    stack := oldcell^.substack;
    level := level - 1;
  end;  { pop }
  
  procedure findnode(var match: boolean;
                     var follow: ptrtoentry;
                         thisnode: ptrtoentry);
  begin { findnode }
    match := false;
    while (thisnode <> nil) and not match do
      begin
        follow := thisnode;
        if savesymbol < thisnode^.procname then
          thisnode := thisnode^.left
        else if savesymbol > thisnode^.procname then
          thisnode := thisnode^.right
        else
          match := true;
      end;
  end;
  
  function makeentry(mainprog: boolean;
                     proc: boolean): ptrtoentry;
    var
      newentry, node: ptrtoentry;
      located: boolean;
      
    procedure puttosupertree(newnode: ptrtoentry);
      var 
        place: ptrtoentry;
        
      procedure findleaf;
        var
          subroot: ptrtoentry;
      begin { findleaf }
        subroot := superroot;
        while subroot <> nil do
          begin
            place := subroot;
            if savesymbol < subroot^.procname then
              subroot := subroot^.before
            else
              subroot := subroot^.after
          end;
      end;  { findleaf }
      
    begin { puttosupertree }
      if superroot = nil then
        superroot := newnode
      else
        begin
          findleaf;
          with place^ do
            begin
              if savesymbol < procname then
                before := newnode
              else
                after := newnode
            end
        end
    end;  { puttosupertree }
    
  begin { makeentry }
    located := false;
    savesymbol := symbol;
    if mainprog then new(newentry)
    else
      if stack^.scopetree = nil then
        begin new(newentry); stack^.scopetree := newentry; end
      else
        begin findnode(located, node, stack^.scopetree);
          if not located then
            begin new(newentry);
              with node^ do
                if symbol < procname then
                  left := newentry
                else
                  right := newentry
            end
        end;
    if not located then
      begin
        with newentry^ do
          begin procname := symbol; caseset := symbolcase;
            linenumber := lineno; startofbody := 0;
            if proc then status := shortform
            else status := notproc;
            left := nil; right := nil;
            before := nil; after := nil;
            calls := nil; localtree := nil;
          end;
        makeentry := newentry;
        if proc then
          begin puttosupertree(newentry); push(newentry); end;
      end
    else
      begin makeentry := node; push(node);
        if node^.status = fwdhalf then
          begin stack^.scopetree := node^.localtree;
            node^.status := allfwd; node^.forwardblock := lineno;
          end
        else
          error(5)
      end
  end;  { makeentry }
  
(*$I refer.inc.text*)

begin { refrencer }
  including := 0;
  with fcb[including] do
    begin chno := 0; 
      bpos := bufsiz; blknr := 2; line := ''; endfile := false;
      write('Input file name: '); readln(inlfn); 
      if inlfn = '' then exit(refrencer);
      {$I- disable system IO checks }
      reset(infile, inlfn);
      if ioresult <> 0 then
        begin inlfn := concat(inlfn, '.text');
          reset(infile, inlfn);
          if ioresult <> 0 then
            begin error(7); exit(refrencer); end;
        end;
      {$I+}
      onscreen := (inlfn = '#1:') or (inlfn = 'CONSOLE:') or 
        (inlfn = 'console:');
    end;
  write('Output file name: '); readln(outlfn); 
  if outlfn = '' then outlfn := 'CONSOLE:';
  rewrite(outfile, outlfn);
  superroot := nil;
  new(stack);
  with stack^ do
    begin current := nil; scopetree := nil; substack := nil; end;
    
  printflag := false;
  
  uppercase := ['A'..'Z'];
  alphabet := uppercase + ['a'..'z'];
  digits := ['0'..'9'];
  alphanums := alphabet + digits + ['_'];
  usefulchars := alphabet + digits + ['(', ')', '{', '.', ':', ';', ''''];
  
  namesperline := (linewidth - (sigcharlimit + 21)) div
                    (sigcharlimit + 1);
                    
  lineno := 0;
  level := -1;
  errorflag := false;
   
  page(outfile);
  
  printheading;
  writeln(outfile, ' line   program/procedure/function heading');
  for pretty := 1 to 43 do
    write(outfile, '-');
  writeln(outfile);
  writeln(outfile);
  
  nexttoken;
  if token <> namesy then
    error(1)
  else if symbol <> sprogram then
    error(1)
  else
    begin
      processunit(true);
      if not errorflag then
        begin
          if (token <> periodsy) and (token <> subrangesy) then
            error(4)
          else
            begin
              adjustment := first;
              printline;
            end
        end
      end;
    if not errorflag then
      begin
        page(outfile);
        printheading;
        writeln(outfile, ' head  body  notes ',
                ' ':sigcharlimit,
                '   call made to');
        for pretty := 1 to (sigcharlimit+37) do
          write(outfile, '-');
        writeln(outfile);
        printtree(superroot);
        writeln(outfile);
      end;
  close(outfile, lock);
end.  { refrencer }
  


========================================================================================
DOCUMENT :usus Folder:VOL14:reform.text
========================================================================================


(************************************************************************)
(*                                                                      *)
(*      This program is used to reformat the conversion table           *)
(*        text file to a data file that can be read swiftly and         *)
(*        in the proper format for the 8080 to Z-80 opcode              *)
(*        conversion program.                                           *)
(*                                                                      *)
(*      Author:         David Parrish                                   *)
(*                      Medical College of Georgia                      *)
(*                      Augusta, Georgia  30912                         *)
(*                                                                      *)
(*      Date:           June  14, 1980                                  *)
(*                                                                      *)
(******* This program is part of the MCG Pascal utilities library *******)
(*                                                                      *)
(*                                                                      *)
(************************************************************************)

Program reform;
  
  type rectype = record
                   a8opc : string[4];
                   a8opr : string[8];
                   aZopc : string[4];
                   aZopr : string[8]
                 end;
  
  var infile       : text;
      outfile      : file of rectype;
      outrec       : rectype;
      orgstr, temp : string;
      i            : integer;

begin
  reset(infile,'table.text');
  rewrite(outfile,'look.up.table');
  for i := 1 to 237 do     (* 237 opcodes in the table *)
   begin
     readln(infile,orgstr);
     outrec.a8opc := copy(orgstr,1,4);
     outrec.a8opr := copy(orgstr,9,8);
     outrec.aZopc := copy(orgstr,17,4);
     temp := copy(orgstr,25,(length(orgstr)-24));
     temp := concat(temp,'        ');
     outrec.aZopr := copy(temp,1,8);
     outfile^ := outrec;
     put(outfile);
     writeln(orgstr)
   end;
  close(infile);
  close(outfile, lock)
end.


========================================================================================
DOCUMENT :usus Folder:VOL14:roman.text
========================================================================================

program roman;
{ Enter year and get the roman numeral equivalent back.
  CEF   Exobiology Labs. Univ. HI   Feb 1982            } 
{ For an interesting historical discussion of Roman Numerals } 
{ as well as a rational for the algorithm behind this program } 
{ see "The World of Mathematics", Volume One, edited by } 
{ James R. Newman, published by Simon and Schuster, New York } 
     type digit = 0..9; 
     var n : integer; 
     
procedure write_digit( d: digit;  units, fives, tens : char); 
{ write digit d in roman numerals using the characters 
  units, fives, and tens} 
  var i : integer; 
  begin
     if d = 9
       then write(units, tens)
     else if d = 4
             then write(units, fives)
          else
             begin
               if d >= 5
                  then write(fives);
                  for i := 1 to d mod 5 do
                  write(units);
             end;
  end; { write digit } 
  
procedure write_date( date : integer ); 
{write date in roman numerals - dates not in the range 1..3999
  are printed as *** } 
  { NOTE-won't happen now due to changes by} 
  {Gene Gingerich--see main program write statements } 
  begin
        if ( date <= 0 ) or ( date >= 4000 )
          then write('***')
        else
          begin
                write_digit(date div 1000,'M','*','*');
                write_digit((date div 100) mod 10,'C','D','M');
                write_digit((date div  10) mod 10,'X','L','C');
                write_digit(date mod 10,'I','V','X');
          end; 
  end; {write_date} 
  
procedure do_it; { do_it repeatedly asks for input and produces } 
{ output until the user terminates the program }
     begin
        repeat
           writeln;writeln;writeln;
           writeln('Enter a year between 1 and 3999  Any other');
           write('year will cause the the program to terminate -->  ');
           (*$I-*)
           repeat
              readln(n);
           until ioresult = 0;
           (*$I+*)
           if ((n > 0) and (n < 4000)) then
             begin
               writeln;
               write('In Rome it would be -->  ');
               write_date(n);
             end;
        until((n <= 0) or (n > 3999));
     end; {do_it} 
     
begin {main}
     writeln;writeln;
     writeln('This program is generated from an example in the book:');
     writeln(' ');
     writeln('"The UCSD Pascal Handbook" by Randy Clark and Stephen Koehler');
     writeln('from Softech Microsystems, San Diego, Calif.  The book is');
     writeln('directed toward the Implementation of UCSD Pascal provided');
     writeln('by Softech Microsystems and is an excellent reference for');
     writeln('users of that system.  The book is published by Prentice-');
     writeln('Hall. This display has been added to the program by ');
     writeln('Gene Gingerich of GINGER BRED SOFTWARE, a happy user of');
     writeln('the Softech UCSD Pascal System, Version II.0.  Some minor'); 
     writeln('changes have been made to warn the user about limits,');
     writeln('valid year entries and how to terminate the program during');
     writeln('execution.   Comments have also been added by Professor');
     writeln('C. E. Folsome, of the Univ. Hawaii, who generated the program');
     writeln('for me.  No criticsm of this fine book is meant');
     do_it; { go do it until termination } 
end. 

========================================================================================
DOCUMENT :usus Folder:VOL14:scanner.text
========================================================================================

(*$L-printer:*)
program scanner;
  {Scanner is by Jon Bondy  and slightly modified by George Schreyer.
    Scanner read a whole disk and looks for a list of strings contained
    in a data file called SCAN.DATA.TEXT.  Make this file with the editor
    and put all of the strings you wish to find in it on separate lines.  
    The original was sensitive
    to null lines, I fixed it.  Also the original always started at block
    10 (it assumes that you keep duplicate directories). I changed it so
    that it will know where to start (block 6 or 10).
    
    This is a good program.  It is ESPECIALLY useful when you have deleted
    a copy of an important file and you want to find where it is still on
    the disk.   gws}
  
  CONST
      { disk directory stuff }
      MAXDIR = 77;           (*MAX NUMBER OF ENTRIES IN A DIRECTORY*)
      MAXUNIT = 12;          (*MAX NUMBER OF UNITS *)
      VIDLENG = 7;           (*NUMBER OF CHARS IN A VOLUME ID*)
      TIDLENG = 15;          (*NUMBER OF CHARS IN TITLE ID*)
      FBLKSIZE = 512;        (*STANDARD DISK BLOCK LENGTH*)
      DIRBLK = 2;            (*DISK ADDR OF DIRECTORY*)

      max_entries = 10;
      read_unit = 5;         { unit where disk is read }
      buffer_length = 16383; { starts at zero }
   
  TYPE
      { disk directory stuff from UCSD GLOBALS.TEXT }
      DATEREC = PACKED RECORD
          MONTH: 0..12;        (*0 IMPLIES DATE NOT MEANINGFUL*)
          DAY: 0..31;          (*DAY OF MONTH*)
          YEAR: 0..100         (*100 IS TEMP DISK FLAG*)
        END (*DATEREC*) ;
      UNITNUM = 0..MAXUNIT;
      VID = STRING[VIDLENG]; { volume name (I.D.) }
      DIRRANGE = 0..MAXDIR; { number of entries (files) in a directory }
      TID = STRING[TIDLENG]; { title (file name) I.D. }
      FILEKIND = (UNTYPEDFILE,XDSKFILE,CODEFILE,TEXTFILE,
                  INFOFILE,DATAFILE,GRAFFILE,FOTOFILE,SECUREDIR);
      DIRENTRY = RECORD
        DFIRSTBLK: INTEGER;          (*FIRST PHYSICAL DISK ADDR*)
        DLASTBLK: INTEGER;           (*POINTS AT BLOCK FOLLOWING*)
        CASE DFKIND: FILEKIND OF
          SECUREDIR,
          UNTYPEDFILE: (*ONLY IN DIR[0]...VOLUME INFO*)
             (DVID: VID;              (*NAME OF DISK VOLUME*)
              DEOVBLK: INTEGER;       (*LASTBLK OF VOLUME*)
              DNUMFILES: DIRRANGE;    (*NUM FILES IN DIR*)
              DLOADTIME: INTEGER;     (*TIME OF LAST ACCESS*)
              DLASTBOOT: DATEREC);    (*MOST RECENT DATE SETTING*)
          XDSKFILE,CODEFILE,TEXTFILE,INFOFILE,
          DATAFILE,GRAFFILE,FOTOFILE:
             (DTID: TID;              (*TITLE OF FILE*)
              DLASTBYTE: 1..FBLKSIZE; (*NUM BYTES IN LAST BLOCK*)
              DACCESS: DATEREC)       (*LAST MODIFICATION DATE*)
      END (*DIRENTRY*) ;
   var
      DIRECTORY : ARRAY [DIRRANGE] OF DIRENTRY;
      infile : text; { file from which search strings are read }
      dict : array[1..max_entries] of string; { list of search strings }
      num_entries : integer; { number of search strings }
      buffer : packed array [0..buffer_length] of char;
      i, j, k, l : integer;
      start_char, start_block, num_blocks, chars_read, len : integer;
      found, done : boolean;
               
   procedure tell_found;
      var
         i, block : integer;
         found : boolean;
      begin
      block := start_block + (start_char div 512);
      write('Block: ', block:3, ' ');
      found := false;
      for i := 1 to directory[0].dnumfiles do 
         with directory[i] do 
            if (block >= dfirstblk) and (block < dlastblk) then begin
               write('File: ', dtid, ' ':(16-length(dtid))); 
               found := true; end;
      if not found then write('Not found in a file.  ');
      writeln('   v');
      { display context of text found }
      for i := -35 to 35 do
         if (start_char+i-2 >= 0) and 
            (start_char+i-1 < chars_read) then
            if (buffer[start_char+i-2] in [' '..'~']) then
               write(buffer[start_char+i-2])
            else write('*')
         else write('*');
      writeln; writeln;
      end; { tell_found }

   begin
   writeln('Disk Scanner Program.  Jon Bondy.  Jan 1982.');
   {$I-} reset(infile,'scan.data.text'); {$I+}
   if (ioresult <> 0) then begin
      writeln('Unable to locate SCAN.DATA.TEXT');
      exit(scanner);
      end;
   num_entries := 1;
   while not eof(infile) and (num_entries <= max_entries) do begin
      readln(infile,dict[num_entries]);
      if dict[num_entries] <> '' then 
         begin
            writeln(num_entries:2, ': "', dict[num_entries], '"');
            num_entries := num_entries + 1;
               {we don't want to search for null strings.  This blew up the 
                 original.   gws }
         end;
      end;
   num_entries := num_entries - 1;
   write('Enter <CR> when disk is in Unit 5.'); readln;
   unitread(read_unit,directory,sizeof(directory),dirblk,0);
   with directory[0] do
      writeln('Volume ', dvid, ': scanning ', deovblk - directory[0].dlastblk,
         ' blocks.');
   start_block := directory[0].dlastblk  {was 10   gws};
   while (start_block <= directory[0].deovblk) do begin
      num_blocks := directory[0].deovblk - start_block;
      if (num_blocks > 32) then num_blocks := 32;
      chars_read := num_blocks * 512;
      unitread(read_unit, buffer, chars_read, start_block);
      for j := 1 to num_entries do begin { scan for each entry }
         start_char := 0; len := chars_read - 1; done := false;
         repeat { until not found in buffer }
            k := scan(len,=dict[j,1],buffer[start_char]);
            start_char := start_char + k + 1;
            if (k < len) then begin { found initial char }
               l := 2; found := true;
               while (l <= length(dict[j])) and found do begin{ finish compare }
                  if (dict[j][l] <> buffer[start_char+l-2]) then
                     found := false;
                  l := l + 1;
                  end; { while }
               if found then tell_found;
               end { if }
            else done := true;
            len := len - k - 1;
            until done;
         end; { for j }
      { re-scan last block in case key word ran across block boundary }
      start_block := start_block + 31;
      end; { for i }
   end.




========================================================================================
DOCUMENT :usus Folder:VOL14:sorts1.text
========================================================================================

PROGRAM RANDOM1;{Bubblesort as the sort method}
CONST MAXSIZE=500;
VAR SEED:REAL;
DIDSWAP:BOOLEAN;
TIMEDIFF,HITIME,LO1TIME,LO2TIME,X,Y:INTEGER;
SCALAR:ARRAY[1..MAXSIZE] OF INTEGER;

PROCEDURE SWAP (VAR I,J:INTEGER);
VAR TEMP:INTEGER;
BEGIN
   TEMP:=I;
   I:=J;
   J:=TEMP;
END;

PROCEDURE SORT;
VAR COUNTER:INTEGER;
BEGIN
DIDSWAP:=FALSE;
   FOR COUNTER:=1 TO MAXSIZE-1 DO
   BEGIN
      IF SCALAR[COUNTER]>SCALAR[COUNTER+1] THEN
         BEGIN
         SWAP(SCALAR[COUNTER],SCALAR[COUNTER+1]);
         DIDSWAP:=TRUE;
         END;
   END;
END;

FUNCTION RANDOM:INTEGER;
BEGIN
SEED:=SEED*27.182813+31.415917;
SEED:=SEED-TRUNC(SEED);
IF SEED<0 THEN
   SEED:=-SEED;
RANDOM:=TRUNC(SEED*50+1);
END;

BEGIN
TIME(HITIME,LO1TIME);
SEED:=1.23456789;
FOR X:=1 TO MAXSIZE DO
   SCALAR[X]:=RANDOM;
FOR Y:=1 TO MAXSIZE DO
   WRITE(SCALAR[Y]:4);
X:=1;
REPEAT
   BEGIN
   SORT;
   WRITELN('IN ITERATION ',X,' OF SWAP-REPEAT LOOP');
   X:=X+1;
   END;
UNTIL DIDSWAP=FALSE;
FOR Y:=1 TO MAXSIZE DO
   WRITE(SCALAR[Y]:4);
TIME(HITIME,LO2TIME);
TIMEDIFF:=LO2TIME-LO1TIME;
IF TIMEDIFF<0 THEN
   TIMEDIFF:=TIMEDIFF+32767;
WRITELN(TIMEDIFF DIV 60,'.',(100*(TIMEDIFF MOD 60) DIV 60),' seconds');
END.

========================================================================================
DOCUMENT :usus Folder:VOL14:sorts2.text
========================================================================================

PROGRAM RANDOM2;{Straight Selection sort as the sort method}
CONST MAXSIZE=500;
TYPE INDEX=0..MAXSIZE;
VAR SEED:REAL;
DIDSWAP:BOOLEAN;
TIMEDIFF,HITIME,LO1TIME,LO2TIME,X,Y:INTEGER;
SCALAR:ARRAY[1..MAXSIZE] OF INTEGER;

PROCEDURE SELECTSORT;
VAR I,J,K:INDEX;
        X:INTEGER;
BEGIN
   FOR I:=1 TO MAXSIZE-1 DO
   BEGIN
      K:=I;
      X:=SCALAR[I];
      FOR J:=I+1 TO MAXSIZE DO
         IF SCALAR[J]<X THEN
            BEGIN
            K:=J;
            X:=SCALAR[J];
            END;
         SCALAR[K]:=SCALAR[I];
         SCALAR[I]:=X;
   END;
END;

FUNCTION RANDOM:INTEGER;
BEGIN
SEED:=SEED*27.182813+31.415917;
SEED:=SEED-TRUNC(SEED);
IF SEED<0 THEN
   SEED:=-SEED;
RANDOM:=TRUNC(SEED*50+1);
END;

BEGIN
TIME(HITIME,LO1TIME);
SEED:=1.23456789;
FOR X:=1 TO MAXSIZE DO
   SCALAR[X]:=RANDOM;
FOR Y:=1 TO MAXSIZE DO
   WRITE(SCALAR[Y]:4);
SELECTSORT;
FOR Y:=1 TO MAXSIZE DO
   WRITE(SCALAR[Y]:4);
TIME(HITIME,LO2TIME);
TIMEDIFF:=LO2TIME-LO1TIME;
IF TIMEDIFF<0 THEN
   TIMEDIFF:=TIMEDIFF+32767;
WRITELN(TIMEDIFF DIV 60,'.',(100*(TIMEDIFF MOD 60) DIV 60),' seconds');
END.

========================================================================================
DOCUMENT :usus Folder:VOL14:sorts3.text
========================================================================================

PROGRAM RANDOM3;{Recursive quicksort as sort method}
CONST MAXSIZE=500;
TYPE INDEX=0..MAXSIZE;
VAR SEED:REAL;
DIDSWAP:BOOLEAN;
TIMEDIFF,HITIME,LO1TIME,LO2TIME,X,Y:INTEGER;
SCALAR:ARRAY[1..MAXSIZE] OF INTEGER;

PROCEDURE QUICKSORT;
   PROCEDURE SORT (L,R:INDEX);
   VAR I,J:INDEX;
   X,W:INTEGER;
   BEGIN
   I:=L;
   J:=R;
   X:=SCALAR[(L+R) DIV 2];
   REPEAT
      WHILE SCALAR[I]<X DO
         I:=I+1;
      WHILE X<SCALAR[J] DO
         J:=J-1;
      IF I<=J THEN
      BEGIN
         W:=SCALAR[I];
         SCALAR[I]:=SCALAR[J];
         SCALAR[J]:=W;
         I:=I+1;
         J:=J-1;
      END;
   UNTIL I>J;
   IF L<J THEN
      SORT(L,J);
   IF I<R THEN
      SORT(I,R);
   END;
BEGIN{quicksort}
   SORT(1,MAXSIZE);
END;{quicksort}

FUNCTION RANDOM:INTEGER;
BEGIN
SEED:=SEED*27.182813+31.415917;
SEED:=SEED-TRUNC(SEED);
IF SEED<0 THEN
   SEED:=-SEED;
RANDOM:=TRUNC(SEED*50+1);
END;

BEGIN
TIME(HITIME,LO1TIME);
SEED:=1.23456789;
FOR X:=1 TO MAXSIZE DO
   SCALAR[X]:=RANDOM;
FOR Y:=1 TO MAXSIZE DO
   WRITE(SCALAR[Y]:4);
QUICKSORT; 
FOR Y:=1 TO MAXSIZE DO
   WRITE(SCALAR[Y]:4);
TIME(HITIME,LO2TIME);
TIMEDIFF:=LO2TIME-LO1TIME;
IF TIMEDIFF<0 THEN
   TIMEDIFF:=TIMEDIFF+32767;
WRITELN(TIMEDIFF DIV 60,'.',(100*(TIMEDIFF MOD 60) DIV 60),' seconds');
END.

========================================================================================
DOCUMENT :usus Folder:VOL14:sorts4.text
========================================================================================

PROGRAM RANDOM4;{Non-Recursive quicksort as sort method}
CONST MAXSIZE=500;
TYPE INDEX=0..MAXSIZE;
VAR SEED:REAL;
DIDSWAP:BOOLEAN;
TIMEDIFF,HITIME,LO1TIME,LO2TIME,X,Y:INTEGER;
SCALAR:ARRAY[1..MAXSIZE] OF INTEGER;

PROCEDURE QUICKSORT;
CONST M=12;
VAR I,J,L,R:INDEX;
    X,W:INTEGER;
    S:0..M;
    STACK:ARRAY [1..M] OF
       RECORD 
          L,R:INDEX
       END;
BEGIN
S:=1;
STACK[1].L:=1;
STACK[1].R:=MAXSIZE;
   REPEAT{take top request from stack}
   L:=STACK[S].L;
   R:=STACK[S].R;
   S:=S-1;
      REPEAT {split SCALAR[L] . . . SCALAR[R]}
      I:=L;
      J:=R;
      X:=SCALAR[(L+R) DIV 2];
         REPEAT
         WHILE SCALAR[I]<X DO
            I:=I+1;
         WHILE X<SCALAR[J] DO
            J:=J-1;
         IF I<=J THEN
         BEGIN
            W:=SCALAR[I];
            SCALAR[I]:=SCALAR[J];
            SCALAR[J]:=W;
            I:=I+1;
            J:=J-1;
         END;
         UNTIL I>J;
      IF I<R THEN
      BEGIN{stack request to sort right partition}
         S:=S+1;
         STACK[S].L:=I;
         STACK[S].R:=R;
      END;
      R:=J;
   UNTIL L>=R;
UNTIL S=0;
END;{quicksort}
      
FUNCTION RANDOM:INTEGER;
BEGIN
SEED:=SEED*27.182813+31.415917;
SEED:=SEED-TRUNC(SEED);
IF SEED<0 THEN
   SEED:=-SEED;
RANDOM:=TRUNC(SEED*50+1);
END;

BEGIN
TIME(HITIME,LO1TIME);
SEED:=1.23456789;
FOR X:=1 TO MAXSIZE DO
   SCALAR[X]:=RANDOM;
FOR Y:=1 TO MAXSIZE DO
   WRITE(SCALAR[Y]:4);
QUICKSORT; 
FOR Y:=1 TO MAXSIZE DO
   WRITE(SCALAR[Y]:4);
TIME(HITIME,LO2TIME);
TIMEDIFF:=LO2TIME-LO1TIME;
IF TIMEDIFF<0 THEN
   TIMEDIFF:=TIMEDIFF+32767;
WRITELN(TIMEDIFF DIV 60,'.',(100*(TIMEDIFF MOD 60) DIV 60),' seconds');
END.

========================================================================================
DOCUMENT :usus Folder:VOL14:sparse.gpat
========================================================================================

+-----------------------------------------------------------------------------+||                                                                             |||                -------- ---------------- -------                            |||            |                                     |                          |||            |                                     |                          |||  --------- |                                     |   ------------------     |||            |                                     |                          ||+-                   +--------   ---------+                                 -+|||            |       |                    |        |                          |||            |       |                    |        |                          |||  --------- |                                     |    ------------------    |||            |       |                    |        |                          |||                    |                    |                                   ||+-           |       +--------   ---------+        |                         -+||            |                                     |                          |||  --------- |                                     |    -----------------     |||            |                                     |                          |||            |                                     |                          |||                                                                             |||                -------- ------------------ -----                            |||                                                                             |||                               |                                             ||+-------------------------------+---------------------------------------------+|                                                                                                                                                                                                                  1       2       $EQUAL  $CURSOR                                                                                                                                                                                                                                                                         
========================================================================================
DOCUMENT :usus Folder:VOL14:srccom.text
========================================================================================

{
        SRCCOM - source file comparison program.
                 adapted from program COMPARE,
                 Pascal News #12.
 
        Copyright (C) 1977,1978
        James F. Miner
        Social Science Research Facilities Center
        25 Blegan Hall
        269 19th Ave. So
        University of Minnesota
        Minneapolis, Minnesota 55455
 
        General permission to make fair use in non-profit activites
        of all or part of this material is granted provided that this
        is given.
}

PROGRAM SRCCOM;
  USES (*$U FASTREAD.CODE*) FASTREAD;
  { Reference: Pascal News, Issue 13 }
  CONST
    VERSION = '1.3';
    LINELENGTH = 120;
    MINLINESFORMATCH = 6;
    
  TYPE
    LINEPOINTER = ^LINE;
    LSTRING = LONGSTRING;
    LINE = 
      PACKED RECORD
        NEXTLINE: LINEPOINTER;
        IMAGE: LSTRING
      END;
      
    STREAM =
      RECORD
        CURSOR, HEAD, TAIL: LINEPOINTER;
        CURSORLINENO, HEADLINENO, TAILLINENO: INTEGER;
        ENDFILE: BOOLEAN
      END;
      
    VAR
      OUTFILE:          TEXT;
      FILEA, FILEB:     FFILE;
      FCBA,  FCBB:      FCB;
      A, B:             STREAM;
      MATCH:            BOOLEAN;
      ENDFILE:          BOOLEAN;
      OUTLFN, NAME1, NAME2: STRING[30];
      
      TEMPLINE: LSTRING;
        
      FREELINES: LINEPOINTER;
      
      SAME: BOOLEAN;
      
    PROCEDURE COMPAREFILES;
    
      FUNCTION ENDSTREAM(VAR X: STREAM): BOOLEAN;
      BEGIN { ENDSTREAM }
        ENDSTREAM := (X.CURSOR = NIL) AND X.ENDFILE
      END;  { ENDSTREAM }
      
      PROCEDURE MARK(VAR X: STREAM);
        VAR 
          P: LINEPOINTER;
      BEGIN { MARK }
        WITH X DO
          IF HEAD <> NIL THEN
            BEGIN
              WHILE HEAD <> CURSOR DO
                BEGIN
                  WITH HEAD^ DO
                    BEGIN P := NEXTLINE;
                      NEXTLINE := FREELINES;
                      FREELINES := HEAD
                    END;
                  HEAD := P;
                END;
              HEADLINENO := CURSORLINENO;
              IF CURSOR = NIL THEN
                BEGIN TAIL := NIL; TAILLINENO := CURSORLINENO END;
            END
      END;  { MARK }

      PROCEDURE MOVECURSOR(VAR X: STREAM; VAR FCBX: FCB; VAR INFILE: FFILE);
      
        PROCEDURE READLINE;
          VAR
            NEWLINE: LINEPOINTER;
            J: INTEGER; 
        BEGIN { READLINE }
          IF NOT X.ENDFILE THEN
            BEGIN
              GETSTRING(FCBX, INFILE, TEMPLINE);
              NEWLINE := FREELINES;
              IF NEWLINE = NIL THEN NEW(NEWLINE)
              ELSE FREELINES := FREELINE^.NEXTLINE;
              NEWLINE^.IMAGE := TEMPLINE;
              NEWLINE^.NEXTLINE := NIL;
              IF X.TAIL = NIL THEN
                BEGIN X.HEAD := NEWLINE;
                  X.TAILLINENO := 1; X.HEADLINENO := 1
                END
              ELSE
                BEGIN X.TAIL^.NEXTLINE := NEWLINE;
                  X.TAILLINENO := X.TAILLINENO + 1;
                END;
              X.TAIL := NEWLINE;
              X.ENDFILE := FCBX.ENDFILE;
            END
        END; { READLINE }
        
      BEGIN { MOVECURSOR }
        IF X.CURSOR <> NIL THEN
          BEGIN
            IF X.CURSOR = X.TAIL THEN READLINE;
            X.CURSOR := X.CURSOR^.NEXTLINE;
            IF X.CURSOR = NIL THEN ENDFILE := TRUE;
            X.CURSORLINENO := X.CURSORLINENO + 1;
          END
        ELSE
          IF NOT X.ENDFILE THEN
            BEGIN
              READLINE; X.CURSOR := X.HEAD;
              X.CURSORLINENO := X.HEADLINENO;
            END
          ELSE
            ENDFILE := TRUE;
      END; { MOVECURSOR }
                
              
      PROCEDURE BACKTRACK(VAR X: STREAM; VAR XLINES: INTEGER);
      BEGIN { BACKTRACK }
        XLINES := X.CURSORLINENO + 1 - X.HEADLINENO;
        X.CURSOR := X.HEAD; X.CURSORLINENO := X.HEADLINENO;
        ENDFILE := ENDSTREAM(A) OR ENDSTREAM(B)
      END;  { BACKTRACK }
      
      PROCEDURE COMPARELINES(VAR MATCH: BOOLEAN);
      BEGIN { COMPARELINES }
        IF (A.CURSOR = NIL) OR (B.CURSOR = NIL) THEN
          MATCH := ENDSTREAM(A) AND ENDSTREAM(B)
        ELSE
          MATCH := (A.CURSOR^.IMAGE = B.CURSOR^.IMAGE);
      END;  { COMPARELINES }
      
      PROCEDURE FINDMISMATCH;
      BEGIN { FINDMISMATCH }
        REPEAT { COMPARENEXTLINES }
          MOVECURSOR(A, FCBA, FILEA); MOVECURSOR(B, FCBB, FILEB);
          MARK(A); MARK(B);
          COMPARELINES(MATCH);
        UNTIL ENDFILE OR NOT MATCH;
      END;  { FINDMISMATCH }
      
      PROCEDURE FINDMATCH;
        VAR ADVANCEB: BOOLEAN;
        
        PROCEDURE SEARCH(VAR X: STREAM; VAR FCBX: FCB; VAR FILEX: FFILE;
                         VAR Y: STREAM; VAR FCBY: FCB; VAR FILEY: FFILE);
          VAR COUNT: INTEGER;
          
          PROCEDURE CHECKFULLMATCH;
            VAR N: INTEGER;
              SAVEXCUR, SAVEYCUR: LINEPOINTER;
              SAVEXLINE, SAVEYLINE: INTEGER;
          BEGIN { CHECKFULLMATCH }
            SAVEXCUR := X.CURSOR; SAVEYCUR := Y.CURSOR;
            SAVEXLINE := X.CURSORLINENO; SAVEYLINE := Y.CURSORLINENO;
            COMPARELINES(MATCH);
            N := MINLINESFORMATCH - 1;
            WHILE MATCH AND (N <> 0) DO
              BEGIN MOVECURSOR(X, FCBX, FILEX); MOVECURSOR(Y, FCBY, FILEY);
                COMPARELINES(MATCH); N := N - 1;
              END;
            X.CURSOR := SAVEXCUR; X.CURSORLINENO := SAVEXLINE;
            Y.CURSOR := SAVEYCUR; Y.CURSORLINENO := SAVEYLINE;
          END;  { CHECKFULLMATCH }

        BEGIN { SEARCH }
          MOVECURSOR(Y, FCBY, FILEY); BACKTRACK(X, COUNT);
          CHECKFULLMATCH; COUNT := COUNT - 1;
          WHILE (COUNT <> 0) AND NOT MATCH DO
            BEGIN
              MOVECURSOR(X, FCBX, FILEY); COUNT := COUNT - 1;
              CHECKFULLMATCH;
            END
        END;  { SEARCH }
        
        PROCEDURE PRINTMISMATCH;
          VAR
            EMPTYA, EMPTYB: BOOLEAN;
            
          PROCEDURE WRITETEXT(P, Q: LINEPOINTER);
          BEGIN { WRITETEXT }
            WRITELN(OUTFILE);
            WHILE (P <> NIL) AND (P <> Q) DO
              BEGIN WRITE(OUTFILE, ' * ');
                WITH P^ DO
                  WRITELN(OUTFILE, IMAGE);
                P := P^.NEXTLINE
              END;
            IF P = NIL THEN WRITELN(OUTFILE, ' *** EOF ***');
            WRITELN(OUTFILE);
          END; { WRITETEXT }
          
          PROCEDURE WRITELINENO(VAR X: STREAM);
            VAR
              F, L: INTEGER;
          BEGIN { WRITELINENO }
            F := X.HEADLINENO; L := X.CURSORLINENO - 1;
            WRITE(OUTFILE, 'LINE');
            IF F = 1 THEN WRITE(OUTFILE, ' ', F:1)
            ELSE WRITE(OUTFILE, 'S ', F:1, ' TO ', L:1);
            IF X.CURSOR = NIL THEN WRITE(OUTFILE, ' (BEFORE EOF)');
          END;  { WRITELINENO }
          
          PROCEDURE PRINTEXTRATEXT(VAR X: STREAM; XNAME: STRING;
                                   VAR Y: STREAM; YNAME: STRING);
          BEGIN { PRINTEXTRATEXT }
            WRITE(OUTFILE, ' EXTRA TEXT ON "', XNAME, '", ');
            WRITELINENO(X); WRITELN(OUTFILE);
            IF Y.HEAD = NIL THEN
              WRITELN(OUTFILE, ' BEFORE EOF ON FILE "', YNAME, '"')
            ELSE
              WRITELN(OUTFILE, ' BETWEEN LINES ', Y.HEADLINENO-1:1, ' AND ',
                Y.HEADLINENO:1, ' OF "', YNAME, '"');
            WRITETEXT(X.HEAD, X.CURSOR)
          END;  { PRINTEXTRATEXT }
          
        BEGIN { PRINTMISMATCH }
          WRITELN(OUTFILE, '***************************************');
          EMPTYA := (A.HEAD = A.CURSOR);
          EMPTYB := (B.HEAD = B.CURSOR);
          IF EMPTYA OR EMPTYB THEN
            IF EMPTYA THEN PRINTEXTRATEXT(B, NAME2, A, NAME1)
            ELSE PRINTEXTRATEXT(A, NAME1, B, NAME2)
          ELSE
            BEGIN
              WRITELN(OUTFILE, ' MISMATCH:'); WRITELN(OUTFILE);
              WRITE(OUTFILE, ' "', NAME1, '", '); WRITELINENO(A); WRITELN(OUTFILE, ':');
              WRITETEXT(A.HEAD, A.CURSOR);
              WRITE(OUTFILE, ' "', NAME2, '", '); WRITELINENO(B); WRITELN(OUTFILE, ':');
              WRITETEXT(B.HEAD, B.CURSOR)
            END
        END; { PRINTMISMATCH }
        
      BEGIN { FINDMATCH }
        ADVANCEB := TRUE;
        REPEAT
          IF NOT ENDFILE THEN ADVANCEB := NOT ADVANCEB
          ELSE ADVANCEB := ENDSTREAM(A);
          IF ADVANCEB THEN SEARCH(A, FCBA, FILEA, B, FCBB, FILEB)
          ELSE SEARCH(B, FCBB, FILEB, A, FCBA, FILEA)
        UNTIL MATCH;
        PRINTMISMATCH;
      END; { FINDMISMATCH }
      
  BEGIN { COMPAREFILES }
    MATCH := TRUE;
    REPEAT 
      IF MATCH THEN FINDMISMATCH
      ELSE
        BEGIN
          SAME := FALSE;
          FINDMATCH
        END
    UNTIL ENDFILE AND MATCH
  END;  { COMPAREFILES }
  
  PROCEDURE INITIALIZE;
  
    PROCEDURE INITSTREAM(VAR X: STREAM; VAR FCBX: FCB;
                         VAR FILEX: FFILE; VAR LFN: STRING);
    BEGIN { INITSTREAM }
      WITH X DO
        BEGIN
          CURSOR := NIL; TAIL := NIL;
          CURSORLINENO := 0; HEADLINENO := 0; TAILLINENO := 0
        END;
      WRITE('File name: ');
      READLN(LFN);
      OPENFILE(FCBX, FILEX, LFN);
      X.ENDFILE := FCBX.ENDFILE;
    END; { INITSTREAM }
    
  BEGIN { INITIALIZE }
    INITSTREAM(A, FCBA, FILEA, NAME1); INITSTREAM(B, FCBB, FILEB, NAME2);
    ENDFILE := A.ENDFILE OR B.ENDFILE;
    FREELINES := NIL;
    WRITE('Output file? '); READLN(OUTLFN); 
    IF OUTLFN = '' THEN OUTLFN := 'CONSOLE:';
    REWRITE(OUTFILE, OUTLFN);
  END;  { INITIALIZE }
  
BEGIN { COMPARE }
  INITIALIZE;
  PAGE(OUTFILE);
  WRITELN(OUTFILE, 'SRCCOM - V', VERSION);
  WRITELN(OUTFILE);
  WRITELN(OUTFILE, ' Match criterion = ', MINLINESFORMATCH:1, ' lines.');
  WRITELN(OUTFILE);
  IF A.ENDFILE THEN WRITELN(OUTFILE, '"', NAME1, ' IS EMPTY.');
  IF B.ENDFILE THEN WRITELN(OUTFILE, '"', NAME2, ' IS EMPTY.');
  IF NOT ENDFILE THEN
    BEGIN 
      SAME := TRUE;
      COMPAREFILES;
      IF SAME THEN WRITELN(OUTFILE, ' NO DIFFERENCES.')
    END;
  CLOSE(OUTFILE, LOCK);
END. { COMPARE }
       

========================================================================================
DOCUMENT :usus Folder:VOL14:stock.data.text
========================================================================================

Astro City Bonds
50
Bigg Corporation
1
Metro Properties
0
Pioneer Mutal
4
Oak Creek Realty
7
Standard Drilling
0
City Bus Lines
0
Tiny Auto Company
2
Uranium Mining
6
Valley Electric
3
  12   7   9   7   8   6   5  -2  11  -5  -8
  14  -6  10   8   6   4   7   6  11  13 -10
  13  10   7   5   4   3  -1  -3  -5  -8 -10
  10 -10  -5  -6  -4   3  -3  -8  -7   6 -15
  10  30 -20 -40  40 -15  45 -20  30  25 -20
  20   6  12   3   8   5   6   7  10   4 -20
  21 -19  21  16   4   8 -10  10 -11  18 -23
  25  22  18 -14 -12  -8  10  14 -18 -22 -25
   8  -2   7   4   3   5   4   6  -4  -4  -7
  -2  26  18  23  20  17  19  11  13  14  24
 -10  16  23  28  15  21  24  18  31  -8  24
  -7  25  11  -2  15  13  17  14   1  19  23
  -9   8  12  11   7  -2   9  11  14  -1  20
  -2 -14  46  56 -20  37  -5  67 -11   9  51
  -9  21  18  19  15  23  26  15  18  25  27
  -7  14  -5  30  13  23  13  22  18 -10  38
 -16  -4  34  29 -10  19  -7  18 -14  13  33
  -4  17  15  14  12  14  15  13  10  19  18


========================================================================================
DOCUMENT :usus Folder:VOL14:stock.doc.text
========================================================================================

17 September 1980

I am not aware of any portion of this program as being from another program.
Stock is a computer implementation of a bookshelf game "Stocks & Bonds" owned
and published by Avalon Hill.

The program was developed on a Heathkit (H-11) and a Southwest Technical
Products (SWTP-82) terminial using Pascal II.0.

The idiosyncrasies of the program are:

1.  It is scope dependent.

2.  I have no random number generator and I am simulating one from the line
    clock.  Therefore, there must be a line clock and it must be on.
    [changed to detect presence of clock and prompt for seed if no clock  gws]

3.  It uses CHR(12), form feed, to clear the screen and home the cursor.
    [ changed to H-19 codes   gws]

4.  The program data is initialized from a text file named
    STOCK:STOCK.DATA.TEXT
    [changed to #5:STOCK.DATA.TEXT gws] 

Questions can be directed to:

Homer Baker
Phoenix Union High School District
2526 W. Osborn Road
Phoenix, AZ  85017

Phone:(602) 257-3086
Home :(602) 967-0064


========================================================================================
DOCUMENT :usus Folder:VOL14:stock.text
========================================================================================

{$S+}
program stockmarket;
type
        share=record
          amount:0..500;
          value:integer[7];
        end;
        stock=record
                name:string[20];
                value:share;
                dividend:integer;
              end;
        player=record
                name:string[10];
                value:array[1..10] of share;
                dividend,turn:integer;
                cash:integer[10];
               end;
        table=(bear,bull);
var
        market:array[table] of array[2..10] of array[2..12] of integer;
        stocks:array[1..10] of stock;
        players:array[1..9] of player;
        num:string[3];
        ch:char;
        hi,lo1,lo2,seed,currentp,currents,year:integer;
        nplayer:1..9;

procedure clear_screen;
begin
   write ( chr ( 27 ), chr ( 69 ) ) ;  {H-19 specific   gws}
end;

procedure clear_line;
begin
   write ( chr ( 27 ), chr ( 75 ) );  {H-19 specific    gws}
end;

procedure clear;
begin
  gotoxy(0,16);
  writeln('                                                                ');
  writeln('                                                                ');
  writeln('                                                                ');
  gotoxy(0,16)
end;

function number:integer;
var     n,i:integer;
begin
n:=0;
for i:=1 to length(num) do
  if ord(num[i])>47 then
    if ord(num[i])<58 then
      n:=n*10+(ord(num[i])-48)
    else
      begin
        clear;
        writeln('          Type digits please.');
        n:=0
      end;
number:=n;
end;

function upper(cha:char):char;
begin
  if ord(cha)>96 then if ord(cha)<123 then upper:=chr(ord(cha)-32)
    else upper:=cha else upper:=cha;
end;

procedure gameconst;
var     i,j:integer;
        k:table;
        f:interactive;
begin   reset(f,'#5:STOCK.DATA.TEXT');
        writeln('Stocks:':20,'Dividends per year');
        for i:=1 to 10 do
          begin
            readln(f,stocks[i].name);
            readln(f,stocks[i].dividend);
            writeln(stocks[i].name:20,stocks[i].dividend:4);
          end;
        for k:=bear to bull do
        for j:=2 to 10 do
          begin
            for i:=2 to 12 do read(f,market[k,j,i]);
            readln(f);
          end;
        close(f);
  end;

procedure initialize;
var     i,j:integer;
begin
        for i:= 1 to 10 do
          begin
            if i=1 then 
              begin
                stocks[i].value.amount:=50;
                stocks[i].value.value:=1000
              end
            else
              begin
                stocks[i].value.amount:=500;
                stocks[i].value.value:=100;
              end;
        if i<10 then
          begin
            for j:=1 to 10 do
              begin
                players[i].value[j].amount:=0;
                players[i].value[j].value:=0;
                players[i].dividend:=0;
                players[i].turn:=i;
                players[i].cash:=5000;
              end;
          end;
       end;
  end;

procedure playersname;
var     i,j:integer;
begin
        write('How many players (1..9)?');
        read(ch);
        nplayer:=ord(ch)-48;
        writeln;
        for i:=1 to nplayer do
          begin
            write('Enter name of player ',i:1,' ');
            readln(players[i].name);
            if length(players[i].name)=0 then i:=i-1;
          end;
end;

function random:real;
 begin
  random := seed/32767;
  seed := ( 103 * seed + 1999 ) mod 32767;
  if seed < 0 then seed := seed * ( -1 );
end; {random}

function irandom(low,high:integer):integer;
{irandom produces integer numbers
ranging from low to high}
        begin irandom:=trunc(random*(high-low+0.9)+low) end;

function dieroll:integer;
        begin dieroll:=irandom(1,6) end;

procedure game;
var     i,j,k:integer;
 
 procedure disstock(i:integer);
        begin
          gotoxy(0,i+3);
          writeln(stocks[i].name:20
                ,stocks[i].value.value:4,stocks[i].value.amount:4);
        end;

 procedure shostock;
 var     i:integer;
        begin
          clear_screen;
          writeln('                    Year 198',year:1);
          writeln('Stock');
          gotoxy(18,2);
          writeln('Value Avail');
          for i:=1 to 10 do disstock(i);
        end;

 procedure update;
 var     j,k:integer;
        i:table;

procedure split(k:integer);
var     i,j:integer;
begin {split}
          stocks[k].value.value:=stocks[k].value.value div 2;
          for i:=1 to nplayer do
            for j:=1 to nplayer do
              if i=players[j].turn then
                begin
                  if players[j].value[k].amount<= stocks[k].value.amount then
                    begin
                      stocks[k].value.amount:=stocks[k].value.amount-
                        players[j].value[k].amount;
                      players[j].value[k].amount:=players[j].value[k].amount 
                        * 2
                    end
               else
                 begin
                   players[j].cash:=players[j].cash+
                     ((players[j].value[k].amount-stocks[k].value.amount)
                     *stocks[k].value.value);
                   players[j].value[k].amount:=players[j].value[k].amount
                     +stocks[k].value.amount;
                   stocks[k].value.amount:=0
                 end
               end;
end; {split}

procedure paydiv;
var     play,stoq:integer;
begin
for play:=1 to 9 do
  begin
    players[play].dividend:=0;
    for stoq:=1 to 10 do
      begin
        players[play].value[stoq].value:=players[play].value[stoq].amount
          *stocks[stoq].value.value;
        if stocks[stoq].value.value>49 then
          players[play].dividend:=players[play].dividend
            +players[play].value[stoq].amount*stocks[stoq].dividend
      end;
  players[play].cash:=players[play].cash+players[play].dividend;
  end;
end;

procedure bust(stoq:integer);
var     i:integer;
begin
  stocks[stoq].value.value:=0;
  stocks[stoq].value.amount:=0;
  for i:=1 to nplayer do
    begin
      players[i].value[stoq].amount:=0;
      players[i].value[stoq].value:=0
    end;
end;

begin {update}
          if irandom(1,2)=1 then i:=bull else i:=bear;
          j:=dieroll+dieroll;
          for k:=2 to 10 do
          begin
            if stocks[k].value.value=0 then
              begin
                stocks[k].value.amount:=500;
                stocks[k].value.value:=100
              end;
            stocks[k].value.value:=stocks[k].value.value+market[i,k,j];
            if stocks[k].value.value>150 then split(k);
            if stocks[k].value.value<1 then bust(k);
          end;
          paydiv;
          shostock;
        end; {update}

 procedure plystock(play,stoq:integer);
        begin
          gotoxy(30,stoq+3);
          writeln(players[play].value[stoq].amount:4,
                  players[play].value[stoq].value:6);
        end;

 procedure shoplay(play:integer);
 var     i:integer;
        begin
          gotoxy(28,1);
          writeln(players[play].name:10);
          gotoxy(30,2);
          writeln('Shares Value');
          for i:=1 to 10 do plystock(play,i);
          gotoxy(24,14);
          writeln('Dividends ',players[play].dividend:6);
          gotoxy(29,15);
          writeln('Cash ',players[play].cash:6);
          clear
        end;

 procedure seturn;
 var     i,r,x:integer;
        begin
          for i:=1 to nplayer do
            begin
              r:=irandom(1,nplayer);
              x:=players[i].turn;
              players[i].turn:=players[r].turn;
              players[r].turn:=x;
            end;
        end;

procedure transak(play,tran,stoq:integer);
var     n:integer;
begin
  gotoxy(0,16);
  clear_line;
  If tran<0 then write('Sell ') else write('Buy ');
  write('how many shares of ',stocks[stoq].name);
  readln(num);
  n:=number;
  if tran<0 then 
    begin
     if players[play].value[stoq].amount<n then
       begin
         gotoxy(0,16);
         clear_line;
         writeln('You do not have ',n,' shares to sell.')
       end
     else
       begin
         players[play].cash:=players[play].cash+n*stocks[stoq].value.value;
         stocks[stoq].value.amount:=stocks[stoq].value.amount+n;
         players[play].value[stoq].amount:=players[play].value[stoq].amount
           -n;
         players[play].value[stoq].value:=players[play].value[stoq].amount
           *stocks[stoq].value.value;
         gotoxy(29,15);
         writeln('Cash ',players[play].cash:6);
         disstock(stoq);
         plystock(play,stoq)
       end
     end
 else
   begin
     if stocks[stoq].value.amount<n then
       begin
         gotoxy(0,16);
         clear_line;
         writeln('There are not ',n,' shares on the open market')
       end
     else
       if players[play].cash<stocks[stoq].value.value*n then
         begin
           gotoxy(0,16);
           clear_line;
           writeln('You do not have the cash to buy.')
         end
       else
         begin
           players[play].cash:=players[play].cash-n
             *stocks[stoq].value.value;
           players[play].value[stoq].amount:=players[play].value[stoq].amount
             +n;
           stocks[stoq].value.amount:=stocks[stoq].value.amount-n;
           players[play].value[stoq].value:=players[play].value[stoq].amount
             *stocks[stoq].value.value;
           gotoxy(29,15);
           writeln('Cash ',players[play].cash:6);
           disstock(stoq);
           plystock(play,stoq)
         end;
     end;
  end;

procedure getstk(play,tran:integer);
var     i:integer;
begin
  gotoxy(0,16);
  clear_line;
  if tran<0 then write('Sell ') else write('Buy ');
  write('which stock (type first letter)');
  read(ch);
  ch:=upper(ch);
  for i:=1 to 10 do if ch=stocks[i].name[1] then transak(play,tran,i);
end;

procedure playturn(play:integer);
var     i,j:integer;
begin
  shoplay(play);
  repeat
    gotoxy(0,17);
    clear_line;
    write(players[play].name:10,' B(uy, S(ell, F(inished');
    read(ch);
    ch:=upper(ch);
    i:=0;
    if ch='S' then i:=-1;
    if ch='B' then i:=1;
    if i<>0 then getstk(play,i)
  until ch='F';
end;

begin {game}
        for year:=0 to 9 do
          begin
            update;
            seturn;
            for i:=1 to nplayer do
              for j:=1 to nplayer do
                if i=players[j].turn then playturn(j);
          end;
end; {game}

procedure finish;
var     cash:integer[10];
        play,stoq:integer;
begin
  clear_screen;
  for play:=1 to nplayer do
    begin
      cash:=players[play].cash;
      for stoq:=1 to 10 do
        begin
          cash:=cash+players[play].value[stoq].value
        end;
      writeln(players[play].name:10,' $',cash:10)
    end;
end;

begin{stockmarket}
        clear_screen;
        time ( hi, lo1 );
        for hi := 1 to 1000 do ;
        time ( hi, lo2 );
        if lo2 = lo1 then 
           begin
              write ( 'no clock, please type an integer ' );
              readln ( seed );
           end
        else seed := lo2;
        clear_screen;
        gameconst;
        playersname;
        initialize;
        game;
        finish;
end. {stockmarket}


========================================================================================
DOCUMENT :usus Folder:VOL14:table.text
========================================================================================

ACI     $       ADC     $   
ADC     A       ADC     A  
ADC     B       ADC     B  
ADC     C       ADC     C  
ADC     D       ADC     D  
ADC     E       ADC     E  
ADC     H       ADC     H  
ADC     L       ADC     L  
ADC     M       ADC     (HL)
ADD     A       ADD     A    
ADD     B       ADD     B    
ADD     C       ADD     C    
ADD     D       ADD     D    
ADD     E       ADD     E    
ADD     H       ADD     H    
ADD     L       ADD     L    
ADD     M       ADD     (HL)
ADI     $       ADD     $   
ANA     A       AND     A  
ANA     B       AND     B  
ANA     C       AND     C  
ANA     D       AND     D  
ANA     E       AND     E  
ANA     H       AND     H  
ANA     L       AND     L  
ANA     M       AND     (HL)
ANI     $       AND     $   
CALL    $       CALL    $   
CC      $       CALL    C,$   
CM      $       CALL    M,$   
CMA     #       CPL     #        
CMC     #       CCF     #        
CMP     A       CP      A  
CMP     B       CP      B  
CMP     C       CP      C  
CMP     D       CP      D  
CMP     E       CP      E  
CMP     H       CP      H  
CMP     L       CP      L  
CMP     M       CP      (HL)
CNC     $       CALL    NC,$   
CNZ     $       CALL    NZ,$   
CP      $       CALL    P,$   
CPE     $       CALL    PE,$   
CPI     $       CP      $   
CPO     $       CALL    PO,$   
CZ      $       CALL    Z,$   
DAA     #       DAA     #      
DAD     B       ADD     HL,BC 
DAD     D       ADD     HL,DE 
DAD     H       ADD     HL,HL 
DAD     SP      ADD     HL,SP 
DCR     A       DEC     A  
DCR     B       DEC     B  
DCR     C       DEC     C  
DCR     D       DEC     D  
DCR     E       DEC     E  
DCR     H       DEC     H  
DCR     L       DEC     L  
DCR     M       DEC     (HL)
DCX     B       DEC     BC 
DCX     D       DEC     DE 
DCX     H       DEC     HL 
DCX     SP      DEC     SP 
DI      #       DI      #        
EI      #       EI      #        
HLT     #       HALT    #        
IN      $       IN      A,$  
INR     A       INC     A  
INR     B       INC     B  
INR     C       INC     C  
INR     D       INC     D  
INR     E       INC     E  
INR     H       INC     H  
INR     L       INC     L  
INR     M       INC     (HL)
INX     B       INC     BC 
INX     D       INC     DE 
INX     H       INC     HL 
INX     SP      INC     SP 
JC      $       JP      C,$   
JM      $       JP      M,$   
JMP     $       JP      $   
JNC     $       JP      NC,$   
JNZ     $       JP      NZ,$   
JP      $       JP      P,$   
JPE     $       JP      PE,$   
JPO     $       JP      PO,$   
JZ      $       JP      Z,$   
LDA     $       LD      A,($)
LDAX    B       LD      A,(BC)
LDAX    D       LD      A,(DE)
LHLD    $       LD      HL,($)
LXI     B,$     LD      BC,$   
LXI     D,$     LD      DE,$   
LXI     H,$     LD      HL,$   
LXI     SP,$    LD      SP,$   
MOV     A,A     LD      A,A    
MOV     A,B     LD      A,B    
MOV     A,C     LD      A,C    
MOV     A,D     LD      A,D    
MOV     A,E     LD      A,E    
MOV     A,H     LD      A,H    
MOV     A,L     LD      A,L    
MOV     A,M     LD      A,(HL)
MOV     B,A     LD      B,A    
MOV     B,B     LD      B,B    
MOV     B,C     LD      B,C    
MOV     B,D     LD      B,D    
MOV     B,E     LD      B,E    
MOV     B,H     LD      B,H    
MOV     B,L     LD      B,L    
MOV     B,M     LD      B,(HL)  
MOV     C,A     LD      C,A    
MOV     C,B     LD      C,B    
MOV     C,C     LD      C,C    
MOV     C,D     LD      C,D    
MOV     C,E     LD      C,E    
MOV     C,H     LD      C,H    
MOV     C,L     LD      C,L    
MOV     C,M     LD      C,(HL)  
MOV     D,A     LD      D,A    
MOV     D,B     LD      D,B    
MOV     D,C     LD      D,C    
MOV     D,D     LD      D,D    
MOV     D,E     LD      D,E    
MOV     D,H     LD      D,H    
MOV     D,L     LD      D,L    
MOV     D,M     LD      D,(HL)  
MOV     E,A     LD      E,A    
MOV     E,B     LD      E,B    
MOV     E,C     LD      E,C    
MOV     E,D     LD      E,D    
MOV     E,E     LD      E,E    
MOV     E,H     LD      E,H    
MOV     E,L     LD      E,L    
MOV     E,M     LD      E,(HL)  
MOV     H,A     LD      H,A    
MOV     H,B     LD      H,B    
MOV     H,C     LD      H,C    
MOV     H,D     LD      H,D    
MOV     H,E     LD      H,E    
MOV     H,H     LD      H,H    
MOV     H,L     LD      H,L    
MOV     H,M     LD      H,(HL)  
MOV     L,A     LD      L,A    
MOV     L,B     LD      L,B    
MOV     L,C     LD      L,C    
MOV     L,D     LD      L,D    
MOV     L,E     LD      L,E    
MOV     L,H     LD      L,H    
MOV     L,L     LD      L,L    
MOV     L,M     LD      L,(HL)  
MOV     M,A     LD      (HL),A  
MOV     M,B     LD      (HL),B  
MOV     M,C     LD      (HL),C  
MOV     M,D     LD      (HL),D  
MOV     M,E     LD      (HL),E  
MOV     M,H     LD      (HL),H  
MOV     M,L     LD      (HL),L  
MVI     A,$     LD      A,$     
MVI     B,$     LD      B,$     
MVI     C,$     LD      C,$     
MVI     D,$     LD      D,$     
MVI     E,$     LD      E,$     
MVI     H,$     LD      H,$     
MVI     L,$     LD      L,$     
MVI     M,$     LD      (HL),$   
NOP     #       NOP     #        
ORA     A       OR      A  
ORA     B       OR      B  
ORA     C       OR      C  
ORA     D       OR      D  
ORA     E       OR      E  
ORA     H       OR      H  
ORA     L       OR      L  
ORA     M       OR      (HL)
ORI     $       OR      $   
OUT     $       OUT     $,A
PCHL    #       JP      (HL)
POP     B       POP     BC 
POP     D       POP     DE 
POP     H       POP     HL 
POP     PSW     POP     PSW
PUSH    B       PUSH    BC 
PUSH    D       PUSH    DE 
PUSH    H       PUSH    HL 
PUSH    PSW     PUSH    PSW
RAL     #       RLA     #        
RAR     #       RRA     #        
RC      #       RET     C
RET     #       RET     #        
RLC     #       RLCA    #        
RM      #       RET     M
RNC     #       RET     NC
RNZ     #       RET     NZ
RP      #       RET     P
RPE     #       RET     PE
RPO     #       RET     PO
RRC     #       RRCA    #        
RST     $       RST     $ 
RZ      #       RET     Z
SBB     A       SBC     A  
SBB     B       SBC     B  
SBB     C       SBC     C  
SBB     D       SBC     D  
SBB     E       SBC     E  
SBB     H       SBC     H  
SBB     L       SBC     L  
SBB     M       SBC     (HL)
SBI     $       SBC     $   
SHLD    $       LD      ($),HL
SPHL    #       LD      SP,HL
STA     $       LD      ($),A
STAX    B       LD      (BC),A
STAX    D       LD      (DE),A
STC     #       SCF     #        
SUB     A       SUB     A  
SUB     B       SUB     B  
SUB     C       SUB     C  
SUB     D       SUB     D  
SUB     E       SUB     E  
SUB     H       SUB     H  
SUB     L       SUB     L  
SUB     M       SUB     (HL)
SUI     $       SUB     $   
XCHG    #       EX      DE,HL
XRA     A       XOR     A  
XRA     B       XOR     B  
XRA     C       XOR     C  
XRA     D       XOR     D  
XRA     E       XOR     E  
XRA     H       XOR     H  
XRA     L       XOR     L  
XRA     M       XOR     (HL)
XRI     $       XOR     $   
XTHL    #       EX      (SP),HL


========================================================================================
DOCUMENT :usus Folder:VOL14:vol14.doc.text
========================================================================================

                             USUS Library Volume 14
                     Assorted programs from almost everyone

COPVOL.TEXT       18  Jon Bondy's disk copier (will copy Z-80 type boot blocks)
COPVER.ASM.TEXT    8    an external procedure for COPVAL
COPFILE.TEXT      12  Jon Bondy's file copier
COMPFILE.TEXT     10  A binary file comparison program
GAME.TEXT         26  A game with a maze and demons by Jon Bondy
GAME1.TEXT        18    an include file of GAME
DEFAULT.GPAT       4    a data file for GAME
CROSSES.GPAT       4      ditto
SPARSE.GPAT        4      ditto
GAME.ASSEM.TEXT    4    an external procedure for GAME ( keypress )
SCANNER.TEXT      14  A nifty program which looks through a disk for a string
KBSTAT.TEXT        4    my keypress routine (for an H-89)
BONDYSTUFF.TEXT   14  Jon's documemtation
HOME_LOAN.TEXT    10  A simple program to calculate simple loans
BANNER.TEXT       22  Prints banners in BIG letters
STOCK.TEXT        22  A Stock Market game
STOCK.DATA.TEXT    6    a data file for STOCK
STOCK.DOC.TEXT     6    documentation for STOCK
SRCCOM.TEXT       18  A nice source comparison program
FASTREAD.TEXT      8    a unit for SRCCOM
REFERENCE.TEXT    24  A simple but effective procedural cross referencer
REFER.INC.TEXT    22    an include file of REFERENCE
8080CONV.TEXT     26  Converts 8080 instructions to Z-80 instructions
LOOK.UP.TABLE     15    A data file for 8080CONV
TABLE.TEXT        18    The text of the data in case you have to recreate it
REFORM.TEXT        8  A utility for 8080CONV
CALENDAR.TEXT     12  A perpetual calendar ( requires an H-19 )
DAYOFWK.TEXT       8  Calculates the day of the week for any date
LISTINFO.TEXT     36  Generates a report of your *SYSTEM.MISCINFO
SORTS1.TEXT        6  These four programs are demos of four different sorts
SORTS2.TEXT        6 
SORTS3.TEXT        6 
SORTS4.TEXT        6 
HEXDUMP.TEXT      12  Dumps blocks in hex
ROMAN.TEXT        10  Converts decimal dates to Roman numerals
VOL14.DOC.TEXT    14  You're reading it
-------------------------------------------------------------------------------
Please transfer the text below to a disk label if you copy this volume.

    USUS Volume 14 -***- USUS Software Library
                         
   For not-for-profit use by USUS members only.
  May be used and distributed only according to 
      stated policy and the author's wishes.



This volume was assembled by George Schreyer from material collected by
the Library committee.

__________________________________________________________________________

Some notes from the editor:

                                     COPVOL

     This is a general disk copier with verification.  It will also copy the 
boot block of Z-80/8080 type systems.  You may have to modify the external
procedure.

                                    COPFILE

     A general file copier.

                                    COMPFILE
                                        
     A binary file comparison program.  It will compare any type of file but
does not provide as nice a difference report as SRCCOM will for textfiles.

                                      GAME

     A game with demons and a maze with some added features.  Refer to
BONDYSTUFF.TEXT for more detailed info.  You will need a keypress function to 
make it work.

                                    SCANNER

     This program will very quickly look through a disk for a target string.
It had some problems as Jon submitted it, but I fixed them (you may note my
kludging here and there).  This program is REALLY useful if you have deleted
a file and you want to know in which <unused> areas it may still exist.

                                   HOME_LOAN

     This is a simple loan calculator.  It could use some work on the display 
format, but it appears to work.

                                     BANNER

     This little ditty was supposed to be on Volume 8 ( it is in the catalog
file, but the file is not on the copy that I have).  It prints a banner in BIG 
letters ( up to about 10" high ) or multiple lines of smaller letters.  The 
character font is passable but could use improvement.  I have modified it here 
and there, changing the overstrike characters and adding the font data for 
digits.

                                     STOCK
                                        
     Stock is a stock market game, simple but interesting.

                              SRCCOM and FASTREAD

     SRCCOM is a textfile comparison similar in function to the comparison 
routine on Volume 4.  Fastread is a unit which allow MUCH faster reading of 
textfiles than the standard READ procedure.

                                   REFERENCE

     REFERENCE is a simple procedural cross-referencer.  It tells you the
scope of procedures and functions and reports which routine call which
routine.
 
                              8080CONV and REFORM

     This utility converts 8080 assembly language source into Z-80 source.
It assumes that the 8080 source conforms to a certain set of conventions, 
which can be arranged by processing the 8080 source with REFORM.  

                                    LISTINFO

     This program generates a report of the data in *SYSTEM.MISCINFO.  It
was written for version I.5 but I tested it under II.0 and it works.  It 
probably won't work right for IV.0.

                              CALENDAR and DAYOFWK

     These programs do date conversions for the Gregorian calendar.  CALENDAR
requires an H-19 as some simple graphics work is done.

                                SORTS1 .. SORTS4

     These demo programs are four different types of sorts.  They include 
internal timers to time themselves, so if you don't have TIME supported on 
your machine, you will have to use a stopwatch.  TIME is also used to 
initialize a random number generator which is used to generate a random list 
on integers to sort, so you may have to include a routine to prompt for a seed 
also.

                                    HEXDUMP

     This is a simple program which dumps blocks in hex.  I think that PATCH 
is much more useful in this regard, but this program works.

                                     ROMAN

     This is a simple program which converts decimal numbers to Roman
numerals.




========================================================================================
DOCUMENT :usus Folder:VOL15:a.___.remu.text
========================================================================================

{ USUS Remote Communication Unit for Apple /// & Hayes SmartModem - 820510 }
{ Note: this version is an EXPERIMENTAL version... Arley Dealey            }

{$setc debug    := false }
{$setc test     := false }

unit RemUnit ;

{ This is a separate compilation unit intended to stand between application
  code and a communication line.  Implementation of this unit follows the
  specifications set out in the USUS (UCSD p-System Users Society) Remote
  Unit Standard of August, 1981.
  
  
*******************************************************************************
*** NOTE: This Apple /// implementation is less well tested than the author ***
***  would like, but it is being submitted to the library in its current    ***
***  state in the interest of expediency.                             - acd ***
*******************************************************************************

  
  This implementation is designed to interface to the following models:
     computer                   serial port                     modem
     --------                   -----------                     -----
     Apple ///                  internal                        Hayes Smartmodem
     

  The following routines are not functional:
    CR_DialTone
    CR_SetAddress
    CR_SetDTR
    CR_SetRTS
    
  The following routines contain calls to UnitClear:
    CR_Answer
    CR_CommInit
    
  The following routines are implemented but untested:
    CR_Answer
    CR_Ringing
    CR_ClearToSend
    

The authors may be contacted as follows:
  
                Robert W. Peterson              Arley C. Dealey
                ------------------              ---------------
US Mail         P.O. Box 1686                   Volition Systems
                Plano, TX 75074                 1000 Texas National Bank Bldg.
                                                Dallas, TX 75225
                                                (214) 692-6518

GTE Telemail    *BVL1707                        *NPN6141

Compuserve      70235,326                       70130,177
                      ( usually via EMAIL or the MUSUS SIG )

Source                                          TCA928 {checked infrequently}


        Change Log
        ====== ===
  Date     What change was made & who made the change
---------  ---------------------------------------------------------------------
04 Jul 82  Changed RS232_StList declaration so correct allocation is made. [acd]
10 May 82  Cleaned up.  UnitControl does return status in ioresult.        [acd]
26 Dec 81  SOS request vars changed to constants where possible - Arley Dealey
21 Dec 81  Implemented CR_ClearToSend - Arley Dealey
20 Dec 81  Implemented CR_Break - Arley Dealey
09 Dec 81  Convert from 990 ver. IV.0 to Apple /// ver. II.x - Arley Dealey
19 Nov 81  Add compile conditional for debugging and segments - Bob Peterson
26 Oct 81  Convert from Polymorphic to 990
25 Aug 81  Bring up to adopted standard - Bob Peterson
03 Aug 81  Convert to IV.0 - Bob Peterson
28 Mar 81  Original code - Bob Peterson


==============================================================================}

{$P}
interface
{============== Copyright Notice =============================================}
{$C Copyright 1980, 1981 by Robert W. Peterson.  All rights reserved.         }
{============== Copyright Notice =============================================}

const
  CR_Version    = '82 Jul 04 [1.1a]' ;                  {*** NON-STANDARD ***}
  CR_Host       = 'Apple ///' ;                         {*** NON-STANDARD ***}
  CR_Modem      = 'Smartmodem' ;                        {*** NON-STANDARD ***}
  
type
  CR_Baud_Result        = ( CR_Bad_Parameter,
                            CR_Bad_Rate,
                            CR_Set_OK,
                            CR_Select_Not_Supported ) ;
  CR_DialResult         = ( CR_Off_Hook,
                            CR_DialError,
                            CR_NoAutoDial ) ;
  CR_Rem_Port           = packed record
                            Part1       : integer ;
                            Part2       : integer ;
                           end { CR_Rem_Port } ;
  CR_State              = ( CR_On,
                            CR_Off,
                            CR_Auto ) ;
  CR_WhoAmI             = ( CR_Orig,
                            CR_Ans ) ;
                            
var
  CR_AttenChar          : char ;
  CR_Current_Port       : CR_Rem_Port ;
  {$ifc debug}
    Remote                : interactive ;                 {*** NON-STANDARD ***}
    DebugLog              : interactive ;                 {*** NON-STANDARD ***}
  {$endc}
  
{       Initialization and termination routines.        }
procedure CR_CommInit (     Dir                 : CR_WhoAmI ;
                            Attention_Char      : char ;
                        var Remote_Exists       : boolean ;
                        var Dialer_Exists       : boolean ) ;
                        
procedure CR_CommQuit ;


{       Input status.                                   }
function  CR_KbStat                             : boolean ;
function  CR_RemStat                            : boolean ;


{       Input/Output operations.                        }
function  CR_GetKb                              : char ;
function  CR_GetRem                             : char ;
procedure CR_PutRem   (     C                   : char ) ;


{       Control procedures.                             }
procedure CR_Answer ;
procedure CR_Break ;
function  CR_Carrier                            : boolean ;
function  CR_ClearToSend                        : boolean ;
procedure CR_Delay    (     Tenths              : integer ) ;
procedure CR_Dial     (     Number              : string ;
                            WaitChar            : char ;
                        var Result              : CR_DialResult ) ;
function  CR_DialTone                           : boolean ;
procedure CR_Hook     (     OnHook              : boolean ) ;
function  CR_Ringing                            : boolean ;
procedure CR_SetAddress(    HighAddr            : integer ;
                            LowAddr             : integer ;
                            Vector              : integer ) ;
procedure CR_SetCommunications 
                      (     Parity              : boolean ;
                            Even                : boolean ;
                            Rate                : integer ;
                            CharBits            : integer ;
                            StopBits            : integer ;
                            Dir                 : CR_WhoAmI ;
                            Model               : string ;
                        var Result              : CR_Baud_Result ) ;
procedure CR_Set_DTR  (     New_State           : CR_State ) ;
procedure CR_Set_RTS  (     New_State           : CR_State ) ;


implementation
{$P} { Page here so the option is not in the interface text }
const
  Answer_After          =   '3' ;       { Answer after this many rings.       }
  CR                    =    13 ;       { Carriage Return                     }
  Esc                   =    27 ;
  Default_Rate          =   300 ;
  Default_Mode          =  true ;       { Default to parity enabled           }
  Default_Parity        =  true ;       { Default to even parity              }
  Default_CharBits      =     7 ;       { Default to seven data bits          }
  Default_StopBits      =     1 ;       { Default to one stop bit             }
  Default_Kind          = 'Apple ///' ;
  Hung_Up               =  true ;
  Crt_Unit              =     1 ;
  Kb_Unit               =     2 ;
  RemIn_Unit            =     7 ;
  RemOut_Unit           =     8 ;
  Timer                 =   600 ;
  UnknownRate           =    -1 ;
  
{ SmartModem return codes: }
  SM_OK                 = '0' ;
  SM_Connect            = '1' ;
  SM_Ring               = '2' ;
  SM_No_Carrier         = '3' ;
  SM_Error              = '4' ;
                                    {                                   Default
                                      S6 =wait for dial tone in seconds     2
                                      S7 =wait for carrier in seconds      30
                                      S8 =pause time for comma in seconds   2
                                      S9 =carrier detector response time
                                          in tenths of a second             6
                                      S10=delay between loss of carrier
                                          and hangup, in seconds            7
                                      S11=TouchTone duration and spacing
                                          in milliseconds                  70
                                      S12=escape code guard time in
                                          50ths of a second                50
                                    }
  SM_Defaults           = 'EV S10=4 S12=10' ;
  SM_Dial_Prologue      = 'DT' ;  { D=dial command; T=use tone dialing }
  SM_Long_Wait          = 32000 ;
  SM_Short_Wait         =   500 ;
  
  
type
  IO_Direction  = ( IO_Out, IO_In ) ;
  ReqType       = ( StatReq, CntlReq ) ;
  Byte          = 0..255 ;
  Bits2         = 0..3 ;
  Bits3         = 0..7 ;
  Bits4         = 0..15 ;
  Bits5         = 0..31 ;
  Bits6         = 0..63 ;
  Bits7         = 0..127 ;
  
  SOS_ReqCode   = packed record
    Channel     : IO_Direction ;
    StatOrCntl  : ReqType ;
    RequestNum  : Byte ;
    Reserved    : Bits6 ;
    end ;
    
    
  { NOTE: We had to kludge up a declaration for the status word.        }    
  { Logically it should look like this:                                 }
  
  {$ifc false }
  RS232_Status  = packed record
    Current   : packed record
      ParityErr   : boolean ;
      FramingErr  : boolean ;
      OverRun     : boolean ;
      RecRegFull  : boolean ;
      XmitRegEmpty: boolean ;
      DCD_False   : boolean ;
      DSR_False   : boolean ;
      IRQ_Pending : boolean ;
      end ;
    Latched   : packed record
      ParityErr   : boolean ;
      FramingErr  : boolean ;
      OverRun     : boolean ;
      RecRegFull  : boolean ;
      XmitRegEmpty: boolean ;
      DCD_False   : boolean ;
      DSR_False   : boolean ;
      IRQ_Pending : boolean ;
      end ;
    end ;
  {$endc }
  
  { but the compiler allocates two words for that, so we use the clumsy }
  { declaration which follows.                                          }
  
  RS232_Status  = packed record
    { Status at last interrupt }
      ParityErr   : boolean ;
      FramingErr  : boolean ;
      OverRun     : boolean ;
      RecRegFull  : boolean ;
      XmitRegEmpty: boolean ;
      DCD_False   : boolean ;
      DSR_False   : boolean ;
      IRQ_Pending : boolean ;
    { Latched status }       
      L_ParityErr   : boolean ;
      L_FramingErr  : boolean ;
      L_OverRun     : boolean ;
      L_RecRegFull  : boolean ;
      L_XmitRegEmpty: boolean ;
      L_DCD_False   : boolean ;
      L_DSR_False   : boolean ;
      L_IRQ_Pending : boolean ;
    end ;
  
  RS232_StList  = packed record
    BufferSize  :   Byte ;
    BaudRate    : Byte ;
    DataFormat  : Byte ;
    CR_Delay    : Byte ;
    LF_Delay    : Byte ;
    FF_Delay    : Byte ;
    Protocol    : Byte ;
    CtlChar1    : Byte ;
    CtlChar2    : Byte ;
    MaxBufLevel : Byte ;
    MinBufLevel : Byte ;
    BlockLength : Byte ;
    HdwrHandShake : Byte ;
    filler    :   Bits7 ;
    ImRead    :   BOOLEAN ;
    Status      : RS232_Status 
    end ;
  
  RS232_BufList = record
    OutBufSize  :   integer ;     { Size of output buffer         }
    CharsOut    :   integer ;     { Number of chars buffered out  }
    InBufSize   :   integer ;     { Size of input buffer          }
    CharsIn     :   integer ;     { Number of chars buffered in   }
    end ;
  
  
var
  Baud_Settable         : boolean ;
  Control               : integer ;
  CurrentBaud           : integer ;
  DTR_State             : CR_State ;
  RTS_State             : CR_State ;
  Off_Hook              : boolean ;
  Unit_Carrier          : boolean ;
  Model_ID              : string ;
  StatusList            : RS232_StList ;
  {$ifc debug}
  xxx                   : integer ;                     {*** NON-STANDARD ***}
  {$endc}
  

function  SM_Execute_Command    (     Cmd       : string ;
                                      Wait_Count: integer )     : char ;
  forward ;
function  Check_SmartModem_There                        : boolean ;
  forward ;
function  SM_Attention                                  : boolean ;
  forward ;
procedure RS232Control          (     Request    : ReqType ;
                                  VAR StatusList : RS232_StList ) ;
  forward ;


{$P}
{  -----------------------------------------------------------  }
{               Initialization/Termination Procedures           }
{  -----------------------------------------------------------  }

procedure CR_SetAddress {     HighAddr  : integer ;
                              LowAddr   : integer ;
                              Vector    : integer } ;
  begin { CR_SetAddress }
    with CR_Current_Port do
      begin
      Part1 := HighAddr ;
      Part2 := LowAddr ;
      end ;
  end ; { CR_SetAddress }



procedure CR_SetCommunications {     Parity     : boolean ;
                                     Even       : boolean ;
                                     Rate       : integer ;
                                     CharBits   : integer ;
                                     StopBits   : integer ;
                                     Dir        : CR_WhoAmI ;
                                     Model      : string ;
                                 var Result     : CR_Baud_Result } ;

  var
    ReqCode             : SOS_ReqCode ;
    StatusList          : RS232_StList ;
    ReqRate             : integer ;
    
  begin { CR_SetCommunications }
    Model_ID            := 'Apple ///' ;
    Control             := 12 ;
    Baud_Settable       := true  ;
    
    { Use a nested if-then-else structure here instead of a case statement
      because of the wide range of selector values involved.          - acd }
    if Rate = 50 
      then ReqRate :=  1
    else if Rate = 75 
      then ReqRate :=  2
    else if Rate = 110
      then ReqRate :=  3
    else if Rate = 135
      then ReqRate :=  4
    else if Rate = 150
      then ReqRate :=  5
    else if Rate = 300
      then ReqRate :=  6
    else if Rate = 600
      then ReqRate :=  7
    else if Rate = 1200
      then ReqRate :=  8 
    else if Rate = 1800
      then ReqRate :=  9 
    else if Rate = 2400
      then ReqRate := 10
    else if Rate = 3600
      then ReqRate := 11
    else if Rate = 4800
      then ReqRate := 12
    else if Rate = 7200
      then ReqRate := 13
    else if Rate = 9600
      then ReqRate := 14
    else if Rate = 19200
      then ReqRate := 15
    else ReqRate := UnknownRate ;
    
    if ReqRate = UnknownRate then
      Result := CR_BadRate
    else if Rate = CurrentBaud then 
      Result := CR_SetOK 
    else begin
      RS232Control( StatReq, StatusList ) ;
      if ioresult = 0 then begin
        StatusList.BaudRate := ReqRate ;
        RS232Control( CntlReq, StatusList ) ;
        end ; { ioresult = 0 }
      if ioresult = 0 then begin
        CurrentBaud := Rate ;
        Result      := CR_SetOK
        end
      else begin
        Result := CR_BadRate ;
        end ;
      end { rate <> currentbaud }
          
  end ; { CR_SetCommunications }



procedure CR_CommInit   {     Dir               : CR_WhoAmI ;
                              Attention_Char    : Char ;
                          var Remote_Exists     : boolean ;
                          var Dialer_Exists     : boolean } ;

  var
    C           : char ;
    Result      : CR_Baud_Result ;
    
  
  procedure Not_There   (     Which             : integer ) ;
    begin { Not_There }
      GoToXY( 0, 10 ) ;
      writeln( ' ':20, 'Required unit #', Which, ' failed UnitClear!' ) ;
      Remote_Exists := false ;
    end ; { Not_There }
    
    
  begin { CR_CommInit }
    
    { Save RS232 control parameters }
    RS232Control( StatReq, StatusList ) ;
    
    { Check that required units exist.          }
    Remote_Exists       := true ;
    
    UnitClear( RemIn_Unit ) ;
    if IOResult <> 0
      then Not_There ( RemIn_Unit ) ;
      
    UnitClear( RemOut_Unit ) ;
    if IOResult <> 0
      then Not_There ( RemOut_Unit ) ;
      
    { The following call to CR_SetCommunications had to be moved here so that }
    { the proper baud was set BEFORE the call to SM_Attention tries to talk   }
    { to the SmartModem.  - acd  3 Jul 82                                     }
    CR_SetCommunications
      ( Default_Mode,
        Default_Parity,
        Default_Rate,
        Default_CharBits,
        Default_StopBits,
        CR_Orig,
        Default_Kind,
        Result ) ;
    if Result = CR_SelectNotSupported
      then BaudSettable := false
      else BaudSettable := true ;
    
    if not SM_Attention
      then
        if not SM_Attention
          then CR_Hook( Hung_Up ) ;
    
    Dialer_exists       := Check_SmartModem_There ;
    
    Model_ID            := '' ;
    DTR_State           := CR_Auto ;
    RTS_State           := CR_Auto ;
    CR_Hook( Hung_Up ) ;
    CR_AttenChar        := Attention_Char ;
    
  end ; { CR_CommInit }



procedure CR_CommQuit ;
  var
    C           : char ;
    Result      : CR_Baud_Result ;
    
  begin { CR_CommQuit }
    
    {$ifc debug}
    xxx := succ(xxx) ;
    writeln( DebugLog, '':xxx, 'entering CR_CommQuit' ) ;
    {$endc}
    
    if Unit_Carrier     { If we think we are communicating,     }
      then
        if not SM_Attention { ...get the SmartModem's attention }
          then
            if not SM_Attention
              then
                { do nothing } ;
    
    if SM_Attention
      then
        CR_Hook( Hung_Up ) ;  { Now hang up the phone.          }
    
    if Baud_Settable          { If we were able to change the baud rate, }
      then
        CR_SetCommunications  { ...reset to the default         }
          ( Default_Mode,
            Default_Parity,
            Default_Rate,
            Default_CharBits,
            Default_StopBits,
            CR_Orig,
            Default_Kind,
            Result ) ;
    
    if SM_Attention
      then
        { 'Z' is software reset of the SmartModem.      }
        C := SM_Execute_Command( 'Z', SM_Short_Wait ) ;
    
    {$ifc debug}
    writeln( DebugLog, '':xxx, 'exiting CR_CommQuit' ) ;
    xxx := pred(xxx) ;
    {$endc}
    
    { Restore RS232 control parameters }
    RS232Control( CntlReq, StatusList ) ;
    
  end ; { CR_CommQuit }



{$P}
{  -------------------------------------------------------------------  }
{               Internal Subroutines                                    }
{  -------------------------------------------------------------------  }

procedure RS232Control      {         Request    : ReqType ;
                                  VAR StatusList : RS232_StList } ;

  var
    ReqCode             : SOS_ReqCode ;
    
  begin { RS232Control }
    with ReqCode do begin
      Channel    := IO_Out ;
      StatOrCntl := Request ;
      RequestNum := 1 ;         { Set/Retrieve control parameters }
      Reserved   := 0 ;
      end ;
    if Request = StatReq then
      StatusList.BufferSize := sizeof( StatusList )-1 ;
    unitstatus( RemOut_Unit, StatusList, ReqCode ) ;
  end ; { RS232Control }


function  SM_Execute_Command    {     Cmd       : string ;
                                      Wait_Count: integer )     : char } ;
  var
    Ch          : char ;
    I           : integer ;

  begin { SM_Execute_Command }
    
    {$ifc debug}
    xxx := succ(xxx) ;
    writeln( DebugLog, '':xxx, 'entering SM_Execute_Command               ' ) ;
    {$endc}
    
    CR_Delay( 2 ) ;
    while CR_RemStat do         { Flush trash   }
      begin
      Ch := CR_GetRem ;
      end ;
    
    { "AT" is what the SmartModem requires at the start of each command line }
    CR_PutRem( 'A' ) ;
    CR_PutRem( 'T' ) ;
    CR_PutRem( ' ' ) ;
    for I := 1 to length( Cmd ) do      { Output each command character }
      CR_PutRem( Cmd[I] ) ;
    CR_PutRem( chr(13) ) ;              { Terminate command with <CR>   }
    
    I := Wait_Count ;
    repeat
      if CR_KbStat              { This allows a manual exit, using      }
        then                    { <attention char> from the keyboard    }
          begin
          if CR_GetKb = CR_AttenChar
            then I := 0 ;
          end
        else I := pred( I )
    until (I <= 0) or CR_RemStat ;      { Loop until the counter goes   }
                                        { to zero or something comes in }
                                        { on the Remote line.           }
    if CR_RemStat               { If something came from Remote line,   }
      then
        begin
        Ch := CR_GetRem ;       { fetch character from remote           }
        Ch := chr( ord( Ch ) mod 128 ) ; { mask bit7 (shame, shame Hayes) }
        CR_Delay( 2 ) ;
        {$ifc debug}
        writeln( DebugLog, '':xxx, 'CR_GetRem = ', Ch ) ;
        {$endc}
        end
      else
        begin
        Ch := SM_Error ;        { If we timed out, return an error.     }
        CR_Delay( 2 ) ;
        {$ifc debug}
        writeln( DebugLog, '':xxx, 'CR_GetRem FAILED' ) ;
        {$endc}
        end ;
    SM_Execute_Command := Ch ;
    
    while CR_RemStat do
      begin
      Ch := CR_GetRem ;         { Flush trash   }
      end ;
    
    {$ifc debug}
    writeln( DebugLog, '':xxx, 'exiting  SM_Execute_Command             ' ) ;
    xxx := pred(xxx) ;
    {$endc}
    
  end ; { SM_Execute_Command }
  
  
  
function  Check_SmartModem_There { : boolean } ;
{ This function returns TRUE if the SmartModem responds to a simple command.
  It returns FALSE if the SmartModem does not understand the command or if no
  response is generated (such as when the SmartModem is not connected or the
  unit is being used with some other type of modem).  }
  
  var
    B   : boolean ;
    C   : char ;
  
  begin { Check_SmartModem_There }
    
    {$ifc debug}
    xxx := succ(xxx) ;
    writeln( DebugLog, '':xxx, 'entering Check_Smartmodem_There         ' ) ;
    {$endc}
    
    { The command sent has the following effects:
      "E" causes the SmartModem to suppress echoing command characters
      "V" causes the SmartModem to use abbreviated command responses    }
    
    if SM_Execute_Command( SM_Defaults, SM_Short_Wait ) = SM_OK
      then Check_SmartModem_There := true
      else Check_SmartModem_There := false ;
    CR_Delay( 2 ) ;
    
    {$ifc debug}
    writeln( DebugLog, '':xxx, 'exiting  Check_Smartmodem_There       ' ) ;
    xxx := pred(xxx) ;
    {$endc}
    
  end ; { Check_SmartModem_There }
  
  
  
function  SM_Attention { : boolean } ;
{ This function will get the SmartModem's attention, regardless of the
  modems state. }
  
  var
    B   : boolean ;
    
  begin { SM_Attention }
    
    {$ifc debug}
    xxx := succ(xxx) ;
    writeln( DebugLog, '':xxx, 'entering SM_Attention               ' ) ;
    {$endc}
    
    if Check_SmartModem_There
      then 
        SM_Attention := true
      else
        begin
        CR_Delay( 2 ) ;
        CR_Delay( 12 ) ;        { Delay just over 1 second }
        CR_PutRem( '+' ) ;      { "+++" is default attention getter.    }
        CR_PutRem( '+' ) ;
        CR_PutRem( '+' ) ;
        CR_Delay( 12 ) ;        { Delay just over 1 second }
        CR_PutRem( chr( CR ) ) ;
        SM_Attention := Check_SmartModem_There ;
        end ;
    CR_Delay( 2 ) ;
    
    {$ifc debug}
    writeln( DebugLog, '':xxx, 'exiting SM_Attention              ' ) ;
    xxx := pred(xxx) ;
    {$endc}
    
  end ; { SM_Attention }
    
{$P}
{  -------------------------------------------------------------------  }
{               Control Procedures                                      }
{  -------------------------------------------------------------------  }

procedure CR_Answer ;   { *** UNTESTED *** }
  var
    C           : char ;
    Connected   : boolean ;
    Count       : integer ;
    Ring        : boolean ;
    Waiting     : boolean ;
    
  begin { CR_Answer }
    if not SM_Attention
      then { null } ;
    C := SM_Execute_Command( concat('S0=', Answer_After), SM_Short_Wait ) ;
    Waiting := true ;
    while Waiting do
      begin
      Ring      := CR_Ringing ;
      Waiting   := not Ring ;
      if Waiting 
        then
          if CR_KbStat
            then 
              begin
              Waiting := (CR_GetKB <> CR_AttenChar) ;
              end ;
      end ;
    if Ring 
      then
        begin
        UnitClear( RemIn_Unit ) ;
        UnitClear( RemOut_Unit ) ;
        Waiting         := true ;
        Connected       := false ;
        Count           := 32000 ;
        repeat
          Count := succ( Count ) ;
          if CR_KbStat
            then 
              Waiting := not (CR_GetKb = CR_AttenChar)
            else
              if CR_RemStat
                then
                  begin
                  Waiting   := not (CR_GetRem = SM_Connect) ;
                  Connected := not Waiting ;
                  end
                 else Waiting := (Count > 0) ;
        until not Waiting ;
        if not Connected
          then CR_Hook( Hung_Up ) ;
        end ;
  end ; { CR_Answer }



procedure CR_Break ;
  const
    ReqCode     =  14 ;
    { 0000000000001110 = $0E = 14
      \____/\______/^^
        |      |    |+-> I/O channel : 0 = Output           
        |      |    +--> Request Type: 1 = Control
        |      +-------> Request code: 3 = Transmit break signal
        +--------------> Reserved    : (must be zero)                   }
  
  var
    BreakLength : PACKED ARRAY[ 0..0 ] OF Byte ;
    
  begin { CR_Break }
    BreakLength[0]  := 1 ;
    UnitStatus( RemOut_Unit, BreakLength, ReqCode ) ;
  end ; { CR_Break }



function  CR_Carrier { : boolean } ;
  
  const
    ReqCode     =   5 ;
    { 0000000000000101 = $05 = 5 
      \____/\______/^^
        |      |    |+-> I/O channel : 1 = Input
        |      |    +--> Request Type: 0 = Status
        |      +-------> Request code: 1 = Retrieve control parameters
        +--------------> Reserved    : (must be zero)                   }
  
  var
    StatusList  : RS232_StList ;
    
  begin { CR_Carrier }
    
    {$ifc false }
    
      StatusList.BufferSize := sizeof( RS232_StList )-1 ;
      UnitStatus( RemIn_Unit, StatusList, ReqCode ) ;
      CR_Carrier  := not StatusList.Status.DCD_False ;
      Off_Hook    := not StatusList.Status.DCD_False ;
    
    {$elsec     }
    
      { Simulate carrier detect by following the hook status }
      CR_Carrier := UnitCarrier ;
      Off_Hook   := UnitCarrier ;
  
    {$endc      }
    
  end ; { CR_Carrier } 



function  CR_ClearToSend { : boolean } ;        { *** UNTESTED *** }
  
  const
    ReqCode     =  12 ;
    { 0000000000001100 = $0C = 12
      \____/\______/^^
        |      |    |+-> I/O channel : 0 = Output
        |      |    +--> Request Type: 0 = Status
        |      +-------> Request code: 3 = Retrieve driver buffer info
        +--------------> Reserved    : (must be zero)                   }
  
  var
    ControlBlock  : RS232_BufList ;
  
  begin { CR_ClearToSend }
    unitstatus( RemIn_Unit, ControlBlock, ReqCode ) ;
    with ControlBlock do
      if (CharsOut < OutBufSize)
        then CR_ClearToSend := true 
        else CR_ClearToSend := false ;
  end ; { CR_ClearToSend }
  
  
  

procedure CR_Delay { Tenths : integer } ;
{ Purpose: Delay 0.1 seconds for each tenth requested }
{ This implementation uses the non-obvious technique of issuing a SOS
  Console 'synchronize' request.  This requests a delay until the next
  vertical retrace cycle of the video generator.  Since these occur
  sixty times per second the iterated call will produce the requested
  delay +/- slightly less than 1/60 second.                     - acd  }
  
  const
    SC_Synchronize      =    22 ;       { Apple /// screen control function # }
    
  var
    Count       : integer ;
    Index       : integer ;
    FnCode      : integer ;
  
  begin { CR_Delay }
    FnCode := SC_Synchronize ;
    for Index := 1 to Tenths do
      for Count := 1 to 6 do
        UnitWrite( Crt_Unit, FnCode, 2,, 12 ) ;
  end ; { CR_Delay }



procedure CR_Dial {     Number    : string ;
                        WaitChar  : char ;
                    var Result    : CR_Dial_Result } ;
{ This routine will cause the SmartModem to dial the number passed }

  var
    I           : integer ;
    Cmd         : string ;
    Valid_Set   : set of char ;
    
  begin { CR_Dial }
    { Initialize valid character set }
    Valid_Set := [ 'p','P','t','T','*','#',';',WaitChar,'0'..'9' ] ;
    
    Result := CR_DialError ;  { Assume an error }
    
    { Get SmartModem's attention }
    if not SM_Attention
      then exit( CR_Dial ) ;
      
    CR_Hook( Hung_Up ) ;  { Be sure we know where we are }
    
    { Start the dial command with the dial prologue.  (See the implementation
      constant list) }
    Cmd := SM_Dial_Prologue ;
    for I := 1 to length( Number ) do
      if Number[I] in Valid_Set   { Include only valid characters }
        then                      {  in the passed number         }
          Cmd := concat( Cmd, copy( Number, I, 1 ) ) ;
    { Execute the dial command and be patient about the response  }
    if SM_Execute_Command( Cmd, SM_Long_Wait ) = SM_Connect
      then
        begin                           { We got an answer & carrier }
        Result      := CR_Off_Hook ;
        Unit_Carrier:= true ;
        end                             { No carrier.  We may have   }
      else Unit_Carrier := false ;      { answer.  We'll never know. }
  end ; { CR_Dial }



function  CR_DialTone ;
  begin { CR_DialTone }
    CR_DialTone := true ;
  end ; { CR_DialTone }



procedure CR_Hook { On_Hook  : boolean } ;
  begin { CR_Hook }
    if On_Hook                    { If we want to go on hook...   }
      then
        begin
        if not SM_Attention       { ...get the modem's attention  }
          then
            if not SM_Attention
              then { null } ;
        { Send the "hang up" command }
        Off_Hook := not (SM_Execute_Command( 'H0', SM_Short_Wait) = SM_OK) ;
        end
      else Off_Hook := true ;
    Unit_Carrier := Off_Hook ;    { The simulated carrier follows the     }
                                  { status of the receiver.               }
  end ; { CR_Hook }



function  CR_Ringing { : boolean } ;  { *** UNTESTED *** }
  begin { CR_Ringing }
    if CR_RemStat
      then CR_Ringing := (SM_Ring = CR_GetRem)
      else CR_Ringing := false ;
  end ; { CR_Ringing }


procedure CR_SetDTR ;
  begin { CR_SetDTR }
  { This should be 'do-able' with SOS calls (I think).  - acd }
  end ; { CR_SetDTR }
  
  
procedure CR_SetRTS ;
  begin { CR_SetRTS }
  { This should be 'do-able' with SOS calls (I think).  - acd }
  end ; { CR_SetRTS }
  
  
{$P}
{  -------------------------------------------------------------------  }
{               Status Procedures                                       }
{  -------------------------------------------------------------------  }

function  CR_KbStat { : boolean } ;
  
  const
    ReqCode     =  21 ;
    { 0000000000010101 = $15 = 21
      \____/\______/^^
        |      |    |+-> I/O channel : 1 = Input
        |      |    +--> Request Type: 0 = Status
        |      +-------> Request code: 5 = Buffered keystroke count   
        +--------------> Reserved    : (must be zero)                   }
  
  var
    ReqList     : packed record
      Enqueued  : byte ;
      Unused    : byte ;
      end ;
  
  begin { CR_KbStat }
    UnitStatus( Kb_Unit, ReqList, ReqCode ) ;
    if ReqList.Enqueued > 0
      then CR_KbStat := true 
      else CR_KbStat := false ;
  end ; { CR_KbStat }



function  CR_RemStat { : boolean } ;
  
  const
    ReqCode     =  13 ;
    { 0000000000001101 = $0D = 13
      \____/\______/^^
        |      |    |+-> I/O channel : 1 = Input
        |      |    +--> Request Type: 0 = Status
        |      +-------> Request code: 3 = Retrieve driver buffer info
        +--------------> Reserved    : (must be zero)                   }
  
  var
    RemBufStat  : RS232_BufList ;
            
  begin { CR_RemStat }
    UnitStatus( RemIn_Unit, RemBufStat, ReqCode ) ;
    if RemBufStat.CharsIn > 0
      then CR_RemStat := true 
      else CR_RemStat := false ;
  end ; { CR_RemStat }
  

{$P}
{  -------------------------------------------------------------------  }
{               Input/Output Procedures                                 }
{  -------------------------------------------------------------------  }

function  CR_GetKb { : char } ;
  var
    Ch          : packed array [0..0] of char ;
    
  begin { CR_GetKb }
    UnitRead( KB_Unit, Ch[0], 1, 0, Control ) ;
    CR_GetKb := Ch[0] ;
  end ; { CR_GetKb }



function  CR_GetRem { : char } ;
  var
    Ch          : packed array [0..0] of char ;
    
  begin { CR_GetRem }
    UnitRead( RemIn_Unit, Ch[0], 1, 0, Control ) ;
    
    {$ifc debug}
    { if ch in [' '..'~'] then write( DebugLog, ch ) ; }
    {$endc}
    
    CR_GetRem := Ch[0] ;
  end ; { CR_GetRem }



procedure CR_PutRem { C : char } ;
  begin { CR_PutRem }
    
    {$ifc debug}
    write( DebugLog, c ) ;
    {$endc}
    
    UnitWrite( RemOut_Unit, C, 1, 0, Control ) ;
  end ; { CR_PutRem }


{$P}
begin { SmartUnit initialization }
  
  CR_AttenChar          := chr(Esc) ;
  CR_Current_Port.Part1 :=        0 ;
  CR_Current_Port.Part2 :=        0 ;
  
  BaudSettable          :=    false ;
  Control               :=       12 ;
  CurrentBaud           :=        0 ;   { force initialization of baud }
  DTR_State             :=  CR_Auto ;
  RTS_State             :=  CR_Auto ;
  Off_Hook              :=    false ;
  Unit_Carrier          := Off_Hook ;
  Model_ID              := Default_Kind ;
  
  unitclear( KB_Unit     ) ;
  unitclear( RemIn_Unit  ) ;
  unitclear( RemOut_Unit ) ;
  
  {$ifc debug}
    xxx := 0 ;
    reset( remote, '.RS232' ) ;
    reset( DebugLog, 'console:' ) ;
  {$endc}
  
end   { SmartUnit initialization }.


========================================================================================
DOCUMENT :usus Folder:VOL15:clr_break.text
========================================================================================

.PROC   CLR_BREAK
; To clear break bit in CR_BREAK
; This external procedures is for use with the
; procedure CR_BREAK in REMUNIT for LSI-11s
; M. A. Ikezawa, 17 July 1981
XCSR    .EQU    177524
        BIC     #1,@#XCSR
        MOV     (SP)+,R0
        JMP     @R0
        .END


========================================================================================
DOCUMENT :usus Folder:VOL15:comm.text
========================================================================================

program comm;
  
  { communicate with remote computer and upload/download text }
  { written by Jon Bondy. }
  
  const
    mdata = 129; { modem data port (both in and out) }
    mstat = 128; { modem status port }
    mcmd = 130; { modem command reg }
    mbaud = 128; { modem baud rate reg }
    mirpt = 131; { interrupt mask reg }
    mreset = 1; { reset device }
    m300b = 132; { 300 baud, 1 stop bits }
    mimask = 0; { enable no TUART interrupts }
    mmask = 64; { modem data available mask }
    cdata = 1; { console data port }
    kstat = 0; { console status port }
    kdata = 1; { keyboard data port }
    kmask = 2; { keyboard data available mask }
    esc = 27;
    command_ch = 1; { ^A prefixes commands (receive, send, quit) }
    lf = 10;
    cr = 13;
    cntl_s = 19;
    cntl_q = 17;
    bufmax = 30000;
    
  type
    byte = 0..255;
    
  var
    receiving : boolean;
    rcv_buff : packed array[0..bufmax] of byte;
    rcv_idx, i : 0..bufmax;
    next_block : integer; { next block to be written for out_file }
    data : byte;
    in_file : text;
    out_file : file;
  
  function pand(ch : byte; mask : integer) : integer; external; { procedure }
  function portread(addr : integer) : byte; external; { procedure }
  procedure portwrite(addr : integer; data : byte); external;
  function eparity(data : byte) : byte; external; { even parity in msb } { procedure }
  
  procedure initialize;
    begin
    writeln('Tele-communications program.  Written by Jon Bondy 3/82.');
    writeln('Enter <control-A> to invoke commands.');
    portwrite(mcmd,mreset); { reset TUART }
    portwrite(mbaud,m300b); { set to 300 baud }
    portwrite(mirpt,mimask); { disable all TUART interrupts }
    receiving := false;
    rcv_idx := 0;
    end; { initialize }
        
  function open_o_file : boolean; { procedure }
    var
       fname : string;
       ok : boolean;
       ch : char;
    begin
    repeat
      write('Enter Pascal file name for received data (".text" assummed) : ');
      readln(fname);
      if (length(fname) = 0) then begin 
         open_o_file := false; exit(open_o_file); end;
      fname := concat(fname,'.text');
      close(out_file);
      {$I-} 
      reset(out_file,fname); { test if file exists }
      {$I+}
      ok := true;
      if (ioresult = 0) then begin
          write('Do you want to write over that file? ');
          read(ch); writeln; ok := false;
          if (ch = 'y') or (ch = 'Y') then ok := true;
          end;
      close(out_file);
      {$I-}
      if ok then rewrite(out_file,fname);
      {$I+}
      until (ioresult = 0) and ok;
    open_o_file := true;
    end; { open_o_file }
  
  function write_header : boolean; { procedure }
      var
         date_file : file; 
         nblock : integer;
         date1, date2 : byte;
      begin
      { read in current date from system disk }
      {$I-} reset(date_file,'*');
      nblock := blockread(date_file,rcv_buff[0],1,2); {$I+}
      if (nblock <> 1) or (ioresult <> 0) then begin
         writeln('Error during receive file initialization.');
         close(date_file); write_header := false; exit(write_header); 
         end;
      close(date_file);
      date1 := rcv_buff[20]; date2 := rcv_buff[21];
      { create text file header }
      fillchar(rcv_buff[0],1024,chr(0));
      rcv_buff[0]   := 1;
      rcv_buff[114] := 1;        { autoindent := true }
      rcv_buff[122] := 79;       { right margin := 79 }
      rcv_buff[124] := 5;        { paragraph margin := 5 }
      rcv_buff[126] := ord('^'); { command character := '^' }
      rcv_buff[128] := date1;
      rcv_buff[129] := date2;
      rcv_buff[130] := date1;
      rcv_buff[131] := date2;
      {$I-} nblock := blockwrite(out_file,rcv_buff[0],2,0); {$I+}
      if (nblock <> 2) or (ioresult <> 0) then begin
         writeln('Error during receive file initialization.');
         close(out_file); write_header := false;
         end
      else write_header := true;
      end; { write_header }
      
   procedure start_receive;
      begin 
      if not open_o_file then exit(start_receive);
      if not write_header then exit(start_receive);
      receiving := true;
      rcv_idx := 0; { just in case not cleaned up previously }
      next_block := 2; 
      writeln('<Reception initiated>');
      end; { start_receive }
    
   procedure close_out_file;
      var
         nc, nblock : integer;
         data_length, len : integer;
         from_index, to_index : integer;
         done : boolean;
      begin
      if (rcv_idx > bufmax) then nc := bufmax else nc := rcv_idx-1;
      { move characters to "right" of array }
      data_length := sizeof(rcv_buff) - 1;
      from_index := data_length - nc;
      moveright(rcv_buff[0],rcv_buff[from_index],nc+1);
      done := false; to_index := 0;
      { move 1024-byte blocks of chars to left, making sure lines are not
        split across block boundaries. }
      repeat
         if (from_index + 1023 < data_length - 1) then
            len := scan(-1024,=chr(cr),rcv_buff[from_index+1023]) + 1024
         else begin
            len := data_length - from_index + 1; done := true; end;
         moveleft(rcv_buff[from_index],rcv_buff[to_index],len);
         from_index := from_index + len;
         fillchar(rcv_buff[to_index + len], 1024 - len, chr(0));
         to_index := to_index + 1024;
         if (to_index > from_index) then begin
            writeln; writeln('Index overwrite error.'); end;
         until done;
      len := to_index div 512;
      nblock := blockwrite(out_file,rcv_buff[0],len,next_block);
      if (nblock <> len) or (ioresult <> 0) then begin 
         writeln('Error during file write.'); end;
      close(out_file, lock); receiving := false; rcv_idx := 0;
      writeln('<terminal mode>');   
      end; { close_out_file }
   
   procedure write_interim_buffer;
      var
         nc, nblock : integer;
         data_length, len : integer;
         from_index, to_index : integer;
         done : boolean;
      begin
      if (rcv_idx > bufmax) then nc := bufmax else nc := rcv_idx-1;
      { move characters to "right" of array }
      data_length := sizeof(rcv_buff) - 1;
      from_index := data_length - nc;
      moveright(rcv_buff[0],rcv_buff[from_index],nc+1);
      done := false; to_index := 0;
      { move 1024-byte blocks of chars to left, making sure lines are not
        split across block boundaries. }
      repeat
         if (from_index + 1023 < data_length - 1) then begin
            len := scan(-1024,=chr(cr),rcv_buff[from_index+1023]) + 1024;
            moveleft(rcv_buff[from_index],rcv_buff[to_index],len);
            from_index := from_index + len;
            fillchar(rcv_buff[to_index + len], 1024 - len, chr(0));
            to_index := to_index + 1024;
            if (to_index > from_index) then begin
               writeln; writeln('Index overwrite error.'); end;
            end
         else done := true; { do not move last partial block }
         until done;
      { write data to disk }
      len := to_index div 512;
      {$I-} nblock := blockwrite(out_file,rcv_buff[0],len,next_block); {$I+}
      if (nblock <> len) or (ioresult <> 0) then begin 
         writeln('Error during file write: receive aborted.'); 
         close(out_file, lock); rcv_idx := 0; receiving := false; 
         writeln('<terminal mode>'); exit(write_interim_buffer);
         end;
      next_block := next_block + len;
      { start off with partial block in buffer after interim write }
      len := data_length - from_index + 1; 
      moveleft(rcv_buff[from_index],rcv_buff[0],len);
      rcv_idx := len;
      end; { write_interim_buffer }
      
   procedure put_out_file;
     { buffer full, so put it on disk }
     var
        counter : integer;
        ch : char;
     begin 
     { ask host computer to stop transmitting }
     portwrite(mdata,eparity(cntl_s));
     { continue to receive chars while awaiting host pause }
     counter := 500;  { counter will = 0 when host has stopped: timeout }
     while (counter > 0) do begin 
        if (pand(portread(mstat),mmask) <> 0) then begin { modem receive char? }
           ch := chr(pand(portread(mdata),127)); { remove parity bit }
           portwrite(cdata,ord(ch)); { echo to crt }
           if (ch <> chr(lf)) then begin
              rcv_buff[rcv_idx] := ord(ch); rcv_idx := rcv_idx + 1; end;
           counter := 500; { try to time out again }
           end; { if }
        counter := counter - 1;
        end; { while }
     write_interim_buffer;
     portwrite(mdata,eparity(cntl_q)); { host may resume xmission }
     end; { put_out_file }
    
  function open_i_file : boolean; { procedure }
     var
        fname : string;
     begin
     repeat
        write('Enter Pascal file name for send data (".text" assummed) : ');
        readln(fname);
        if (length(fname) = 0) then begin
           open_i_file := false; exit(open_i_file); end;
        fname := concat(fname,'.text');
        close(in_file);
        {$I-} reset(in_file,fname); {$I+}
        until (ioresult = 0);
     open_i_file := true;
     end; { open_i_file }
  
  procedure send_file;
     var
        abort : boolean;
        r_ch, s_ch : char;
     begin 
     if not open_i_file then exit(send_file); abort := false;
     while not eof(infile) and not abort do begin
        if eoln(infile) then begin s_ch := chr(cr); readln(infile); end
        else read(infile,s_ch);
        { write to modem }
        portwrite(mdata,eparity(ord(s_ch))); r_ch := chr(128);
        repeat
           { abort send if <esc> key pressed during send }
           if (pand(portread(kstat),kmask) <> 0) then 
              if (pand(portread(kdata),127) = esc) then abort := true;
           { see if modem received echo character yet }
           if (pand(portread(mstat),mmask) <> 0) then begin
              { read modem, remove parity bit }
              r_ch := chr(pand(portread(mdata),127)); 
              { write char to CRT -- assume CRT is faster than modem }
              portwrite(cdata,ord(r_ch));
              end; { if }
           until (s_ch = r_ch) or abort;
        end; { while }
     close(infile);
     if abort then begin
        writeln; r_ch := chr(pand(portread(kdata),127)); { clear keyboard ch }
        writeln('<Transmission aborted by operator>');
        end
     else writeln('<Transmission complete>');
     end; { send_file }
      
  procedure get_command;
     var
        ch : char;
     begin 
     repeat
        writeln; write('Comm: R(eceive, S(end, C(lose, T(erminal, Q(uit : ');
        repeat until (pand(portread(kstat),kmask) <> 0);
        ch := chr(pand(portread(kdata),127)); 
        until (ch in ['r','R','s','S','c','C','t','T','q','Q']);
     writeln;
     case ch of
       'r','R' : start_receive;
       's','S' : send_file;
       'c','C' : close_out_file;
       't','T' : begin end; { return to terminal mode }
       'q','Q' : begin if (rcv_idx > 0) then close_out_file; exit(comm); end;
       end { case }
     end; { if }
     
  begin
  initialize;
  repeat
     { char ready from modem? }
     if (pand(portread(mstat),mmask) <> 0) then begin
        data := pand(portread(mdata),127); { remove parity bit }
        { transfer to CRT -- assume CRT is faster than modem }
        portwrite(cdata,data); 
        if receiving and (data <> lf) then begin
           rcv_buff[rcv_idx] := data; rcv_idx := rcv_idx + 1; end;
        if (rcv_idx >= (bufmax - 1500)) then put_out_file;
        end; { read character from modem }
     { char ready from keyboard? }
     if (pand(portread(kstat),kmask) <> 0) then begin
        { read from keyboard }
        data := pand(portread(kdata),127); { clear msb }
        if (data = command_ch) then get_command
        else portwrite(mdata,eparity(data)); { assume kbd is slower than modem }
        end;  { read character from keyboard }
     until false;
  end. { comm }
  

========================================================================================
DOCUMENT :usus Folder:VOL15:contents.text
========================================================================================

  This file describes the files contained on this diskette.
The files contain sources for two different separate
compilation units, each of which was written to conform to
the USUS Standard Remote Separate Compilation Unit of August
1981.  One of the units makes no assumptions about the modem
in use.  The other requires the Hayes Microcomputer Products
Smartmodem.
  The description of each group of files follows the
directory listing of the files.


HSM.TROOT.TEXT    16  5-Dec-81    6 Text
HSM.TINC1.TEXT    16  5-Dec-81   22 Text
HSM.TINC2.TEXT    14  5-Dec-81   38 Text
  These files contain TERMINAL, a terminal emulation
program.  This version of TERMINAL will emulate a dumb
terminal as well as use the capabilities of auto-dial if the
Remote Unit claims auto-dial support is available.  The
program is also able to:
--Log received characters into a memory buffer and move the
  buffer to a user-named disk file.
--Send a text file to the remote system.
--Send logon text to the remote system.
--Change log files during a session.
--Purge the log file upon user request.
--Optionally respond to Compuserve's VideoTex CRT control
  codes.
See the source code for additional comments.
  To use the program, first compile a USUS Remote Unit.
Edit HSM.TROOT.TEXT's unit reference to point to the Unit's
code file.  Compile using HSM.TROOT.TEXT as the compiler
input file.  Using LIBRARY, create a code file containing
both the output of the HSM.TROOT.TEXT compile and the Remote
Unit object code.


HSM.UROOT.TEXT    22  5-Dec-81   52 Text
HSM.UINC1.TEXT    16  5-Dec-81   74 Text
HSM.UINC2.TEXT    14 22-Dec-81  158 Text
  These files contain an implemetation of the USUS Remote
Separate Compilation Unit of August 1981 which expects to
use a Hayes Smartmodem.  To use the unit, compile
HSM.UROOT.TEXT after editing in any changes required in the
CR_SETCOMMUNICATIONS routine.  See the comments in
HSM.UROOT.TEXT for additional guidance.

STD.UNIT.TEXT     24 16-Nov-81   90 Text
STD.UNIT.CODE     11 22-May-82  114 Code
  This implementation of the USUS Remote Unit assumes the 
minimum about the communications connection.  It is useful
when using an acoustic coupler environment or direct connect
modem which does not have auto-dial capabilities, as well as
in hardwire situations.  It does assume a synchronous BIOS
and a standard implementation of UnitStatus, UnitRead, and
UnitWrite.  It has been compiled under IV.0 and used
extensively.

USERLIB.TEXT       4 22-May-82  139 Text
  This is a user library file that points to the standard
unit's code file.  By entering "x" followed by 
"TERM.MAIN L=USERLIB" one executes the most recent version 
of TERMINAL.

TERM.EMUL.TEXT    10 29-May-82  172 Text
TERM.MAIN.TEXT    20 29-May-82  182 Text
TERM.INIT.TEXT    22 29-May-82  202 Text
TERM.LOG.TEXT     14 29-May-82  125 Text
TERM.UTIL.TEXT    22  3-Jun-82  232 Text
TERM.MAIN.CODE    32  3-Jun-82  254 Code
  These files also contain the source and object of
TERMINAL.  However, this version is much improved over the
other.  The code file is for version IV.0 and has been used
extensively.
  New and improved features of this version include:
  1) The memory buffer is moved to disk using
BLOCKWRITE, instead of the much slower WRITE/WRITELN. 
In addition, the file created is a legal text file. 
That is, each block pair ends with <return> followed by
nulls.
  2) TERMINAL tells you how large the log file is in
blocks.  This allows you to monitor the file size in
case your available space is limited.
  3) The Menu has more information in it.  The options 
selected, the name of the log file, and the logon text
selected are all displayed in the menu.
  4) When returning to terminal emulation from the
menu, the last 10 lines of the log file are
redisplayed.
  5) The program has been reorganized and segmented 
to fit smaller machines (like my 56K 8080).
  6) Logon text, previously compiled into the program,
is now stored in a file, along with default option
settings.  The file can reside on any blocked volume in
the set [4,5,9..17].  The program will search first the
prefix volume, then the system volume, then #4, #5, #9,
and up to #17:.
  The segmentation uses more segments than are available
in some versions of the p-System.  This may result in
compile errors under I.4, I.5, and II.x if some routines are
not removed from the list of segment procedures.  See the
documentation in TERM.MAIN.TEXT for additional information.
  To use the program, first compile a USUS Remote Unit. Edit
TERM.MAIN.TEXT's unit reference to point to the Unit's code
file.  Compile using TERM.MAIN.TEXT as the compiler input
file.  Using LIBRARY, create a code file containing both the
output of the HSM.TROOT.TEXT compile and the Remote Unit
object code or use a user library.


  If questions come up regarding programs contained on this 
volume, contact the author at 
        Bob Peterson
        P.O. Box 1686
        Plano, Texas  75074
        (214) 995-0618 Central time zone business hours
        70235,326 on Compuserve via EMail or MUSUS
        *BVL1707 or *ZLZ1912 on GTE Telemail


========================================================================================
DOCUMENT :usus Folder:VOL15:hsm.uinc1.text
========================================================================================

PROCEDURE SETCOMMUNICATIONS(
                      PARITY        : boolean ;
                      EVEN          : boolean ;
                      RATE          : integer ;
                      CHARBITS      : integer ;
                      STOPBITS      : integer ;
                      DIR           : CR_WHOAMI ;
                      MODEL         : string ;
                  var RESULT        : CR_BAUD_RESULT ) ;


begin

  MODEL_ID := '' ;

  BAUD_SETTABLE := false ;
  
  RESULT := CR_SELECT_NOT_SUPPORTED ;

  if length( MODEL )>2 then if (copy(MODEL,1,3) = '990')
    then
      RESULT := CR_SET_OK ;
  
  CONTROL := 12 ;
end ; { SETCOMMUNICATIONS }

PROCEDURE COMMINIT(  DIR             : CR_WHOAMI ;
                     ATTENTION_CHAR  : CHAR ;
                 VAR REMOTE_EXISTS   : BOOLEAN ;
                 VAR DIALER_EXISTS   : BOOLEAN ) ;
VAR
  C                     : CHAR ;
  RESULT                : CR_BAUD_RESULT ;

PROCEDURE NOT_THERE( WHICH : INTEGER ) ;
BEGIN
  GOTOXY( 0, 10 ) ;
  WRITELN(' ':20, 'Required unit #', WHICH, 
          ' failed UNITCLEAR!') ;
  REMOTE_EXISTS := FALSE ;
END ;

BEGIN
  
  { Check that the required units exist. }
  REMOTE_EXISTS := TRUE ;
  
  UNITCLEAR( REMIN_UNIT ) ;
  IF IORESULT <> 0
    THEN
      NOT_THERE( REMIN_UNIT ) ;
  
  UNITCLEAR( REMOUT_UNIT ) ;
  IF IORESULT <> 0
    THEN
      NOT_THERE( REMOUT_UNIT ) ;
  
  IF NOT SM_ATTENTION
    THEN
      IF NOT SM_ATTENTION
        THEN
          CR_HOOK( HUNG_UP ) ;
  
  DIALER_EXISTS := CHECK_SMARTMODEM_THERE ;

  MODEL_ID      := '' ;
  DTR_STATE     := CR_AUTO ;
  RTS_STATE     := CR_AUTO ;
  CR_HOOK( HUNG_UP ) ;
  CR_ATTENCHAR  := ATTENTION_CHAR ;

  SETCOMMUNICATIONS(
                        DEFAULT_MODE,
                        DEFAULT_PARITY,
                        DEFAULT_RATE,
                        DEFAULT_CHARBITS,
                        DEFAULT_STOPBITS,
                        CR_ORIG,
                        DEFAULT_KIND,
                        RESULT ) ;
  BAUD_SETTABLE := RESULT = CR_SELECT_NOT_SUPPORTED ;
END ; { COMMINIT }


PROCEDURE COMMQUIT ;
VAR
  C             : CHAR ;
  RESULT        : CR_BAUD_RESULT ;
BEGIN
  IF UNIT_CARRIER { If we think we are communicating, }
    THEN
      IF NOT SM_ATTENTION { . . . get the Smartmodem's attention, }
        THEN
          IF NOT SM_ATTENTION
            THEN
              { Null } ;
  IF SM_ATTENTION
    THEN
      CR_HOOK( HUNG_UP ) ; { Now hang up the phone. }
  IF BAUD_SETTABLE  { If we were able to change the baud rate, }
    THEN
      SETCOMMUNICATIONS(     { . . . reset to the default. }
                        DEFAULT_MODE,
                        DEFAULT_PARITY,
                        DEFAULT_RATE,
                        DEFAULT_CHARBITS,
                        DEFAULT_STOPBITS,
                        CR_ORIG,
                        DEFAULT_KIND,
                        RESULT ) ;
  IF SM_ATTENTION
    THEN
      { "Z" is a software reset of the Smartmodem. }
      C := SM_EXECUTE_COMMAND( 'Z', SM_SHORT_WAIT ) ;
END ; { COMMQUIT }

{ End of procedures set up for change to Segment Procedures. }

PROCEDURE CR_SETADDRESS{   HIGHADDR        : INTEGER ;
                           LOWADDR         : INTEGER ;
                           VECTOR          : INTEGER } ;
BEGIN
  SETADDRESS( HIGHADDR, LOWADDR, VECTOR ) ;
END ;

PROCEDURE CR_SETCOMMUNICATIONS{
                      PARITY        : boolean ;
                      EVEN          : boolean ;
                      RATE          : integer ;
                      CHARBITS      : integer ;
                      STOPBITS      : integer ;
                      DIR           : CR_WHOAMI ;
                      MODEL         : string ;
                  var RESULT        : CR_BAUD_RESULT } ;
BEGIN
  SETCOMMUNICATIONS(
                      PARITY,
                      EVEN,
                      RATE,
                      CHARBITS,
                      STOPBITS,
                      DIR,
                      MODEL,
                      RESULT ) ;
END ;

PROCEDURE CR_SETDTR ;
BEGIN
END ;

PROCEDURE CR_SETRTS ;
BEGIN
END ;

PROCEDURE CR_COMMINIT{  DIR             : CR_WHOAMI ;
                        ATTENTION_CHAR  : CHAR ;
                    VAR REMOTE_EXISTS   : BOOLEAN ;
                    VAR DIALER_EXITST   : BOOLEAN } ;
BEGIN
   COMMINIT(  DIR,
              ATTENTION_CHAR,
              REMOTE_EXISTS,
              DIALER_EXISTS ) ;
END ;

PROCEDURE CR_COMMQUIT ;
BEGIN
  COMMQUIT ;
END ;
{$P+}
{  ---------------------------------------------------------  }
{               Internal Subroutines                          }
{  ---------------------------------------------------------  }
FUNCTION  SM_EXECUTE_COMMAND{ CMD        : STRING ;
                              WAIT_COUNT : INTEGER ) : CHAR } ;
VAR
  CH    : CHAR ;
  I     : INTEGER ;
  
BEGIN
  CR_DELAY( 2 ) ;
  WHILE CR_REMSTAT DO CH := CR_GETREM ; { Flush trash }
  { "AT" is what the Smartmodem requires at the start of 
         each command line. }
  CR_PUTREM( 'A' ) ;
  CR_PUTREM( 'T' ) ;
  CR_PUTREM( ' ' ) ;
  FOR I := 1 TO LENGTH( CMD ) DO { Output each command char. }
    CR_PUTREM( CMD[I] ) ;
  CR_PUTREM( CHR(13) ) ; { Terminate command with <return> }
  I := WAIT_COUNT ;
  REPEAT                 { Wait for a response. }
    I := I - 1 ;
    IF CR_KBSTAT         { This allows a manual exit, using  }
      THEN               { <attention character> from the    }
        IF CR_GETKB = CR_ATTENCHAR { keyboard.               }
          THEN
            I := 0 ;
  UNTIL (I <= 0) OR CR_REMSTAT ; { Loop until the counter goes
                                   to zero or something comes in
                                   from the Remote line. }
  IF CR_REMSTAT { If something came from the remote line, }
    THEN
      BEGIN
      CH := CR_GETREM ; { fetch character from Remote. }
      IF ORD( CH ) > 127
        THEN
          CH := CHR( ORD( CH ) - 128 ) ;
      CR_DELAY( 2 ) ;
      END
    ELSE
      BEGIN
      CH := SM_ERROR ; { If we timed out, return an error. }
      CR_DELAY( 2 ) ;
      END ;
  SM_EXECUTE_COMMAND := CH ;
  WHILE CR_REMSTAT DO CH := CR_GETREM ; { Flush trash }
END ;


FUNCTION  CHECK_SMARTMODEM_THERE { : BOOLEAN } ;
{ This function returns TRUE if the Smartmodem responds to
  a simple command.  It returns FALSE if the Smartmodem does
  not understand the command or if no response is generated
  (such as when the Smartmodem is not connected or the unit
  is being used with some other type of modem.) }
VAR
  B     : BOOLEAN ;
  C     : CHAR ;
BEGIN
  { The command sent has the following effects:
    "E" causes the Smartmodem to suppress echoing command
        characters
    "V" causes the Smartmodem to use abbreviated command 
        responses
  }
  C := SM_EXECUTE_COMMAND( SM_DEFAULTS, SM_SHORT_WAIT ) ;
  IF ORD( C ) > 127
    THEN
      C := CHR( ORD( C ) - 128 ) ;
  B := SM_OK = C ; 
  CR_DELAY( 2 ) ;
  CHECK_SMARTMODEM_THERE := B ;
END ;
      
FUNCTION  SM_ATTENTION { : BOOLEAN } ;
{ This function will get the Smartmodem's attention, irregardless
  of the modem's state. }
VAR
  B : BOOLEAN ;
BEGIN
  CR_SETDTR( CR_OFF ) ; { If the user has implemented this 
                          routine, setting DTR low will get 
                          the Smartmodem's attention. }
  CR_SETDTR( CR_AUTO ) ;
  B := CHECK_SMARTMODEM_THERE ;
  IF NOT B
    THEN
      BEGIN
      CR_DELAY( 2 ) ;
      CR_DELAY( 12 ) ;   { Delay just over 1 second }
      CR_PUTREM( '+' ) ; { "+++" is the default attention getter. }
      CR_PUTREM( '+' ) ;
      CR_PUTREM( '+' ) ;
      CR_DELAY( 12 ) ;   { Delay just over 1 second }
      CR_PUTREM( CHR( CR ) ) ;
      B := CHECK_SMARTMODEM_THERE ;
      END ;
  CR_DELAY( 2 ) ;
  SM_ATTENTION := B ;
END ;



========================================================================================
DOCUMENT :usus Folder:VOL15:hsm.uinc2.text
========================================================================================

{$P+}
{  ---------------------------------------------------------  }
{               Control Procedures                            }
{  ---------------------------------------------------------  }

PROCEDURE CR_ANSWER ; { ** UNTESTED ** }
VAR
  C                     : CHAR ;
  CONNECTED             : BOOLEAN ;
  COUNT                 : INTEGER ;
  RING                  : BOOLEAN ;
  WAITING               : BOOLEAN ;
BEGIN
  IF NOT SM_ATTENTION
    THEN
      ; { null }
  C := SM_EXECUTE_COMMAND( CONCAT( 'S0=', ANSWER_AFTER ), 
                                               SM_SHORT_WAIT ) ;
  WAITING := TRUE ;
  WHILE WAITING DO
    BEGIN
    RING := CR_RINGING ;
    WAITING := NOT RING ;
    IF WAITING
      THEN
        IF CR_KBSTAT
          THEN
            WAITING := CR_GETKB <> CR_ATTENCHAR ;
    END ;
  IF RING
    THEN
      BEGIN
      UNITCLEAR( REMIN_UNIT ) ;
      UNITCLEAR( REMOUT_UNIT ) ;
      WAITING := TRUE ;
      CONNECTED := FALSE ;
      COUNT := 32000 ;
      REPEAT
        COUNT := COUNT - 1 ;
        IF CR_KBSTAT
          THEN
            WAITING := NOT (CR_GETKB = CR_ATTENCHAR)
          ELSE
            IF CR_REMSTAT
              THEN
                BEGIN
                WAITING := NOT (CR_GETREM = SM_CONNECT) ;
                CONNECTED := NOT WAITING ;
                END
              ELSE
                WAITING := COUNT > 0 ;
      UNTIL NOT WAITING ;
      IF NOT CONNECTED
        THEN
          CR_HOOK( HUNG_UP ) ;
      END ;
END ; { CR_ANSWER }

PROCEDURE CR_BREAK ;
BEGIN
END ;

function  CR_CARRIER{: boolean};
begin
  CR_CARRIER  := UNIT_CARRIER ;
  OFF_HOOK    := UNIT_CARRIER ;
end ; { CR_CARRIER }

FUNCTION  CR_CLEARTOSEND{ : BOOLEAN } ;
BEGIN
  CR_CLEARTOSEND := TRUE ;
END ; { CR_CLEARTOSEND }


procedure CR_DELAY{ TENTHS : integer } ;
{ Purpose: delay 0.1 seconds for each tenth requested. }
var
  clock        : T_CLOCK ;
  I            : integer ;
  J            : integer ;
begin
  I := TENTHS ;
  while i > 0 do
    begin
    I := I - 1 ;
    J := TIMER ;
    while j > 0 do
      j := j - 1 ;
    end ;
end ; { CR_DELAY }


PROCEDURE CR_DIAL{ NUMBER       : STRING ;
                   WAITCHAR     : CHAR ;
               VAR RESULT       : CR_DIAL_RESULT } ;
{ This routine will cause the Smartmodem to dial the number 
  passed. }
  
VAR
  I             : INTEGER ;
  CMD           : STRING ;
  VALID_SET     : SET OF CHAR ;
BEGIN
  { Initialize valid character set }
  VALID_SET := [ 'P', 'T', '*', '#', ';', WAITCHAR,
            '0', '1', '2', '3', '4', '5','6', '7', '8', '9' ] ;
  
  RESULT := CR_DIALERROR ; { Assume an error }

  { Get Smartmodem's attention. }
  IF NOT SM_ATTENTION
    THEN
      EXIT( CR_DIAL ) ;

  CR_HOOK( HUNG_UP ) ; { Be sure we know where we are. }

  { Start the dial command with the dial prologue.  (See the
    Implementation Constant list.) }
  CMD := SM_DIAL_PROLOGUE ;
  FOR I := 1 TO LENGTH( NUMBER ) DO
    IF NUMBER[I] IN VALID_SET { Include only valid characters }
      THEN                    { in the passed number.         }
         CMD := CONCAT( CMD, COPY( NUMBER, I, 1 ) ) ;
  { Execute the dial command and be patient about the response.}
  IF SM_EXECUTE_COMMAND( CMD, SM_LONG_WAIT ) = SM_CONNECT
    THEN
      BEGIN                     { We got an answer & carrier. }
      RESULT := CR_OFF_HOOK ;
      UNIT_CARRIER := TRUE ;
      END
    ELSE                        { No carrier.  We may have an  }
      UNIT_CARRIER := FALSE ;   { answer.  We'll never know.   }
END ; { CR_DIAL }

FUNCTION  CR_DIALTONE ;
BEGIN
  CR_DIALTONE := TRUE ;
END ;

PROCEDURE CR_HOOK{ ON_HOOK      : BOOLEAN } ;
BEGIN
  IF ON_HOOK            { If we want to go on-hook, }
    THEN
      BEGIN
      IF NOT SM_ATTENTION { . . . get the modem's attention. }
        THEN
          IF NOT SM_ATTENTION
            THEN
              ;
      { Send the "hang up" command. }
      OFF_HOOK := NOT 
           (SM_EXECUTE_COMMAND( 'H0', SM_SHORT_WAIT ) = SM_OK)
      END
    ELSE
      OFF_HOOK := TRUE ;
  UNIT_CARRIER := OFF_HOOK ; { The simulated carrier follows
                               the status of the reciever.   }
END ; { CR_HOOK }

FUNCTION  CR_RINGING { : BOOLEAN } ; { ** UNTESTED ** }
BEGIN
  IF CR_REMSTAT
    THEN
      CR_RINGING := SM_RING = CR_GETREM
    ELSE
      CR_RINGING := FALSE ;
END ;
{$P+}
{  ---------------------------------------------------------  }
{               Status Procedures                             }
{  ---------------------------------------------------------  }

FUNCTION  CR_KBSTAT{ : BOOLEAN } ;
VAR
  A     : TRICK ;
BEGIN
  UNITSTATUS( KB_UNIT, A, 1 ) ;
  CR_KBSTAT := A.I > 0 ;
END ; { CR_KBSTAT }

FUNCTION  CR_REMSTAT{ : BOOLEAN } ;
VAR
  A     : TRICK ;
BEGIN
  UNITSTATUS( REMIN_UNIT, A, 1 ) ;
  CR_REMSTAT := A.I > 0 ;
END ; { CR_REMSTAT }
{$P+}
{  ---------------------------------------------------------  }
{               Input/Output Procdures                        }
{  ---------------------------------------------------------  }

FUNCTION  CR_GETKB{ : CHAR } ;
VAR
  ARAY                  : TRICK ;
BEGIN
  UNITREAD( KB_UNIT, ARAY.A, 1,, 12 ) ;
  CR_GETKB := ARAY.A[0] ;
END ; { CR_GETKB }

FUNCTION  CR_GETREM{ : CHAR } ;
VAR
  ARAY                  : TRICK ;
BEGIN
  UNITREAD( REMIN_UNIT, ARAY.A, 1,, CONTROL ) ;
  CR_GETREM := ARAY.A[0] ;
END ; { CR_GETREM }

PROCEDURE CR_PUTREM{ C : CHAR } ;
VAR
  P                     : TRICK ;
BEGIN
  P.A[0] := C ;
  UNITWRITE( REMOUT_UNIT, P.A, 1, 0, CONTROL ) ;
END ; { CR_PUTREM }



========================================================================================
DOCUMENT :usus Folder:VOL15:hsm.uroot.text
========================================================================================

UNIT REMUNIT ;{ IV.0 w/ SMARTMODEM}{xL Printer: }{xL+}

INTERFACE
{============== Copyright Notice =============================================}
{$c Copyright 1980, 1981 by Robert W. Peterson.  All Rights Reserved. }
{============== Copyright Notice =============================================}


{ This is a separate compilation unit intended to stand
  between application code and a communication line.
  Implementation of this unit follows the specifications and
  suggestions set out in the USUS (UCSD p-System User Society)
  Remote Unit Standard of August, 1981.
  
  This unit is specifically intended for the following 
  communications environment:
        1) A p-System which implements Unitstatus, Unitread
           and Unitwrite in the standard manner.
        2) The modem in use is a Hayes Microcomputer Products,
           Inc., Smartmodem with the factory option switch 
           settings.

  
  This unit is designed to interface to the model codes defined in the 
  include file "SMART.TINC.TEXT".


  The following routines are not functional:
        CR_BREAK
        CR_CLEARTOSEND
        CR_DIALTONE
        CR_SETADDRESS
        CR_SETDTR
        CR_SETRTS
  
  The following routines contain calls to UnitClear:
        CR_ANSWER
        CR_COMMINIT

  There is code near the end of this unit which is IV.0 dependent.  For
  versions of the p-System(tm) other than IV.0, this code must be moved
  to CR_COMMINIT.

  The author may be contacted as follows:
  
        USMail:
                Robert W. Peterson
                P.O. Box 1686
                Plano, Texas  75074
        
        GTE Telemail:
                *BVL1707

        Compuserve:
                70235,326 
                  (usually via EMAIL or the MUSUS SIG)


                                   Change Log
                                   ====== ===
  Date     What change was made & Who made the change
---------  ----------------------------------------------------------------
 5 Dec 81  Remove 990 specific code.  Remove Segment procedures-Bob Peterson
 5 Dec 81  Partition the source to fit memory-bound editor - Bob Peterson
 2 Dec 81  Remove compile conditionals and debug stuff - Bob Peterson
19 Nov 81  Add compile conditionals for debugging and Segments-Bob Peterson
26 Oct 81  Convert from Polymorphic to 990 
25 Aug 81  Bring up to actually adopted standard - Bob Peterson
25 Aug 81  Add Hayes Smartmodem support - Bob Peterson
 3 Aug 81  Convert to IV.0 - Bob Peterson
28 Mar 81  Original code - Bob Peterson


 =============================================================================}
{$P+}
TYPE
  CR_BAUD_RESULT    = ( CR_BAD_PARAMETER,
                        CR_BAD_RATE,
                        CR_SET_OK,
                        CR_SELECT_NOT_SUPPORTED ) ;
  CR_DIALRESULT     = ( CR_OFF_HOOK, 
                        CR_DIALERROR,
                        CR_NOAUTODIAL ) ;
  CR_REM_PORT       =  PACKED RECORD
                        PART1   : INTEGER ;
                        PART2   : INTEGER ;
                        END ; { CR_REM_PORT }
  CR_STATE          = ( CR_ON, 
                        CR_OFF, 
                        CR_AUTO ) ;
  CR_WHOAMI         = ( CR_ORIG,
                        CR_ANS ) ;

VAR
  CR_ATTENCHAR          : CHAR ;
  CR_CURRENT_PORT       : CR_REM_PORT ;

{       Initialization and termination routines. }
PROCEDURE CR_COMMINIT(  DIR             : CR_WHOAMI ;
                        ATTENTION_CHAR  : CHAR ;
                    VAR REMOTE_EXISTS   : BOOLEAN ;
                    VAR DIALER_EXISTS   : BOOLEAN ) ;

PROCEDURE CR_COMMQUIT ;


{       Input status. }
FUNCTION  CR_KBSTAT                     : BOOLEAN ;
FUNCTION  CR_REMSTAT                    : BOOLEAN ;


{       Input/Output operations. }
FUNCTION  CR_GETKB                      : CHAR ;
FUNCTION  CR_GETREM                     : CHAR ;
PROCEDURE CR_PUTREM(                  C : CHAR ) ;


{       Control procedures. }
PROCEDURE CR_ANSWER ;
PROCEDURE CR_BREAK ;
FUNCTION  CR_CARRIER                    : BOOLEAN ;
FUNCTION  CR_CLEARTOSEND                : BOOLEAN ;
PROCEDURE CR_DELAY(     TENTHS          : INTEGER ) ;
PROCEDURE CR_DIAL(      NUMBER          : STRING ;
                        WAITCHAR        : CHAR
                    VAR RESULT          : CR_DIALRESULT ) ;
FUNCTION  CR_DIALTONE                   : BOOLEAN ;
PROCEDURE CR_HOOK(      ON_HOOK         : BOOLEAN ) ;
FUNCTION  CR_RINGING                    : BOOLEAN ;
PROCEDURE CR_SETADDRESS(HIGHADDR        : INTEGER ;
                        LOWADDR         : INTEGER ;
                        VECTOR          : INTEGER ) ;
PROCEDURE CR_SETCOMMUNICATIONS(
                        PARITY          : BOOLEAN ;
                        EVEN            : BOOLEAN ;
                        RATE            : INTEGER ;
                        CHARBITS        : INTEGER ;
                        STOPBITS        : INTEGER ;
                        DIR             : CR_WHOAMI ;
                        MODEL           : STRING ;
                    VAR RESULT          : CR_BAUD_RESULT ) ;
PROCEDURE CR_SET_DTR(   NEW_STATE       : CR_STATE ) ;
PROCEDURE CR_SET_RTS(   NEW_STATE       : CR_STATE ) ;

IMPLEMENTATION
{$P+}{ Page here so the option is not in the interface text. }
CONST
  ANSWER_AFTER          =    '3' ; { Answer after this many rings}
  CR                    =     13 ; { Carriage Return }
  DEFAULT_RATE          =    300 ;
  DEFAULT_MODE          =   TRUE ; { Default to parity enabled. }
  DEFAULT_PARITY        =   TRUE ; { Default to even parity.    }
  DEFAULT_CHARBITS      =      7 ; { Default to seven data bits.}
  DEFAULT_KIND          = '990/5'; { Default model code. }
  DEFAULT_STOPBITS      =      1 ; { Default to one stop bits.  }
  HUNG_UP               =   TRUE ;
  KB_UNIT               =      2 ;
  REMIN_UNIT            =      7 ;
  REMOUT_UNIT           =      8 ;
  TIMER                 =    600 ;

{ Smartmodem return codes: }
  SM_OK                 = '0' ;
  SM_CONNECT            = '1' ;
  SM_RING               = '2' ;
  SM_NO_CARRIER         = '3' ;
  SM_ERROR              = '4' ;
                          {                                   Default
                            S6 =wait for dial tone in seconds     2
                            S7 =wait for carrier in seconds      30
                            S8 =pause time for comma in seconds   2
                            S9 =carrier detector response time
                                in tenths of a second             6
                            S10=delay between loss of carrier
                                and hangup, in seconds            7
                            S11=TouchTone duration and spacing
                                in milliseconds                  70
                            S12=escape code guard time in
                                50ths of a second                50
                           }
  SM_DEFAULTS           = 'EV S10=4 S12=10' ;
  SM_DIAL_PROLOGUE      = 'DT' ; { D=dial command; T=use tone dialing }
  SM_LONG_WAIT          = 32000 ;
  SM_SHORT_WAIT         =   500 ;
  
  
TYPE
  T_CLOCK = record
            case boolean of 
              { NOTE: TI uses binary representation for long integers.  }
              true  : ( ticks      : integer[ 4 ] ) ;
              false : ( hitime     : integer ;
                        lotime     : integer ) ;
              end ; { case }
  TRICK                 = PACKED RECORD
                          CASE INTEGER OF
                          1:(A : PACKED ARRAY[0..80] OF CHAR);
                          2:(S : STRING[80]);
                          3:(I : INTEGER;
                             J : INTEGER);
                          4:(L : ARRAY[0..39] OF INTEGER);
                          5:(B : ARRAY[0..39] OF BOOLEAN);
                          6:(C : PACKED RECORD
                                 CHARL  : CHAR ;
                                 CHARR  : CHAR 
                                 END ) ;
                          END ; { TRICK }

VAR
  BAUD_SETTABLE         : BOOLEAN ;
  CONTROL               : INTEGER ;
  CURRENT_BAUD          : INTEGER ;
  DTR_STATE             : CR_STATE ;
  MODEL_ID              : STRING ;
  OFF_HOOK              : BOOLEAN ;
  RTS_STATE             : CR_STATE ;
  UNIT_CARRIER          : BOOLEAN ;


FUNCTION  SM_EXECUTE_COMMAND( CMD        : STRING ;
                              WAIT_COUNT : INTEGER ) : CHAR ;    FORWARD ;
FUNCTION  CHECK_SMARTMODEM_THERE                     : BOOLEAN ; FORWARD ;
FUNCTION  SM_ATTENTION                               : BOOLEAN ; FORWARD ;
{$P+}
{  ---------------------------------------------------------  }
{               Initialization/Termination Procedures         }
{  ---------------------------------------------------------  }


{ The following procedures are set up this way so that in IV.0
  it is a simple matter to Segment the actual code.  These are not
  time-critical routines, so even the small delay caused by the 
  indirect call does not matter.
  
  To make these into IV.0 Segment procedures, simply add "SEGMENT" 
  just before the "PROCEDURE" keyword.
}

PROCEDURE SETADDRESS(   HIGHADDR        : INTEGER ;
                        LOWADDR         : INTEGER ;
                        VECTOR          : INTEGER ) ;
BEGIN
  WITH CR_CURRENT_PORT DO
    BEGIN
    PART1 := HIGHADDR ;
    PART2 := LOWADDR ;
    END ;
END ; { SETADDRESS }

{$I HSM.UINC1.TEXT }
{$I HSM.UINC2.TEXT }
{$P+}
BEGIN

{  *******************************************************************  }
{  *******************************************************************  }
{            This code is initialization code.  Leave it here for       }
{         IV.0 but move it to CR_COMMINIT for any other version.        }
{         Under IV.0, this code is guaranteed to be executed before     }
{         any other code in this unit.                                  }
{  *******************************************************************  }
{  *******************************************************************  }

  CR_ATTENCHAR          := CHR( 5 ) ; { <control>E }
  CR_CURRENT_PORT.PART1 :=        0 ;
  CR_CURRENT_PORT.PART2 :=        0 ;

  BAUD_SETTABLE         :=    FALSE ;
  CONTROL               :=       12 ;
  CURRENT_BAUD          :=      300 ;
  DTR_STATE             :=  CR_AUTO ;
  MODEL_ID              :=       '' ;
  OFF_HOOK              :=    FALSE ;
  RTS_STATE             :=  CR_AUTO ;
  UNIT_CARRIER          :=    FALSE ;
{  *******************************************************************  }
{  *******************************************************************  }
{             End of IV.0 initialization code.                          }
{  *******************************************************************  }
{  *******************************************************************  }

   *** ; { In any version other than IV.0, remove this line. }

END.



========================================================================================
DOCUMENT :usus Folder:VOL15:iounit.text
========================================================================================

UNIT IOUNIT;
{This is an implememtation dependent unit for LSI-11's.  It allow direct
 access to the hardware buffers so the i/o can be accomplished directly
 without the intervention of the OS.  It may be necessary to disable
 interrupts at a port if characters are to be read from that port as the
 interrupt driven OS has a tendency to snatch them away before you can get
 your hands on them.    george w. schreyer}
 
INTERFACE

TYPE CHAR_POINTER = ^CHAR;
     WORD = PACKED ARRAY[0..15] OF BOOLEAN;
     WORD_POINTER = ^WORD;

VAR MODEM_RBUF   : CHAR_POINTER;
    MODEM_RCSR   : WORD_POINTER;
    MODEM_XBUF   : CHAR_POINTER;
    MODEM_XCSR   : WORD_POINTER;
    
    PRINT_RBUF   : CHAR_POINTER;
    PRINT_RCSR   : WORD_POINTER;
    PRINT_XBUF   : CHAR_POINTER;
    PRINT_XCSR   : WORD_POINTER;
    
    CRT_RBUF     : CHAR_POINTER;
    CRT_RCSR     : WORD_POINTER;
    CRT_XBUF     : CHAR_POINTER;
    CRT_XCSR     : WORD_POINTER;
    
    BIT : WORD;
    
PROCEDURE VER_IOUNIT;
PROCEDURE SET_UP_POINTERS;

(******************)

IMPLEMENTATION

PROCEDURE VER_IOUNIT ;
BEGIN
   WRITELN('uses iounit     version 1     5-Aug-81');
END;

PROCEDURE SET_UP_POINTERS;  {sets values of pointers}
 TYPE REP = (POINTREP,INTREP);   {this procedure adapted from SMARTREMOT in
                                                   USUS library}
      TTT = (WORDREF,BITREP);
 
 ALIAST = RECORD
    CASE REP OF
       POINTREP: (POINTVAL : CHAR_POINTER);
       INTREP  : (INTVAL : INTEGER);
    END;
 
 BUFFER = RECORD
    CASE TTT OF
       WORDREF : (WORDVAL : WORD_POINTER);
       BITREP  : (INTVALX : INTEGER);
    END;
    
 VAR ALIAS : ALIAST;
     XBUFFER : BUFFER;
 
 {the negative numbers below are two's complement representations of the
  addresses (octal) of various places in the I/O page.  The addresses used 
  conform to UCSD and RT-11 standard conventions.  Although not important
  here, the vector is 200.}
 
 BEGIN
    ALIAS.INTVAL := -182;   {printer rbuf, 177512}
    PRINT_RBUF := ALIAS.POINTVAL;
    
    XBUFFER.INTVALX := -184;   {printer rcsr, 177510}
    PRINT_RCSR := XBUFFER.WORDVAL;
    
    ALIAS.INTVAL := -178;   {printer xbuf, 177516}
    PRINT_XBUF := ALIAS.POINTVAL;
    
    XBUFFER.INTVALX := -180;   {printer xcsr, 177514}
    PRINT_XCSR := XBUFFER.WORDVAL;
    
    (*********)
    
    ALIAS.INTVAL := -170;   {modem xbuf,  177526}
    MODEM_XBUF := ALIAS.POINTVAL;
    
    XBUFFER.INTVALX := -172;  {modem xcsr, 177524}
    MODEM_XCSR := XBUFFER.WORDVAL;
    
    ALIAS.INTVAL := -174;   {modem rbuf,  177522}
    MODEM_RBUF := ALIAS.POINTVAL;
    
    XBUFFER.INTVALX := -176;  {modem rcsr,  177520}
    MODEM_RCSR := XBUFFER.WORDVAL;
    
    (********)
    
    ALIAS.INTVAL := -138;  {console xbuf,  177566}
    CRT_XBUF := ALIAS.POINTVAL;
    
    XBUFFER.INTVALX := -140;  {console xcsr,  177564}
    CRT_XCSR := XBUFFER.WORDVAL;
    
    ALIAS.INTVAL := -142;  {console rbuf,  177562}
    CRT_RBUF := ALIAS.POINTVAL;
    
    XBUFFER.INTVALX := -144;  {console rcsr,  177560}
    CRT_RCSR := XBUFFER.WORDVAL;
    
    
END;   {initpointer}

            
END.
            

========================================================================================
DOCUMENT :usus Folder:VOL15:remtalk.text
========================================================================================

{ Mark Allen's Box to Box Talker }
{$I-,R-}
program talker;
const
  readunit=7;
  writeunit=8;
  filestringsize=40;
  blockmax=511; {# of bytes in a packet - 1. must be (512/(2**n))-1 n=0..7}
  tempmax=686;  {=ceiling((blockmax+1)*4/3)+4 - 1 (4 for checksum)}
type
  commands=
    (nocommand,sendblock,resendblock,getblock,regetblock,
     resetfile,rewritefile,gotoprompt,closefile,success,
     sumerror,diskerror,closerror,openerror);
  setofchar=set of char;
  bufftype=packed array[0..0,0..blockmax] of char;
  
var
  commandtoch:packed array[commands] of char;
  chtocommand:packed array[char] of commands;
  ch:packed array[0..1] of char;
  tempbuff:packed array[0..tempmax] of 0..255;
  f:file;
  C : TEXT;
  ReDir : BOOLEAN;
  buff:^bufftype;
  charcnt,buffpos,bufffirst,bufflast,buffsize:integer;
  buffbyte:packed record case integer of
             0:(int:integer);
             1:(bit05:0..63;
                bit67:0..3;
                fill1:0..255);
             2:(bit03:0..15;
                bit47:0..15;
                fill2:0..255);
             3:(bit01:0..3;
                bit27:0..63;
                fill3:0..255);
           end;

  FUNCTION ReDirect : BOOLEAN;
  BEGIN
    ReDir := ReDir AND NOT EOF (C);
    ReDirect := ReDir
    END;

  FUNCTION ReadChar : CHAR;
  VAR
    Ch : CHAR;
  BEGIN
    IF ReDirect
      THEN READ (C, Ch)
      ELSE READ (KeyBoard, Ch);
    ReadChar := Ch
    END;

  PROCEDURE ReadLine (VAR Str : STRING);
  BEGIN
    IF ReDirect
      THEN BEGIN
        READLN (C, Str);
        WRITELN (Str)
        END
      ELSE READLN (Str)
    END;

  function prompt(message:string; okset:setofchar):char;
  var ch:char;
  begin
    write(message);
    repeat
      Ch := ReadChar;
      if ch in ['a'..'z'] then
        ch:=chr(ord(ch)-ord('a')+ord('A'));
      IF NOT (Ch IN OkSet)
        THEN ReDir := FALSE
    until ch in okset;
    writeln(ch);
    prompt:=ch;
  end;
  
  procedure error(message:string);
  begin
    writeln;
    writeln('ERROR: ',message);
  end;
  
  procedure outchar(ch:char);
  begin
    if charcnt>=40 then
    begin
      writeln;
      charcnt:=0;
    end;
    write(ch);
    charcnt:=charcnt+1;
  end;
  
  procedure initialize;
  type block=packed array[0..511] of char;
  var comm:commands;
      blockp:^block;
      ch:char;
  begin
    for ch:=chr(0) to chr(255) do
      chtocommand[ch]:=nocommand;
    for comm:=nocommand to openerror do
    begin
      ch:=chr(ord('1')+ord(comm));
      commandtoch[comm]:=ch;
      chtocommand[ch]:=comm;
    end;
    ReDir := FALSE;
    buffsize:=0;
    mark(buff);
    while ((memavail<0) or (memavail>3600)) and (buffsize<62) do
    begin
      new(blockp);
      buffsize:=buffsize+1;
    end;
    buffsize:=(512 div (blockmax+1))*buffsize;
  end;
  
  procedure sendcommand(comm:commands);
  begin
    ch[0]:=commandtoch[comm];
    unitwrite(writeunit,ch[0],1);
  end;
  
  function waitcommand:commands;
  begin
    unitread(readunit,ch[0],1);
    waitcommand:=chtocommand[ch[0]];
  end;
  
  procedure initbuffer;
  begin
    buffpos:=-1;
    bufffirst:=0;
    bufflast:=-1;
  end;
  
  function fillbuffer:commands;
  var size:integer;
  begin
    size:=blockread(f,buff^[0],buffsize div (512 div (blockmax+1)));
    bufffirst:=bufflast+1;
    bufflast:=bufffirst+(512 div (blockmax+1))*size-1;
    if ioresult=0 then
      if size=0 then
        fillbuffer:=closefile
      else
        fillbuffer:=success
    else
      begin
        fillbuffer:=diskerror;
        error('reading from file');
      end;
  end;
  
  function dumpbuffer:boolean;
  var size:integer;
      ok:boolean;
  begin
    size:=(buffpos-bufffirst+1) div (512 div (blockmax+1));
    ok:=(blockwrite(f,buff^[0],size)=size) and (ioresult=0);
    if not ok then
      error('writing to file');
    dumpbuffer:=ok;
    bufffirst:=buffpos+1;
  end;
  
  procedure xferout(isretry:boolean);
  var tempcnt,state,bytecnt,checksum:integer;
  begin
    state:=0;
    tempcnt:=0;
    checksum:=0;
    for bytecnt:=0 to blockmax do
    begin
      buffbyte.int:=ord(buff^[buffpos-bufffirst,bytecnt]);
      checksum:=checksum+buffbyte.int;
      case state of
        0:begin
            tempbuff[tempcnt]:=ord(odd(buffbyte.int) and odd(63)){.bit05}+32;
            tempcnt:=tempcnt+1;
            tempbuff[tempcnt]:=16*buffbyte.bit67+32;
            state:=1;
          end;
        1:begin
            tempbuff[tempcnt]:=tempbuff[tempcnt]+
                               ord(odd(buffbyte.int) and odd(15)){.bit03};
            tempcnt:=tempcnt+1;
            tempbuff[tempcnt]:=4*buffbyte.bit47+32;
            state:=2;
          end;
        2:begin
            tempbuff[tempcnt]:=tempbuff[tempcnt]+
                               ord(odd(buffbyte.int) and odd(3)){.bit01};
            tempcnt:=tempcnt+1;
            tempbuff[tempcnt]:=buffbyte.bit27+32;
            tempcnt:=tempcnt+1;
            state:=0;
          end;
      end;
    end;
    checksum:=abs(checksum);
    if isretry then
      outchar('?') else
      outchar('.');
    tempbuff[tempmax-3]:=ord('0')+checksum div 4096 mod 16;
    tempbuff[tempmax-2]:=ord('0')+checksum div 256 mod 16;
    tempbuff[tempmax-1]:=ord('0')+checksum div 16 mod 16;
    tempbuff[tempmax  ]:=ord('0')+checksum mod 16;
    unitwrite(writeunit,tempbuff,tempmax+1);
  end;
  
  function xferin:boolean;
  var tempbyte,i,sentcheck,checksum,tempcnt,state,bytecnt:integer;
  begin
    sendcommand(success);
    unitread(readunit,tempbuff,tempmax+1);
    state:=0;
    tempcnt:=0;
    buffbyte.int:=0;
    checksum:=0;
    for bytecnt:=0 to blockmax do
    begin
      case state of
        0:begin
            buffbyte.int{.bit05}:=ord(odd(tempbuff[tempcnt]) and odd(127))-32;
            tempcnt:=tempcnt+1;
            tempbyte:=ord(odd(tempbuff[tempcnt]) and odd(127))-32;
            buffbyte.bit67:=tempbyte div 16;
            state:=1;
          end;
        1:begin
            buffbyte.int{.bit03}:=ord(odd(tempbyte) and odd(15));
            tempcnt:=tempcnt+1;
            tempbyte:=ord(odd(tempbuff[tempcnt]) and odd(127))-32;
            buffbyte.bit47:=tempbyte div 4;
            state:=2;
          end;
        2:begin
            buffbyte.int{.bit01}:=ord(odd(tempbyte) and odd(3));
            tempcnt:=tempcnt+1;
            buffbyte.bit27:=ord(odd(tempbuff[tempcnt]) and odd(127))-32;
            tempcnt:=tempcnt+1;
            state:=0;
          end;
      end;
      buff^[buffpos-bufffirst,bytecnt]:=chr(buffbyte.int);
      checksum:=checksum+buffbyte.int;
    end;
    checksum:=abs(checksum);
    sentcheck:=0;
    for i:=tempmax-3 to tempmax do
      sentcheck:=16*sentcheck+tempbuff[i]-ord('0');
    if sentcheck=checksum then
      outchar('.') else
      outchar('?');
    xferin:=sentcheck=checksum;
  end;
  
  procedure master;
  var filename:string;
      result,answer:commands;
      ok:boolean;
      i:integer;
        
    procedure send;
    begin
      repeat
        write('    Send what file? ');
        ReadLine (FileName);
        if length(filename)=0 then
          exit(send);
        close(f);
        reset(f,filename);
        IF IORESULT <> 0
          THEN ReDir := FALSE
      until ioresult=0;
      repeat
        write('    To what remote file? ');
        ReadLine (FileName);
        if length(filename)=0 then
          exit(send);
        sendcommand(rewritefile);
        answer:=waitcommand;
        for i:=length(filename)+1 to filestringsize do
          filename[i]:=' ';
        unitwrite(writeunit,filename[1],filestringsize);
        answer:=waitcommand;
        IF Answer <> Success
          THEN ReDir := FALSE
      until answer=success;
      initbuffer;
      repeat
        buffpos:=buffpos+1;
        if buffpos>bufflast then
        begin
          answer:=fillbuffer;
          if answer=diskerror then
            exit(send);
        end else
          answer:=success;
        if answer=success then
        begin
          sendcommand(sendblock);
          answer:=waitcommand;
          if answer=success then
          begin
            xferout(false);
            answer:=waitcommand;
            while answer=sumerror do
            begin
              sendcommand(resendblock);
              answer:=waitcommand;
              xferout(true);
              answer:=waitcommand;
            end;
          end;
        end;
      until answer<>success;
      writeln;
      if answer=closefile then
      begin
        sendcommand(closefile);
        if waitcommand<>success then
          error('closing remote file');
      end else
        error('writing to remote file');
    end;
  
    procedure receive;
    begin
      repeat
        write('    Receive what remote file? ');
        ReadLine (FileName);
        if length(filename)=0 then
          exit(receive);
        sendcommand(resetfile);
        answer:=waitcommand;
        for i:=length(filename)+1 to filestringsize do
          filename[i]:=' ';
        unitwrite(writeunit,filename[1],filestringsize);
        answer:=waitcommand;
        IF Answer <> Success
          THEN ReDir := FALSE
      until answer=success;
      repeat
        write('    To what file? ');
        ReadLine (FileName);
        if length(filename)=0 then
          exit(receive);
        close(f);
        rewrite(f,filename);
        IF IORESULT <> 0
          THEN ReDir := FALSE
      until ioresult=0;
      initbuffer;
      repeat
        sendcommand(getblock);
        answer:=waitcommand;
        if answer=success then
        begin
          buffpos:=buffpos+1;
          while not xferin do
          begin
            sendcommand(regetblock);
            answer:=waitcommand;
          end;
        end;
        if (buffpos-bufffirst+1=buffsize) or (answer=closefile) then
          if not dumpbuffer then
            exit(receive);
      until answer in [closefile,diskerror];
      writeln;
      if answer=closefile then
      begin
        close(f,lock);
        if ioresult<>0 then
          error('closing file');
      end else
        error('reading from remote file');
    end;
  
    PROCEDURE FromFile;
    VAR
      FN : STRING;
    BEGIN
      ReDir := FALSE;
      CLOSE (C, LOCK);
      REPEAT
        WRITE ('    Get cmds from file : ');
        READLN (FN);
        IF LENGTH (FN) = 0 THEN EXIT (FromFile);
        FN := CONCAT (FN, '.TEXT');
        RESET (C, FN);
        UNTIL IORESULT = 0;
      ReDir := TRUE
      END;
  
  begin (*Master*)
    repeat
      charcnt:=0;
      case prompt('  S(end R(eceive F(ile Q(uit ',['S','R','F','Q']) of
        'S':send;
        'R':receive;
        'Q':begin
              sendcommand(gotoprompt);
              answer:=waitcommand;
              exit(master);
            end;
        'F': FromFile
      end;
    until false;
  end;
  
  procedure slave;
  var filename:string;
      i:integer;
      answer,command:commands;
  begin
    answer:=nocommand;
    repeat
      if answer<>nocommand then
        sendcommand(answer);
      answer:=nocommand;
      command:=waitcommand;
      case command of
        getblock,
        regetblock:
          begin
            if command=getblock then
              buffpos:=buffpos+1;
            if buffpos>bufflast then
              answer:=fillbuffer else
              answer:=success;
            if answer=success then
            begin
              sendcommand(success);
              answer:=waitcommand;
              xferout(command=regetblock);
              answer:=nocommand;
            end;
          end;
        sendblock,
        resendblock:
          begin
            answer:=success;
            if command=sendblock then
            begin
              if buffpos-bufffirst+1=buffsize then
                if not dumpbuffer then
                  answer:=diskerror;
              buffpos:=buffpos+1;
            end;
            if answer=success then
              if not xferin then
                answer:=sumerror;
          end;
        resetfile,
        rewritefile:
          begin
            writeln;
            initbuffer;
            charcnt:=0;
            sendcommand(success);
            unitread(readunit,filename[1],filestringsize);
            i:=filestringsize;
            while (i>0) and (filename[i]=' ') do
              i:=i-1;
            filename[0]:=chr(i);
            close(f);
            if command=resetfile then
            begin
              write('Sending ');
              reset(f,filename);
            end else
            begin
              write('Receiving ');
              rewrite(f,filename);
            end;
            if ioresult=0 then
              answer:=success else
              answer:=openerror;
            writeln(filename);
          end;
        closefile:
          begin
            answer:=diskerror;
            if dumpbuffer then
            begin
              close(f,lock);
              if ioresult=0 then
                answer:=success;
            end;
          end;
        gotoprompt:
          begin
            sendcommand(success);
            writeln;
            exit(slave);
          end;
      end;
    until false;
  end;
  
begin
  initialize;
  unitclear(readunit);
  unitclear(writeunit);
  writeln;
  writeln('Remtalk [14 Feb 82]');
  writeln(' 1) Let both machines reach this prompt');
  writeln(' 2) Press S(lave on one machine');
  writeln(' 3) Press M(aster on the other');
  repeat
    case prompt('M(aster S(lave Q(uit ',['M','S','Q']) of
      'M':master;
      'S':slave;
      'Q':exit(program);
    end;
  until false;
end.

========================================================================================
DOCUMENT :usus Folder:VOL15:remunit.l3.text
========================================================================================

{$S+}

{UNIT REMUNIT      Version L3     12 August 1981}

{============== Copyright Notice =======================}
        {$C Copyright 1980, 1981 by Robert W. Peterson }
{============== Copyright Notice =======================}
        {Copyright 1981 by Michael A. Ikezawa}
        {Copyright 1981 by Walter B. Farrell}
{============================================================
  This is a separate compilation unit intended to stand 
  between application code and a communication line.
  Implementation of this unit follows the specifications
  and suggestions set out in the Feburary 1981 draft of the
  USUS (UCSD p-System User Society) remote unit specification.

  This unit will interface to the following model codes:
        LSI-11

  The following routines are not functional:
        CR_CLEARTOSEND
        CR_DIAL
        CR_DIALTONE
        CR_SETADDRESS
        CR_SETCOMMUNICATIONS

 ============================================================}


{============================================================
                Change Log
                ====== ===
  Date     What change was made & Who made the change
---------  ----------------------------------------------------
28 Mar 81  Original code - Bob Peterson

16 May 81  LSI-11 Modifications - Mike Ikezawa
                        
        In the IMPLEMENTATION section:
        
        (1) Delete the following CONSTANTs entirely:
        
                POLY_KB
                POLY_REMOTE
                
        (2) In PROCEDURE CR_ANSWER delete:
        
                UNITCLEAR(POLY_REMOTE)
                
        (3) The single statement in FUNCTION CR_KBSTAT should read:
        
                CR_KBSTAT := NOT UNITBUSY(KB_UNIT)
                
        (4) The single statement in FUNCTION CR_REMSTAT should read:
        
                CR_REMSTAT := NOT UNITBUSY(REMIN_UNIT)
                
        (5) The UNITREAD statement in FUNCTION CR_GETKB should read:
        
                UNITREAD(KB_UNIT,ARAY.A,1,,1)
                
        (6) The UNITREAD statement in FUNCTION CR_GETREM should read:
        
                UNITREAD(REMIN_UNIT,ARAY.A,1,,1)
                
1 June 81  More LSI-11 Modifications by Walt Farrell

        (1) Following declaration of BAUD_SETTABLE:
        
                BUF_KB, BUF-REMIN : PACKED ARRAY[1..1] OF CHAR;
                
        (2) In Procedure CR_ANSWER following UNITCLEAR(REMOUT_UNIT); :
        
                UNITREAD( REMIN_UNIT, BUF_REMIN, 1,,1);
                
        (3) Replace Function CR_KBSTAT with:
        
                FUNCTION CR_KBSTAT( : BOOLEAN )
                VAR
                  STATUS_REC : ARRAY[1..30] OF INTEGER;
                BEGIN
                  UNITSTATUS( KB_UNIT, STATUS_REC, 1);
                  CR_KBSTAT := (STATUS_REC[1] > 0);
                END;
                
        (4) Replace Function CR_GETKB with:
        
                FUNCTION CR_GETKB ( : CHAR );
                BEGIN
                  UNITREAD( KB_UNIT, BUF_KB, 1,,5);
                  CR_GETKB := BUF_KB[1];
                END;
                
        (5) Replace Function CR_GETREM with:
        
                FUNCTION CR_GETREM ( : CHAR );
                BEGIN
                  CR_GETREM := BUF_REMIN[1];
                  UNITREAD( REMIN_UNIT, BUF_REMIN, 1,,1);
                END; 
                
        (6) In CR_COMMINIT just before MODEL_ID := ''; :
        
                UNITREAD( REMIN_UNIT, BUF_REMIN, 1,,1);
                
12 Aug 81  More LSI-11 Modifications by Mike Ikezawa

        CR_BREAK has been implemented.  It uses the external
        procedures SET_BREAK and CLR_BREAK.  In this version,
        SET_BREAK and CLR_BREAK are written for the LSI-11.
        This makes this version machine-dependent.  However,
        it is very possible that if SET_BREAK and CLR_BREAK
        are replaced by appropriate external functions that
        are written for other machines, this version may very
        well work on those machines also.

19 Jun 82  Changed CR_RATE_SET_OK in interface part to
             CR_SET_OK per std in NL#5   
             
           Changed CR_REMSTAT to use UNITSTATUS and commented out an initial
             UNITREAD in CR_COMMINIT.  This allowed this unit to work with
             Bob Peterson's TERM.MAIN.TEXT and still work with TOMUSUS.  
                                                George Schreyer
        

 ============================================================}


UNIT REMUNIT ;
INTERFACE

{$P+}

TYPE
  CR_DIALRESULT     = ( CR_OFF_HOOK, 
                        CR_DIALERROR,
                        CR_NOAUTODIAL ) ;
  CR_BAUD_RESULT    = ( CR_BAD_PARAMETER,
                        CR_BAD_RATE,
                        CR_SET_OK,
                        CR_SELECT_NOT_SUPPORTED ) ;
  CR_WHOAMI         = ( CR_ORIG,
                        CR_ANS ) ;
  CR_REM_PORT       =  PACKED RECORD
                        PART1   : INTEGER ;
                        PART2   : INTEGER ;
                        END ; { CR_REM_PORT }

VAR
  CR_ATTENCHAR          : CHAR ;
  CR_CURRENT_PORT       : CR_REM_PORT ;

{       Initialization and termination routines. }
PROCEDURE CR_COMMINIT(  DIR             : CR_WHOAMI ;
                        ATTENTION_CHAR  : CHAR ;
                    VAR REMOTE_EXISTS   : BOOLEAN ;
                    VAR DIALER_EXISTS   : BOOLEAN ) ;

PROCEDURE CR_COMMQUIT ;


{       Input status. }
FUNCTION  CR_KBSTAT                     : BOOLEAN ;
FUNCTION  CR_REMSTAT                    : BOOLEAN ;


{       Input/Output operations. }
FUNCTION  CR_GETKB                      : CHAR ;
FUNCTION  CR_GETREM                     : CHAR ;
PROCEDURE CR_PUTREM(                  C : CHAR ) ;


{       Control procedures. }
PROCEDURE CR_ANSWER ;
PROCEDURE CR_BREAK ;
FUNCTION  CR_CARRIER                    : BOOLEAN ;
FUNCTION  CR_CLEARTOSEND                : BOOLEAN ;
PROCEDURE CR_DELAY(     TENTHS          : INTEGER ) ;
PROCEDURE CR_DIAL(      NUMBER          : STRING ;
                        WAITCHAR        : CHAR
                    VAR RESULT          : CR_DIALRESULT ) ;
PROCEDURE CR_HOOK(      ON_HOOK         : BOOLEAN ) ;
PROCEDURE CR_SETADDRESS(HIGHADDR        : INTEGER ;
                        LOWADDR         : INTEGER ;
                        VECTOR          : INTEGER ) ;
PROCEDURE CR_SETCOMMUNICATIONS(
                        PARITY          : BOOLEAN ;
                        EVEN            : BOOLEAN ;
                        RATE            : INTEGER ;
                        CHARBITS        : INTEGER ;
                        STOPBITS        : INTEGER ;
                        DIR             : CR_WHOAMI ;
                        MODEL           : STRING ;
                    VAR RESULT          : CR_BAUD_RESULT ) ;

IMPLEMENTATION
{$P+}{ Page here so the option is not in the interface text. }
CONST
  DEFAULT_RATE          =  300 ;
  DEFAULT_MODE          = TRUE ; { Default to parity enabled. }
  DEFAULT_PARITY        = TRUE ; { Default to even parity.    }
  DEFAULT_CHARBITS      =    7 ; { Default to seven data bits.}
  DEFAULT_STOPBITS      =    2 ; { Default to two stop bits.  }
  KB_UNIT               =    2 ;
  REMIN_UNIT            =    7 ;
  REMOUT_UNIT           =    8 ;
  TIMER                 =  250 ;

TYPE
  TRICK                 = PACKED RECORD
                          CASE INTEGER OF
                          1:(A : PACKED ARRAY[0..80] OF CHAR);
                          2:(S : STRING[80]);
                          3:(I : INTEGER;
                             J : INTEGER);
                          4:(L : ARRAY[0..39] OF INTEGER);
                          5:(B : ARRAY[0..39] OF BOOLEAN);
                          6:(C : PACKED RECORD
                                 CHARL  : CHAR ;
                                 CHARR  : CHAR 
                                 END ) ;
                          END ; { TRICK }

VAR
  BAUD_SETTABLE         : BOOLEAN ;
  buf_kb, buf_remin     : packed array[1..1] of char;
  CONTROL               : INTEGER ;
  CURRENT_BAUD          : INTEGER ;
  MODEL_ID              : STRING ;
  OFF_HOOK              : BOOLEAN ;
{$P+}
{  ---------------------------------------------------------  }
{               Control Procedures                            }
{  ---------------------------------------------------------  }

procedure set_break; external;

procedure clr_break; external;

PROCEDURE CR_ANSWER ;
VAR
  WAITING               : BOOLEAN ;
BEGIN
  WAITING := TRUE ;
  WHILE WAITING DO
    BEGIN
    WAITING := NOT CR_CARRIER ;
    IF WAITING
      THEN
        IF CR_KBSTAT
          THEN
            WAITING := CR_GETKB <> CR_ATTENCHAR ;
    END ;
  OFF_HOOK := NOT WAITING ;
  IF NOT WAITING
    THEN
      BEGIN
      UNITCLEAR( REMIN_UNIT ) ;
      UNITCLEAR( REMOUT_UNIT ) ;
      unitread(remin_unit,buf_remin,1,,1);
      END ;
END ; { CR_ANSWER }

PROCEDURE CR_BREAK ;

var     i       :integer;

BEGIN
  cr_putrem(chr(0));
  cr_putrem(chr(0));
  set_break;
  for i := 1 to 100 do
    cr_putrem(chr(0));
  clr_break;
END ;

FUNCTION  CR_CARRIER{ : BOOLEAN } ;
BEGIN
  CR_CARRIER := TRUE ;
  OFF_HOOK   := TRUE ;
END ; { CR_CARRIER }

FUNCTION  CR_CLEARTOSEND{ : BOOLEAN } ;
BEGIN
  CR_CLEARTOSEND := TRUE ;
END ; { CR_CLEARTOSEND }

PROCEDURE CR_DELAY{ TENTHS : INTEGER } ;
VAR
  I             : INTEGER ;
BEGIN
  I := TIMER ;
  WHILE I > 0 DO
    I := I - 1 ;
END ; { CR_DELAY }

PROCEDURE CR_DIAL{ NUMBER       : STRING ;
               VAR RESULT       : CR_DIAL_RESULT } ;
BEGIN
  RESULT := CR_NOAUTODIAL ;
END ; { CR_DIAL }

PROCEDURE CR_HOOK{ ON_HOOK      : BOOLEAN } ;
BEGIN
  OFF_HOOK := NOT ON_HOOK ;
END ; { CR_HOOK }
{$P+}
{  ---------------------------------------------------------  }
{               Status Procedures                             }
{  ---------------------------------------------------------  }

FUNCTION  CR_KBSTAT{ : BOOLEAN } ;
var     status_rec      :array[1..30] of integer;
BEGIN
  unitstatus(kb_unit,status_rec,1);
  cr_kbstat := (status_rec[1] > 0);
END ; { CR_KBSTAT }

FUNCTION  CR_REMSTAT{ : BOOLEAN } ;
var status_rec : array[1..30] of integer;
BEGIN
  CR_REMSTAT := not UNITBUSY( remin_unit ) ;
  {unitstatus ( remin_unit, status_rec, 1 );} {this sometimes works and}
  {cr_remstat := ( status_rec[1] > 0 );}       {and sometimes doesn't   gws}
END ; { CR_REMSTAT }
{$P+}
{  ---------------------------------------------------------  }
{               Input/Output Procdures                        }
{  ---------------------------------------------------------  }

FUNCTION  CR_GETKB{ : CHAR } ;
BEGIN
  unitread(kb_unit,buf_kb,1,,5);
  cr_getkb := buf_kb[1];
END ; { CR_GETKB }

FUNCTION  CR_GETREM{ : CHAR } ;
BEGIN
  cr_getrem := buf_remin[1];
  unitread(remin_unit,buf_remin,1,,1);
END ; { CR_GETREM }

PROCEDURE CR_PUTREM{ C : CHAR } ;
VAR
  P                     : TRICK ;
BEGIN
  IF CR_CARRIER
    THEN
      BEGIN
      P.A[0] := C ;
      UNITWRITE( REMOUT_UNIT, P.A, 1, 0, CONTROL ) ;
      END ;
END ; { CR_PUTREM }
{$P+}
{  ---------------------------------------------------------  }
{               Initialization/Termination Procedures         }
{  ---------------------------------------------------------  }

PROCEDURE CR_SETADDRESS{        HIGHADDR        : INTEGER ;
                                LOWADDR         : INTEGER ;
                                VECTOR          : INTEGER } ;
BEGIN
  WITH CR_CURRENT_PORT DO
    BEGIN
    PART1 := HIGHADDR ;
    PART2 := LOWADDR ;
    END ;
END ; { CR_SETADDRESS }

PROCEDURE CR_SETCOMMUNICATIONS{
                        PARITY          : BOOLEAN ;
                        EVEN            : BOOLEAN ;
                        RATE            : INTEGER ;
                        CHARBITS        : INTEGER ;
                        STOPBITS        : INTEGER ;
                        DIR             : CR_WHOAMI ;
                        MODEL           : STRING ;
                    VAR RESULT          : CR_BAUD_RESULT } ;
BEGIN
  CONTROL       :=    12 ;
  BAUD_SETTABLE := FALSE ;
  RESULT        := CR_SELECT_NOT_SUPPORTED ;
END ; { CR_SETCOMMUNICATIONS }

PROCEDURE CR_COMMINIT{  DIR             : CR_WHOAMI ;
                        ATTENTION_CHAR  : CHAR ;
                    VAR REMOTE_EXISTS   : BOOLEAN ;
                    VAR DIALER_EXITST   : BOOLEAN } ;
VAR
  RESULT                : CR_BAUD_RESULT ;
PROCEDURE NOT_THERE ;
BEGIN
  PAGE( OUTPUT ) ;
  GOTOXY( 0, 10 ) ;
  WRITELN(' ':20, 'Required unit failed UNITCLEAR!') ;
  WRITELN(' ':20, 'Program will terminate.') ;
  EXIT( PROGRAM ) ;
END ;
BEGIN
  { Set no auto-dial. }
  DIALER_EXISTS := FALSE ;

  { Check that the required units exist. }
  REMOTE_EXISTS := TRUE ;
  UNITCLEAR( REMIN_UNIT ) ;
  IF IORESULT <> 0
    THEN
      NOT_THERE ;
  UNITCLEAR( REMOUT_UNIT ) ;
  IF IORESULT <> 0
    THEN
      NOT_THERE ;

  {unitread(remin_unit,buf_remin,1,,1);}              {primes the pump}
  MODEL_ID      := '' ;
  OFF_HOOK      := FALSE ;
  BAUD_SETTABLE :=  TRUE ;
  CR_ATTENCHAR  := ATTENTION_CHAR ;

  CR_SETCOMMUNICATIONS(
                        DEFAULT_MODE,
                        DEFAULT_PARITY,
                        DEFAULT_RATE,
                        DEFAULT_CHARBITS,
                        DEFAULT_STOPBITS,
                        CR_ORIG,
                        'LSI-11',
                        RESULT ) ;
  BAUD_SETTABLE := RESULT = CR_SELECT_NOT_SUPPORTED ;
END ; { CR_COMMINIT }


PROCEDURE CR_COMMQUIT ;
VAR
  RESULT                : CR_BAUD_RESULT ;
BEGIN
  OFF_HOOK := FALSE ;
  IF BAUD_SETTABLE
    THEN
      CR_SETCOMMUNICATIONS(
                        DEFAULT_MODE,
                        DEFAULT_PARITY,
                        DEFAULT_RATE,
                        DEFAULT_CHARBITS,
                        DEFAULT_STOPBITS,
                        CR_ORIG,
                        'LSI-11',
                        RESULT ) ;

END ; { CR_COMMQUIT }

END.







========================================================================================
DOCUMENT :usus Folder:VOL15:set_break.text
========================================================================================

.PROC   SET_BREAK
; To set break bit in CR_BREAK
; This external procedure is for use with the
; procedure CR_BREAK in REMUNIT for LSI-11s
; M. A. Ikezawa, 17 July 1981
XCSR    .EQU    177524
        BIS     #1,@#XCSR
        MOV     (SP)+,R0
        JMP     @R0
        .END


========================================================================================
DOCUMENT :usus Folder:VOL15:smtremv5.text
========================================================================================

          {Program SMARTREMOTE allows you to communicate with another
     computer or terminal via a modem and your telephone.  The program is
     capable of operation in either half or full duplex.  The program
     will also optionally record in a disk file or print all incoming
     information from the modem (although not from the console unless the
     remote computer echos the information) or transmit the contents of a
     disk file to the modem. The program works well and is freindly to use
     but ***BEWARE*** of machine dependency.  gws}
 
(* Program Author:   Walter Hess
                     1460 Seven Pines Rd.
                     Schaumberg, IL 60193*)

{Modified by George W. Schreyer 1-Feb-81.

                   - - - >   ** NOTE!!! **   < - - -
                   
                   This program is machine specific!
                   
          It will only run on a PDP-11 or LSI-11 or H-11.  It is also
     heavily terminal dependant on a Heath H-19 or DEC VT- 52.  The code
     makes extensive use of pointers to point at I/O status registers and
     buffers in the I/O page. The address have been adjusted to the same
     as used by the UCSD operating system for 'PRINTER:' and 'REMIN:' and
     'REMOUT:'.  There are also printer dependant commands for a TI-820.
     The funny negative numbers scattered about are two's complement
     repesentations of addresses (in the case of INITPOINTER) or bit
     patterns (as in the main program and elsewhere).  All this garbage
     could be replaced with blockreads and blockwrites (of regular reads
     and writes for that matter if you don't mind slow programs) for
     reading and writing files and unitreads to get data from the modem
     and keyboard. This would make the program portable, but it works on
     my computer the kludgey way it is and I don't feel like modifying it
     again.  This would be a good project for one of you super-sharp
     Pascal programmers out there in computerland.  gws}
                   
                                                        
(* SMTTERM
               
                    BEWARE!!!   This program has only been 
               finished (I think) during the last week.  It 
               requires a serial card at addresses 177570 thru
changed address,
  see below    177576 (octal). the VECTOR address is 270 but is 
               not used as PASCAL has no provision for servicing
               an interrupt from this card.  The resultant RS232 
               port is connected to a coupler for dial-up to the 
               remote computer.
               
                    The biggest problem I had was in writing to 
               a disc file from the remote computer due to the 
               fact that PASCAL stores data for a file in 
               temporary storage someplace and periodically 
               actually writes it to disc.  The period while it 
               is writing to disc is relatively long and since 
               the remote computer keeps sending data, some
               information would be lost.  I solved the problem
               by writing to an array, and when the array is
               nearly full, I send the remote computer an ESC
 changed to    "H" which is the command sequence which halts the
 cntl S        particular remote computer I use (see PROCEDURE
               WARRY).  After a short wait while the remote
               computer stops during which time arriving
               characters are accepted, I write the array to the
               disc file and then tell the remote computer to
 changed to    resume by sending an ESC which restarts the 
 cntl Q        remote computer (see PROCEDURE WFILE). The
               particular commands will, of course, be different
               for different computers.
               
                    Another tricky area was the use of "BREAK". 
               If you want to send a "BREAK" to the remote 
               computer, do not use the "BREAK" key as this will 
               locally interrupt PASCAL.  Instead, I simulate a 
               "BREAK" with the top row f5 which does the job 
               nicely.
               
                    The program uses certain of the ESC 
               functions created by the top row of keys as 
               program commands and passes all other ESC 
               sequences to the remote computer.  If the remote 
               computer needs one of the top row sequences, the 
               command structure will have to be modified.  It 
               seems that Heath uses sequences for the top row 
               which are not commonly used elsewhere.*)
               
PROGRAM SMTTERM;
{ VERSION "O"  10/20/79  W.I.H. }
{version '5' 27-AUG-81  George W. Schreyer}

USES (*$U iounit.code*) IOUNIT;

CONST
  ARLEN = 100;


VAR
  TCHAR : PACKED ARRAY[0..1] OF CHAR;
  i,ARINDEX,CFULL,PRINDEX,COLM,LNCT,LNPAGE,L : INTEGER;
  NFULL,HALT,LESC,FDUP,CMD,PRINTON,RCRDON,PLBKON,TERMINATE : BOOLEAN;
  FILENAME : STRING[30];
  PRARRY : PACKED ARRAY[1..ARLEN] OF STRING[132];
  SSTRING : STRING[1];
  PRFILE : TEXT;
  R : REAL;
  RCH,CH,ESCH : CHAR;


PROCEDURE WASTE;  {wait until printer ready}
VAR
  K : INTEGER;

BEGIN
  REPEAT
     BIT := PRINT_XCSR^;
  UNTIL BIT[7];
END; {Waste}

PROCEDURE COMM(CH : CHAR);  {check for modem ready then stuff ch in xbuf}

BEGIN
  REPEAT
     BIT := MODEM_XCSR^;
  UNTIL BIT[7];
  MODEM_XBUF^ := CH
END; {Comm}
 
PROCEDURE QUIT;
   BEGIN
      WRITE(ESCH,'k');
      WRITE(ESCH,'y1');
      WRITE(ESCH,'y5');
      bit := modem_rcsr^;
      bit[6] := true;  {re-enable interupts at modem rcsr}
      modem_rcsr^:= bit;
      CLOSE(PRFILE,LOCK);
   END;  {quit}

PROCEDURE CARRAY;  {empty buffer file}

VAR
  J : INTEGER;

BEGIN
  FOR J := 2 TO ARLEN DO
    PRARRY[J] := '';
END; {Carray}

PROCEDURE WARRY;  {see if necessary to stop host}
  
BEGIN
  IF ORD(CH) > 127
    THEN CH := CHR(ORD(CH) - 128);
  IF (CH = CHR(13))
    THEN
      BEGIN
        PRINDEX := 1;
        ARINDEX := ARINDEX + 1;
        IF ARINDEX = ARLEN - 3
          THEN
            BEGIN
              NFULL := TRUE;
              COMM(CHR(19));   {send cntl-s}
            END;
      END
    ELSE
      BEGIN
        IF CH <> CHR(127)
          THEN
            BEGIN
              SSTRING[1] := CH;
              INSERT(SSTRING,PRARRY[ARINDEX],PRINDEX);
              PRINDEX := PRINDEX + 1;
            END;
      END;
END; {Warry}

PROCEDURE DISPLAY;
  
  BEGIN
    WRITE(ESCH,'Y8 ',ESCH,'l',ESCH,'F^',ESCH,'G');
    IF CMD
      THEN WRITE(ESCH,'p');
    WRITE('BLUE Cmd',ESCH,'q',ESCH,'F^',ESCH,'G');
    IF PLBKON
      THEN WRITE(ESCH,'p');
    WRITE('RED Playback',ESCH,'q',ESCH,'F^',ESCH,'G');
    IF RCRDON
      THEN WRITE(ESCH,'p');
    WRITE('GREY Record',ESCH,'q',ESCH,'F^',ESCH,'G');
    IF NOT FDUP
      THEN WRITE(ESCH,'p');
    WRITE('f1 Half Duplex',ESCH,'q',ESCH,'F^',ESCH,'G');
    IF PRINTON
      THEN WRITE(ESCH,'p');
    WRITE('f2 Print',ESCH,'q',ESCH,'F^',ESCH,'G','f3 Quit',
          ESCH,'F^',ESCH,'Gf5 Break',ESCH,'F^',ESCH,'G');
  END; {Display}


PROCEDURE RCORD;
  
  VAR
    TRYAGAIN : BOOLEAN;

  BEGIN
    {$I-}
    REPEAT
      unitclear(1);
      WRITE('Enter File Name (.TEXT Assumed)');
      WRITE(' Or CR to Terminate  ');
      READLN(FILENAME);
      IF LENGTH(FILENAME) = 0
        THEN
          BEGIN
            RCRDON := FALSE;
            EXIT(RCORD);
          END;
      FILENAME := CONCAT(FILENAME,'.TEXT');
      RESET(PRFILE,FILENAME);
      IF IORESULT = 0
        THEN
          BEGIN
            CLOSE(PRFILE);
            WRITE(ESCH,'Y8 ',ESCH,'l','File exists, do you want to ');
            WRITE('replace it (Y or N)   ');
            REPEAT
              READ(CH);
            UNTIL (CH = 'Y') OR (CH = 'N') OR (CH = 'y') OR (CH = 'n');
            IF (CH = 'N') OR (CH = 'n')
              THEN TRYAGAIN := TRUE
              ELSE TRYAGAIN := FALSE;
          END
        ELSE TRYAGAIN := FALSE;
      IF NOT TRYAGAIN
        THEN REWRITE(PRFILE,FILENAME);
    UNTIL (IORESULT = 0) AND (NOT TRYAGAIN);
    {$I+}
    END; {Rcord}
    

PROCEDURE WFILE;  {write buffer array to disk}


VAR
  K,J : INTEGER;

BEGIN
  K := 1;
  IF LENGTH(PRARRY[1]) = 0
    THEN K := 2;
  FOR J := K TO ARINDEX - 1 DO
    begin
      (*$I-*)
      WRITELN(PRFILE,PRARRY[J]);
      (*$I+*)
      if ioresult <> 0 then 
         begin
            close(prfile,lock);
            write(chr(27),'Y8 ',chr(27),'l');
            write('file full  ');
            RCORD;
            WRITE(CHR(27),'Y8 ',CHR(27),'K','please wait ...');
            writeln(prfile,prarry[j]);
         end;
    end;
  IF PRINDEX > 1
    THEN
      PRARRY[1] := PRARRY[ARINDEX]
    ELSE
      PRARRY[1] := '';
  ARINDEX := 1;
  CARRAY;
  NFULL := FALSE;
END; {Wfile}

procedure dummy;
begin
  write(chr(27),'j');
  WRITE(CHR(27),'Y8 ',CHR(27),'K','please wait ...');
  wfile;
  display;
  write(chr(27),'k');
  COMM(CHR(17));   {send cntl-q}
end;

PROCEDURE PRINT (PRTCHR : CHAR);

BEGIN
  WASTE;PRINT_XBUF^ := PRTCHR;
END; {Print}


PROCEDURE COMMAND;

VAR
  GCHAR : BOOLEAN;
    
    PROCEDURE PLAYBACK;
  
    VAR
      J : INTEGER;
  
    BEGIN
      {$I-}
      REPEAT
        WRITE(ESCH,'Y8 ',ESCH,'l','Enter File Name (.TEXT Assumed)');
        WRITE(' Or CR to Terminate  ');
        READLN(FILENAME);
        IF LENGTH(FILENAME) = 0
          THEN
            BEGIN
              PLBKON := FALSE;
              EXIT(PLAYBACK);
            END;
        FILENAME := CONCAT(FILENAME,'.TEXT');
        RESET(PRFILE,FILENAME);
      UNTIL IORESULT = 0;
      {$I+}
      WRITE(ESCH,'k');
      WHILE NOT EOF(PRFILE) DO
        BEGIN
          READ(PRFILE,RCH);
          COMM(RCH);
          WRITE(RCH);
          IF EOLN(PRFILE)
            THEN
              BEGIN
                COMM(CHR(13));
                COMM(CHR(10));
                WRITE(CHR(13));
                READ(PRFILE,RCH);
              END;
        END; {While}
        PLBKON := FALSE;
        WRITE(ESCH,'j');
        CLOSE(PRFILE);
      END; {Playback}
    

BEGIN {Command}
  WRITE(ESCH,'x5',ESCH,'j');
  DISPLAY;
  IF CMD THEN
     BEGIN
        REPEAT
          GCHAR := FALSE;
          REPEAT
            READ(CH);
            IF CH = ESCH
              THEN
                BEGIN
                  GCHAR := TRUE;
                  READ(CH);
                END
              ELSE WRITE(CHR(7));
          UNTIL GCHAR AND (CH IN ['P'..'U']);
          CASE CH OF
            'P' : CMD := FALSE;
            'Q' : IF PLBKON
                  THEN PLBKON := FALSE
                  ELSE
                    BEGIN
                      PLBKON := TRUE;
                      DISPLAY;
                      PLAYBACK;
                    END;
            'R' : IF RCRDON
                    THEN
                      BEGIN
                        RCRDON := FALSE;
                        write(chr(27),'l');
                        WRITE(CHR(27),'Y8 ',chr(27),'K','please wait ...');
                        WFILE;
                        CLOSE(PRFILE,LOCK);
                      END
                    ELSE
                     BEGIN
                       RCRDON := TRUE;
                       PRINDEX := 1;
                       ARINDEX := 1;
                       CARRAY;
                       NFULL := FALSE;
                       PRARRY[1] := '';
                       write(chr(27),'Y8 ',chr(27),'l');
                       RCORD;
                       write(chr(27),'k');
                     END;
            'S' : IF FDUP = TRUE
                    THEN FDUP := FALSE
                    ELSE FDUP := TRUE;
            'T' : PRINTON := NOT PRINTON;
            'U' : TERMINATE := TRUE;
          END; {Case}
          DISPLAY;
        UNTIL (NOT CMD) OR TERMINATE;
     END;
  WRITE(ESCH,'y5',ESCH,'k');
END; {Command}

BEGIN { Smtterm }
  WRITE(CHR(27),CHR(69));
  WRITELN('smart remote version 5      3-Sep-81');
  set_up_pointers;
  BIT := MODEM_RCSR^;
  BIT[6] := FALSE;  {disable interupts}
  MODEM_RCSR^ := BIT;
  BIT := MODEM_XCSR^;
  BIT[6] := FALSE;
  MODEM_XCSR^ := BIT;
  ESCH := CHR(27);
  WRITE(ESCH,'x1');
  SSTRING := ' ';
  CFULL := 0;
  NFULL := FALSE;TERMINATE := FALSE; HALT := FALSE;
  FDUP := TRUE;CMD := FALSE;PRINTON := FALSE;RCRDON := FALSE;
  PLBKON := FALSE;
  COMMAND;
  WHILE NOT TERMINATE DO
     BEGIN
       UNITREAD(2,TCHAR[0],1,,1);
       WHILE UNITBUSY(2) DO
         BEGIN
           bit := modem_rcsr^;
           IF NFULL THEN CFULL := CFULL + 1;
           IF bit[7] THEN
               BEGIN
                 CFULL := 0;
                 CH := MODEM_RBUF^;
                 if ord(ch) > 127 then ch := chr(ord(ch)-128);
                 IF CH <> CHR(10)  THEN 
                    BEGIN
                      WRITE(CH);
                      IF PRINTON
                        THEN PRINT(CH);
                      IF RCRDON
                        THEN WARRY;
                    END;
               END;
           IF CFULL = 100  {wait until 100 loops without receipt of a char}
             THEN 
               BEGIN
                 DUMMY;
                 CFULL := 0;
               END;
         END; {While}
       IF LESC
         THEN
           BEGIN
             LESC := FALSE;
             IF TCHAR[0] = 'P'
               THEN 
                  BEGIN
                     CMD := TRUE;
                     COMMAND
                  END
               ELSE
                 BEGIN
                   IF TCHAR[0] = 'W'
                     THEN
                     BEGIN
                         for i := 0 to 15 do bit[i] := false;
                         bit[0] := true;
                         MODEM_XCSR^ := bit;  
                         {set break bit, bit 0, in modem xcsr}
                         FOR L := 1 TO 500 DO
                           R := 6.2*164.83*9.5/17.84;
                         bit[0] := false;
                         MODEM_XCSR^ := bit;  {reset break bit}
                       END
                     ELSE
                       BEGIN
                         COMM(ESCH);COMM(TCHAR[0]);
                         IF TCHAR[0] = 'H'
                           THEN HALT := TRUE;
                       END;
                 END;
           END
         ELSE
           IF (TCHAR[0] = ESCH) AND (NOT HALT)
             THEN LESC := TRUE
             ELSE
               BEGIN
                 COMM(TCHAR[0]);
                 IF TCHAR[0] = ESCH
                   THEN HALT := FALSE
                   ELSE IF NOT FDUP
                     THEN WRITE(TCHAR[0]);
               END;
     END;
  IF TERMINATE THEN QUIT;
END. {Smtterm}


========================================================================================
DOCUMENT :usus Folder:VOL15:std.unit.text
========================================================================================

UNIT REMUNIT ;{ This is REMUNIT for a Poly }   {xL PRINTER: }

INTERFACE

{============== Copyright Notice =======================}
        {$C Copyright 1980, 1981 by Robert W. Peterson }
{============== Copyright Notice =======================}


{============================================================
  This is a separate compilation unit intended to stand 
  between application code and a communication line.
  Implementation of this unit follows the specifications
  and suggestions set out in the Feburary 1981 draft of the
  USUS (UCSD p-System User Society) remote unit specification.
  
  This unit will interface to the following model codes:
        POLYMORPHIC

  The following routines are not functional:
        CR_BREAK
        CR_CLEARTOSEND
        CR_DIAL
        CR_DIALTONE
        CR_SETADDRESS
        CR_SETCOMMUNICATIONS
        CR_SETDTR
        CR_SETRTS
        
  The following routines contain calls to UnitClear:
        CR_ANSWER

 ============================================================}


{============================================================
                Change Log
                ====== ===
  Date     What change was made & Who made the change
---------  ----------------------------------------------------
16 Nov 81  Bring up to actually adopted standard - Bob Peterson
03 Aug 81  Convert to IV.0 - Bob Peterson
28 Mar 81  Original code - Bob Peterson


 ============================================================}
{$P+}

TYPE
  CR_DIALRESULT     = ( CR_OFF_HOOK, 
                        CR_DIALERROR,
                        CR_NOAUTODIAL ) ;
  CR_BAUD_RESULT    = ( CR_BAD_PARAMETER,
                        CR_BAD_RATE,
                        CR_SET_OK,
                        CR_SELECT_NOT_SUPPORTED ) ;
  CR_WHOAMI         = ( CR_ORIG,
                        CR_ANS ) ;
  CR_REM_PORT       =  PACKED RECORD
                        PART1   : INTEGER ;
                        PART2   : INTEGER ;
                        END ; { CR_REM_PORT }
  CR_STATE          = ( CR_ON,
                        CR_OFF,
                        CR_AUTO ) ;

VAR
  CR_ATTENCHAR          : CHAR ;
  CR_CURRENT_PORT       : CR_REM_PORT ;

{       Initialization and termination routines. }
PROCEDURE CR_COMMINIT(  DIR             : CR_WHOAMI ;
                        ATTENTION_CHAR  : CHAR ;
                    VAR REMOTE_EXISTS   : BOOLEAN ;
                    VAR DIALER_EXITST   : BOOLEAN ) ;

PROCEDURE CR_COMMQUIT ;


{       Input status. }
FUNCTION  CR_KBSTAT                     : BOOLEAN ;
FUNCTION  CR_REMSTAT                    : BOOLEAN ;


{       Input/Output operations. }
FUNCTION  CR_GETKB                      : CHAR ;
FUNCTION  CR_GETREM                     : CHAR ;
PROCEDURE CR_PUTREM(                  C : CHAR ) ;


{       Control procedures. }
PROCEDURE CR_ANSWER ;
PROCEDURE CR_BREAK ;
FUNCTION  CR_CARRIER                    : BOOLEAN ;
FUNCTION  CR_CLEARTOSEND                : BOOLEAN ;
PROCEDURE CR_DELAY(     TENTHS          : INTEGER ) ;
PROCEDURE CR_DIAL(      NUMBER          : STRING ;
                        WAITCHAR        : CHAR
                    VAR RESULT          : CR_DIALRESULT ) ;
FUNCTION  CR_DIALTONE                   : BOOLEAN ;
PROCEDURE CR_HOOK(      ON_HOOK         : BOOLEAN ) ;
FUNCTION  CR_RINGING                    : BOOLEAN ;
PROCEDURE CR_SETADDRESS(HIGHADDR        : INTEGER ;
                        LOWADDR         : INTEGER ;
                        VECTOR          : INTEGER ) ;
PROCEDURE CR_SETCOMMUNICATIONS(
                        PARITY          : BOOLEAN ;
                        EVEN            : BOOLEAN ;
                        RATE            : INTEGER ;
                        CHARBITS        : INTEGER ;
                        STOPBITS        : INTEGER ;
                        DIR             : CR_WHOAMI ;
                        MODEL           : STRING ;
                    VAR RESULT          : CR_BAUD_RESULT ) ;
PROCEDURE CR_SET_DTR(   NEW_STATE       : CR_STATE ) ;
PROCEDURE CR_SET_RTS(   NEW_STATE       : CR_STATE ) ;
                    

IMPLEMENTATION
{$P+}{ Page here so the option is not in the interface text. }
CONST
  DEFAULT_RATE          =  300 ;
  DEFAULT_MODE          = TRUE ; { Default to parity enabled. }
  DEFAULT_PARITY        = TRUE ; { Default to even parity.    }
  DEFAULT_CHARBITS      =    7 ; { Default to seven data bits.}
  DEFAULT_STOPBITS      =    1 ; { Default to one stop bits.  }
  HUNG_UP               = TRUE ;
  KB_UNIT               =    2 ;
  REMIN_UNIT            =    7 ;
  REMOUT_UNIT           =    8 ;
  TIMER                 =  250 ;

TYPE
  TRICK                 = PACKED RECORD
                          CASE INTEGER OF
                          1:(A : PACKED ARRAY[0..80] OF CHAR);
                          2:(S : STRING[80]);
                          3:(I : INTEGER;
                             J : INTEGER);
                          4:(L : ARRAY[0..39] OF INTEGER);
                          5:(B : ARRAY[0..39] OF BOOLEAN);
                          6:(C : PACKED RECORD
                                 CHARL  : CHAR ;
                                 CHARR  : CHAR 
                                 END ) ;
                          END ; { TRICK }

VAR
  BAUD_SETTABLE         : BOOLEAN ;
  CONTROL               : INTEGER ;
  CURRENT_BAUD          : INTEGER ;
  DTR_STATE             : CR_STATE ;
  MODEL_ID              : STRING ;
  OFF_HOOK              : BOOLEAN ;
  RTS_STATE             : CR_STATE ;
  UNIT_CARRIER          : BOOLEAN ;
{$P+}
{  ---------------------------------------------------------  }
{               Control Procedures                            }
{  ---------------------------------------------------------  }

PROCEDURE CR_ANSWER ;
VAR
  WAITING               : BOOLEAN ;
BEGIN
  WAITING := TRUE ;
  WHILE WAITING DO
    BEGIN
    WAITING := NOT CR_CARRIER ;
    IF WAITING
      THEN
        IF CR_KBSTAT
          THEN
            WAITING := CR_GETKB <> CR_ATTENCHAR ;
    END ;
  OFF_HOOK := NOT WAITING ;
  IF NOT WAITING
    THEN
      BEGIN
      UNITCLEAR( REMIN_UNIT ) ;
      UNITCLEAR( REMOUT_UNIT ) ;
      END ;
END ; { CR_ANSWER }

PROCEDURE CR_BREAK ;
BEGIN
END ;

FUNCTION  CR_CARRIER{ : BOOLEAN } ;
BEGIN
  CR_CARRIER := UNIT_CARRIER ;
  OFF_HOOK   := UNIT_CARRIER ;
END ; { CR_CARRIER }

FUNCTION  CR_CLEARTOSEND{ : BOOLEAN } ;
BEGIN
  CR_CLEARTOSEND := TRUE ;
END ; { CR_CLEARTOSEND }

PROCEDURE CR_DELAY{ TENTHS : INTEGER } ;
VAR
  I             : INTEGER ;
BEGIN
  I := TIMER ;
  WHILE I > 0 DO
    I := I - 1 ;
END ; { CR_DELAY }

PROCEDURE CR_DIAL{ NUMBER       : STRING ;
               VAR RESULT       : CR_DIAL_RESULT } ;
BEGIN
  RESULT := CR_NOAUTODIAL ;
END ; { CR_DIAL }

FUNCTION CR_DIALTONE ;
BEGIN
  CR_DIALTONE := TRUE ;
END ;

PROCEDURE CR_HOOK{ ON_HOOK      : BOOLEAN } ;
BEGIN
  OFF_HOOK := NOT ON_HOOK ;
  UNIT_CARRIER := OFF_HOOK ;
END ; { CR_HOOK }

FUNCTION CR_RINGING { : BOOLEAN } ;
BEGIN
  CR_RINGING := TRUE ;
END ;
{$P+}
{  ---------------------------------------------------------  }
{               Status Procedures                             }
{  ---------------------------------------------------------  }

FUNCTION  CR_KBSTAT{ : BOOLEAN } ;
VAR
  A     : TRICK ;
BEGIN
  UNITSTATUS( KB_UNIT, A, 1 ) ;
  CR_KBSTAT := A.I > 0 ;
END ; { CR_KBSTAT }

FUNCTION  CR_REMSTAT{ : BOOLEAN } ;
VAR
  A     : TRICK ;
BEGIN
  UNITSTATUS( REMIN_UNIT, A, 1 ) ;
  CR_REMSTAT := A.I > 0 ;
END ; { CR_REMSTAT }
{$P+}
{  ---------------------------------------------------------  }
{               Input/Output Procdures                        }
{  ---------------------------------------------------------  }

FUNCTION  CR_GETKB{ : CHAR } ;
VAR
  ARAY                  : TRICK ;
BEGIN
  UNITREAD( KB_UNIT, ARAY.A, 1,, 12 ) ;
  CR_GETKB := ARAY.A[0] ;
END ; { CR_GETKB }

FUNCTION  CR_GETREM{ : CHAR } ;
VAR
  ARAY                  : TRICK ;
BEGIN
  UNITREAD( REMIN_UNIT, ARAY.A, 1,, CONTROL ) ;
  CR_GETREM := ARAY.A[0] ;
END ; { CR_GETREM }

PROCEDURE CR_PUTREM{ C : CHAR } ;
VAR
  P                     : TRICK ;
BEGIN
  P.A[0] := C ;
  UNITWRITE( REMOUT_UNIT, P.A, 1, 0, CONTROL ) ;
END ; { CR_PUTREM }
{$P+}
{  ---------------------------------------------------------  }
{               Initialization/Termination Procedures         }
{  ---------------------------------------------------------  }

PROCEDURE CR_SETADDRESS{        HIGHADDR        : INTEGER ;
                                LOWADDR         : INTEGER ;
                                VECTOR          : INTEGER } ;
BEGIN
  WITH CR_CURRENT_PORT DO
    BEGIN
    PART1 := HIGHADDR ;
    PART2 := LOWADDR ;
    END ;
END ; { CR_SETADDRESS }

PROCEDURE CR_SETDTR ;
BEGIN
END ;

PROCEDURE CR_SETRTS ;
BEGIN
END ;

PROCEDURE CR_SETCOMMUNICATIONS{
                        PARITY          : BOOLEAN ;
                        EVEN            : BOOLEAN ;
                        RATE            : INTEGER ;
                        CHARBITS        : INTEGER ;
                        STOPBITS        : INTEGER ;
                        DIR             : CR_WHOAMI ;
                        MODEL           : STRING ;
                    VAR RESULT          : CR_BAUD_RESULT } ;
BEGIN
  CONTROL       :=    12 ;
  BAUD_SETTABLE := FALSE ;
  IF (MODEL = 'POLYMORPHIC') OR
     (MODEL = 'Polymorphic') OR
     (MODEL = 'POLY'       ) OR
     (MODEL = 'Poly'       )
    THEN
      RESULT        := CR_SET_OK
    ELSE
      RESULT        := CR_SELECT_NOT_SUPPORTED ;
END ; { CR_SETCOMMUNICATIONS }

PROCEDURE CR_COMMINIT{  DIR             : CR_WHOAMI ;
                        ATTENTION_CHAR  : CHAR ;
                    VAR REMOTE_EXISTS   : BOOLEAN ;
                    VAR DIALER_EXITST   : BOOLEAN } ;
VAR
  RESULT                : CR_BAUD_RESULT ;
PROCEDURE NOT_THERE ;
BEGIN
  PAGE( OUTPUT ) ;
  GOTOXY( 0, 10 ) ;
  WRITELN(' ':20, 'Required unit failed UNITCLEAR!') ;
  WRITELN(' ':20, 'Program will terminate.') ;
  EXIT( PROGRAM ) ;
END ;
BEGIN
  { Set no auto-dial. }
  DIALER_EXISTS := FALSE ;
  
  { Check that the required units exist. }
  REMOTE_EXISTS := TRUE ;
  UNITCLEAR( REMIN_UNIT ) ;
  IF IORESULT <> 0
    THEN
      NOT_THERE ;
  UNITCLEAR( REMOUT_UNIT ) ;
  IF IORESULT <> 0
    THEN
      NOT_THERE ;
  
  UNIT_CARRIER := FALSE ;
  CR_HOOK( HUNG_UP ) ;
  
  MODEL_ID      := '' ;
  DTR_STATE     := CR_AUTO ;
  RTS_STATE     := CR_AUTO ;
  OFF_HOOK      := FALSE ;
  BAUD_SETTABLE :=  TRUE ;
  CR_ATTENCHAR  := ATTENTION_CHAR ;

  CR_SETCOMMUNICATIONS(
                        DEFAULT_MODE,
                        DEFAULT_PARITY,
                        DEFAULT_RATE,
                        DEFAULT_CHARBITS,
                        DEFAULT_STOPBITS,
                        CR_ORIG,
                        'POLYMORPHIC',
                        RESULT ) ;
  BAUD_SETTABLE := RESULT = CR_SELECT_NOT_SUPPORTED ;
END ; { CR_COMMINIT }


PROCEDURE CR_COMMQUIT ;
VAR
  RESULT                : CR_BAUD_RESULT ;
BEGIN
  CR_HOOK( HUNG_UP ) ;
  IF BAUD_SETTABLE
    THEN
      CR_SETCOMMUNICATIONS(
                        DEFAULT_MODE,
                        DEFAULT_PARITY,
                        DEFAULT_RATE,
                        DEFAULT_CHARBITS,
                        DEFAULT_STOPBITS,
                        CR_ORIG,
                        'POLYMORPHIC',
                        RESULT ) ;

END ; { CR_COMMQUIT }
BEGIN
END.


========================================================================================
DOCUMENT :usus Folder:VOL15:teletalker.text
========================================================================================

{TeleTalker to Bob's Standard I/O Spec  10 Jul 82}
PROGRAM TeleTalker;
{$U *remunit.l3.code }
USES RemUnit;
CONST
        Title       = '   R a n d y '' s    U S U S    T e l e T a l k e r';

        Version     = '                   of 10 Jul 82';

        Copyright   = 'Copyright 1982, Volition Systems. All rights reserved.';

(* |xjm$ver|nx|f8|ef/of/wx|f8|ejb|.
        
          This may not be used for commercial gain without Volition's
                           explicit written consent.

UPDATE LOG:
10 Jul 82 Initialize DleCount!
09 Jul 82 Notes to implementors added, good luck!
22-Oct-81 cosmetics
07-Oct-81 Hacked to new WD.IO per Bob P's April Draft

Note to implementors / adaptors
        
        We ask that you leave the Title..Copyright banner.
        
        This code was a quick hack, it is in no way warantied.  It is meant
        to get you up, with something you can hack up yourself.

        You will want to look at:
            - DleDelay below in the CONSTant list.  It determines the delay
              between successive blanks output to Remote.
            - PROCEDURE CrtOutput is machine dependent to gain a bit of speed
              rather than going through the BIOS.
            - on my box, the IoCtrlPort is used to configure the BIOS.  Here it
              is used to disable all special char detection on kbd input.  This
              allows me to type in control sequences transparently.


CONST Contd.          *)
        DleDelay    = 66;   { MUST BE ADJUSTED FOR EACH MACHINE & BAUD RATE }
        IOCtrlPort  = 128;
        BlkSz       = 512;
        BlkSzM1     = 511;
        AttenChar   = 1;
        StopChar    = 19;
        StartChar   = 17;
        XWait       = 128;
        Dle         = 16;
        NoControl   = 12;
        NoCrlf      = 8;

TYPE
        Block       = PACKED ARRAY [0..BlkSzM1] OF CHAR;
        
VAR
        C           : CHAR;
        Ch          : PACKED ARRAY [0..0] OF CHAR;
        Sending     : BOOLEAN;
        Recording   : BOOLEAN;
        Frozen      : BOOLEAN;
        Chr0        : CHAR;
        I           : INTEGER;
        DleCount    : INTEGER;
        XWaitState  : (XWIdle, XWWaiting, XWReady);
        XWaitCnt    : INTEGER;
        TextCharSet : SET OF CHAR;
        RcvFile     : FILE;
        RcvFilPtr   : INTEGER;
        RcvBlk      : Block;
        RcvBufPtr   : INTEGER;
        RcvName     : STRING;
        XmtFile     : FILE;
        XmtFilPtr   : INTEGER;
        XmtBlk      : Block;
        XmtBufPtr   : INTEGER;
        XmtName     : STRING;

(*PROCEDURE CrtOutput (C: CHAR);
CONST
        SerialA                 = -1008;
TYPE
        SerStatType             = SET OF (
                TransBufEmpty   ,
                RecvrBufFull    ,
                OverrunError    ,
                ParityError     ,
                FramingError    ,
                CarrierDetect   ,
                DataSetReady    ,
                DataSetChange   );

        SerialPort              = RECORD
                Data            : INTEGER;
                Status          : SerStatType
                END {SerialPort};

        SerPunType              = RECORD CASE BOOLEAN OF
                TRUE  :( Int    : INTEGER);
                FALSE :( Port   : ^SerialPort)
                END {SerAdTrix};

VAR
        SerAPun                 : SerPunType;
BEGIN
        SerAPun.Int := SerialA;
        WITH SerAPun.Port^ DO BEGIN
            REPEAT  
                UNTIL TransBufEmpty IN Status;
            Data := ORD (C)
            END 
        END;
*)

procedure crtoutput ( c : char );
var ch : packed array [ 0..1 ] of char;
begin
   ch [ 0 ] := c;
   unitwrite ( 1, ch [ 0 ], 1,, 0 );
end;

PROCEDURE Init;
VAR
        Ok              : BOOLEAN;
        Rslt            : Cr_BaudResult;
        Dummy           : BOOLEAN;
        Ch              : PACKED ARRAY [0..0] OF CHAR;
BEGIN
        PAGE (OUTPUT);
        WRITELN;
        WRITELN (Title);
        WRITELN;
        WRITELN (Version);
        WRITELN;
        WRITELN (Copyright);
        WRITELN;
        CrCommInit ( Cr_Orig, CHR(1), Ok, Dummy );
        Cr_SetCommunications ( FALSE,       {Parity}
                               FALSE,       {Even}
                               1200,        {Baud}
                               8,           {BitsPerChar}
                               1,           {StopBits}
                               Cr_Orig,     {Direction}
                               'VA3451',    {Modem}
                               Rslt         {Result} );
        { UNITREAD (IOCtrlPort, Ch, 0, 0, 2);}
        Cr_Hook (FALSE );
        XmtName     := '';
        RcvName     := '';
        Sending     := FALSE;
        Recording   := FALSE;
        Frozen      := FALSE;
        DleCount    := 0;
        TextCharSet := [CHR(13), ' '..'~'];
        Chr0        := CHR(0)
        END;
        
PROCEDURE BlkWrite;
VAR
        HoldInx     : INTEGER;
        HoldBuf     : PACKED ARRAY [1..BlkSz] OF CHAR;
        SpareBlk    : Block;
        I           : INTEGER;
BEGIN
        HoldInx := 0;
        REPEAT
            IF Cr_RemStat THEN BEGIN
                C := CHR( ORD( ODD(ORD(Cr_GetRem)) AND ODD(127) ) );
                CrtOutput (C);
                IF ORD(C) = StopChar
                    THEN Frozen := TRUE
                    ELSE IF ORD(C) = StartChar
                        THEN Frozen := FALSE
                        ELSE IF (C IN TextCharSet) AND (HoldInx < BlkSz)
                             THEN BEGIN
                                 HoldInx := HoldInx + 1;
                                 HoldBuf[HoldInx] := C
                                 END
                END;
            I := 0;
            WHILE (NOT Cr_RemStat) AND (I < 256) DO
                I := I + 1;
            UNTIL NOT Cr_RemStat;
  {$I-} RcvBufPtr := BLOCKWRITE (RcvFile, RcvBlk, 1, RcvFilPtr);
        WHILE RcvBufPtr = 1 DO
            IF (BLOCKREAD (RcvFile, SpareBlk, 1, RcvFilPtr) = 1)
                                   AND (SpareBlk = RcvBlk)
                THEN RcvBufPtr := 0
                ELSE RcvBufPtr := BLOCKWRITE (RcvFile,RcvBlk,1,RcvFilPtr);
  {$I+} RcvFilPtr := RcvFilPtr + 1;
        FOR I := 1 TO HoldInx DO BEGIN
            RcvBlk[RcvBufPtr] := HoldBuf[I];
            RcvBufPtr := RcvBufPtr + 1
            END;
        Cr_PutRem (CHR(StartChar))
        END;

PROCEDURE RawOptions;
VAR
        Ch                  : PACKED ARRAY [0..0] OF CHAR;
    
    PROCEDURE UpCase ( VAR Str : STRING );
    VAR     I       : INTEGER;
    BEGIN
            FOR I := 1 TO LENGTH (Str) DO
                IF Str[I] IN ['a'..'z']
                    THEN Str[I] := CHR( ORD(Str[I]) - ORD('a') + ORD('A') )
            END;
    PROCEDURE RClose;
    BEGIN
            RcvBlk[RcvBufPtr] := CHR(13);
            WHILE RcvBufPtr < (BlkSzM1) DO BEGIN
                RcvBufPtr := RcvBufPtr + 1;
                RcvBlk[RcvBufPtr] := Chr0
                END;
            Cr_PutRem (CHR(StopChar));
            BlkWrite;
            IF ODD(RcvFilPtr) THEN BEGIN
                FILLCHAR (RcvBlk[0], BlkSz, Chr0);
                Cr_PutRem (CHR(StopChar));
                BlkWrite
                END;
            CLOSE (RcvFile, CRUNCH)
            END;

BEGIN {RawOptions}
        REPEAT
            REPEAT
                WRITELN;
                WRITE ('FileOptions: S(end, R(ecord, G(o, E(xit - ');
                C := Cr_GetKb;
                IF C = CHR(13)
                    THEN C := 'G'
                UNTIL C IN ['s','S','r','R','g','G','e','E'];
            WRITELN (C);
            CASE C OF
              's','S': IF Sending
                  THEN BEGIN
                      WRITE ('Now Sending ', XmtName, ' Close it ? ');
                      C := Cr_GetKb;
                      IF C IN ['y','Y'] THEN BEGIN
                          CLOSE (XmtFile, NORMAL);
                          Sending := FALSE;
                          WRITELN ('Closed')
                          END
                      END
                  ELSE BEGIN
                      REPEAT
                          WRITE ('Send what textfile ? ');
                          READLN (XmtName);
                          UpCase (XmtName);
                          IF LENGTH (XmtName) > 0 THEN
                              IF XmtName[LENGTH(XmtName)] = '.'
                                  THEN DELETE (XmtName, LENGTH(XmtName), 1)
                                  ELSE XmtName := CONCAT (XmtName, '.TEXT');
                    {$I-} RESET (XmtFile, XmtName); {$I+}
                          IF IORESULT = 0 THEN BEGIN
                              Sending := TRUE;
                              XWaitState  := XWIdle;
                              DleCount    := 0;
                              WRITELN (XmtName, ' Opened')
                              END
                           UNTIL (LENGTH(XmtName) = 0) OR (IORESULT = 0);
                      IF COPY (XmtName, LENGTH(XmtName)-4, 5) = '.TEXT'
                          THEN BEGIN
                              IF BLOCKREAD (XmtFile, XmtBlk, 1) = 0 THEN;
                              IF BLOCKREAD (XmtFile, XmtBlk, 1) = 0 THEN
                              END;
                      XmtBufPtr := BlkSz
                      END;
              'R','r': IF Recording
                  THEN BEGIN
                      WRITE ('Now Recording ', RcvName,
                               ' C(lose, P(urge  ? ');
                      C := Cr_GetKb;
                      CASE C OF
                        'c','C': BEGIN
                            RClose;
                            Recording := FALSE;
                            WRITELN ('Closed')
                            END;
                        'p','P': BEGIN
                            CLOSE (RcvFile, PURGE);
                            Recording := FALSE;
                            WRITELN ('Purged')
                            END
                        END
                      END
                  ELSE BEGIN
                      REPEAT
                          WRITE ('Record as what textfile ? ');
                          READLN (RcvName);
                          UpCase (RcvName);
                          IF LENGTH (RcvName) > 0 THEN
                              IF RcvName[LENGTH(RcvName)] = '.'
                                  THEN DELETE (RcvName, LENGTH(RcvName), 1)
                                  ELSE RcvName := CONCAT (RcvName, '.TEXT');
                {$I-}     RESET (RcvFile, RcvName);                    {$I+}
                          IF IORESULT = 0 THEN BEGIN
                              WRITE (RcvName, ' Exists, P(urge ? ');
                              C := Cr_GetKb;
                              IF C IN ['y', 'Y', 'p', 'P']
                                  THEN BEGIN
                                      CLOSE (RcvFile, PURGE);
                                      WRITELN ('Purged')
                                      END
                                  ELSE BEGIN
                                      CLOSE (RcvFile, LOCK);
                                      RcvName := '';
                                      WRITELN ('Saved')
                                      END
                              END;
                          IF LENGTH(RcvName) > 0 THEN BEGIN
                 {$I-}        REWRITE (RcvFile, RcvName);                  {$I+}
                              IF IORESULT = 0 THEN BEGIN
                                  Recording := TRUE;
                                  WRITELN (RcvName, ' Opened')
                                  END
                              END
                          UNTIL (LENGTH(RcvName) = 0) OR (IORESULT = 0);
                      IF COPY (RcvName, LENGTH(RcvName)-4, 5) = '.TEXT'
                          THEN BEGIN
                              FILLCHAR (RcvBlk[0], BlkSz, Chr0);
                              IF BLOCKWRITE (RcvFile, RcvBlk, 1) = 1 THEN ;
                              IF BLOCKWRITE (RcvFile, RcvBlk, 1) = 1 THEN ;
                              RcvFilPtr := 2
                              END
                          ELSE BEGIN
                              RcvFilPtr := 0
                              END;
                      RcvBufPtr := 0
                      END;
              'E','e': BEGIN
                  IF Recording THEN BEGIN
                      RClose;
                      Recording := FALSE
                      END;
                  Cr_CommQuit;
                  IF Sending THEN
                      CLOSE (XmtFile, NORMAL);
                  EXIT (TeleTalker)
                  END
              END
            UNTIL C IN ['g','G'];
            C := Chr0
        END;

PROCEDURE NoCts;
CONST
        Msg         = 'LOST CARRIER';
VAR
        I           : INTEGER;
BEGIN
        WRITELN (CHR(7));
        IF NOT Cr_KbStat
            THEN WRITE (Msg);
        REPEAT
            UNTIL Cr_ClearToSend OR Cr_KbStat;
        IF NOT Cr_KbStat
            THEN FOR I := 1 TO LENGTH(Msg) DO
                WRITE (CHR(8), ' ', CHR(8))
            ELSE BEGIN
                C := Cr_GetKb;
                RawOptions
                END
        END;
        
BEGIN {TeleTalker}
        Init;
{$R-}   REPEAT
            IF NOT Cr_ClearToSend
                THEN NoCts;
            IF Cr_RemStat
                THEN BEGIN
                    C := CHR(ORD( ODD(127) AND ODD(ORD(Cr_GetRem)) ));
                    CrtOutput (C);
                    IF ORD(C) = StopChar
                        THEN Frozen := TRUE
                        ELSE IF ORD(C) = StartChar
                            THEN Frozen := FALSE
                            ELSE IF Recording AND (C IN TextCharSet) THEN BEGIN
                                RcvBlk[RcvBufPtr] := C;
                                IF RcvBufPtr < BlkSzM1
                                    THEN RcvBufPtr := RcvBufPtr + 1
                                    ELSE BEGIN
                                        Cr_PutRem (CHR(StopChar));
                                        BlkWrite {slow machines bring inline}
                                        END
                                END
                    END
                ELSE IF NOT Frozen THEN BEGIN
                    C := Chr0;
                    IF Cr_KbStat
                        THEN BEGIN
                            C := Cr_GetKb;
                            IF (ORD(C) = AttenChar) OR Sending
                                THEN RawOptions
                            END
                        ELSE IF DleCount > 0
                            THEN BEGIN
                                IF (DleCount MOD 2) = 0
                                    THEN C := ' ';
                                DleCount := DleCount - 1
                                END
                            ELSE IF Sending AND (NOT Cr_RemStat) THEN
                                IF XmtBufPtr >= BlkSz
                                    THEN CASE XWaitState OF
                                        XWIdle: BEGIN
                                            XWaitState := XWWaiting;
                                            XWaitCnt := XWait
                                            END;
                                        XWWaiting: IF XWaitCnt < 0
                                            THEN XWaitState := XWReady
                                            ELSE XWaitCnt := XWaitCnt - 1;
                                        XWReady: BEGIN
                            {$I-}           IF BLOCKREAD (XmtFile, XmtBlk, 1)
                                               = 1                         {$I+}
                                                THEN XmtBufPtr := 0
                                                ELSE BEGIN
                                                    CLOSE (XmtFile, NORMAL);
                                                    WRITELN (XmtName, 
                                                       ' Finished');
                                                    Sending := FALSE
                                                    END;
                                            XWaitState := XWIdle
                                            END
                                        END
                                    ELSE BEGIN
                                        C         := XmtBlk[XmtBufPtr];
                                        XmtBufPtr := XmtBufPtr + 1;
                                        IF DleCount < 0
                                            THEN BEGIN
                                                DleCount := (ORD(C) - 32) * 2;
                                                IF DleCount < 0
                                                    THEN DleCount := 0;
                                                C := Chr0
                                                END
                                            ELSE IF ORD(C) = Dle
                                                THEN DleCount := -1
                                                ELSE FOR I := 0 TO DleDelay DO;
                                        IF NOT (C IN TextCharSet)
                                            THEN C := Chr0
                                        END;
                    IF C <> Chr0
                        THEN Cr_PutRem (C)
                    END
            UNTIL FALSE
        END.


========================================================================================
DOCUMENT :usus Folder:VOL15:term.emul.text
========================================================================================

{$P+}
{******************************************************************************

      Because of their time-sensitive nature, routines after this message 
                            SHOULD NOT BE SEGMENTED.

******************************************************************************}



PROCEDURE LOGIT{ C : CHAR } ;
{$N+}
BEGIN
  IF ORD( C ) IN [BACKSPACE, RUBOUT]
    THEN
      IF LOGINDEX > 1
        THEN
          { Subtract 2 here because we add one back later. }
          LOGINDEX := LOGINDEX - 2
        ELSE
          { NULL STATEMENT }
    ELSE
      LOGARRAY[ LOGINDEX ] := C ;
  IF LOGINDEX = NEARLY
    THEN
      BEGIN
      WRITELN ;
      WRITELN( ' ***> CURRENTLY AT 80% OF LOG SPACE <***' ) ;
      WRITELN ;
      END ;
  IF LOGINDEX >= LOGLIMIT 
    THEN
      BEGIN
      WRITELN ;
      WRITELN( ' >* LOGLIMIT EXCEEDED *< ', CHR(7), CHR(7) ) ;
      WRITELN ;
      { We turn logging off in order to preserve the current
        logged data, since it is usually easier to remember
        where we overflowed and restart from there than to
        restart the entire transaction stream.  }
      LOGTEXT := FALSE ;
      END
    ELSE
      LOGINDEX := LOGINDEX + 1 ;
END ;
{$N-}

{$P+}
PROCEDURE DISPLAY{ C : CHAR } ;
VAR
  ORD_C         : INTEGER ;
  P_A           : PACKED ARRAY[0..1] OF CHAR ;

PROCEDURE V_GOTOXY ;
{ This routine processes a Videotext GOTOXY sequence. }
VAR
  C     : CHAR ;
  X     : INTEGER ;
  Y     : INTEGER ;
BEGIN
  REPEAT
  UNTIL CR_REMSTAT OR CR_KBSTAT ;
  IF CR_KBSTAT
    THEN
      BEGIN
      C := CR_GETKB ;
      EXIT( DISPLAY ) ;
      END ;
  C := CR_GETREM ;
  Y := ORD( C ) - 31 ;
  
  REPEAT
  UNTIL CR_REMSTAT OR CR_KBSTAT ;
  IF CR_KBSTAT
    THEN
      BEGIN
      C := CR_GETKB ;
      EXIT( DISPLAY ) ;
      END ;
  C := CR_GETREM ;
  X := ORD( C ) - 31 ;

  GOTOXY( X, Y ) ;

END ; { V_GOTOXY }

{$N+}
BEGIN

  IF VIDEOTEXT AND (C = CHR( ESCAPE ))
    THEN
      BEGIN
      REPEAT
      UNTIL CR_REMSTAT OR CR_KBSTAT ;
      IF CR_KBSTAT
        THEN
          BEGIN
          C := CR_GETKB ;
          EXIT( DISPLAY ) ;
          END ;
      C := CR_GETREM ;
      ORD_C := 0 ;
      CASE C OF 
        'm',
        'l'      : ; { Wide character/Normal character }
        'A'      : ORD_C := ARROW_UP ; { Up arrow }
        'B'      : ORD_C := ARROW_DOWN ; { Down arrow }
        'C'      : ORD_C := ARROW_RIGHT ; { Right arrow }
        'D'      : ORD_C := ARROW_LEFT ; { Left arrow }
        'H'      : ORD_C := HOME_CURSOR ; { Home }
        'K'      : ORD_C := CLEAR_EOLN ; { Clear to end of line }
        'J'      : ORD_C := CLEAR_EOS ; { Clear to end of screen }
        'j'      : ORD_C := CLEAR_SCREEN ; { Clear screen }
        'Y'      : V_GOTOXY ; { VIDEOTEXT's GOTOXY }
        END ; { CASE ORD_C OF }
        IF ORD_C <> 0
          THEN
            BEGIN
            P_A[0] := CHR( ORD_C );
            UNITWRITE( 1, P_A, 1 ) ;
            END ;
      END
    ELSE
      BEGIN
      IF C > CHR( RUBOUT )
        THEN
          C := CHR( ORD_C - (RUBOUT + 1) ) ;
      IF C <> CHR( LINEFEED )
        THEN
          IF FILTERCONTROL
            THEN
              BEGIN
              IF NOT (C IN FILTERSET)
                THEN
                  BEGIN
                  P_A[0] := C ;
                  UNITWRITE( 1, P_A, 1 ) ;
                  END ;
              END
            ELSE
              BEGIN
              P_A[0] := C ;
              UNITWRITE( 1, P_A, 1 ) ;
              END ;
      IF LOGTEXT
        THEN
          IF NOT (C IN FILTERSET)
            THEN
              LOGIT( C ) ;
      END ;
END ;
{$N-}

{$P+}
{$N+}
PROCEDURE EMULATE ;
{ This procedure exists solely so that native code can be
  generated without generating native code for the rest
  of the mainline.                                      }
BEGIN
  DONE := FALSE ;
  REPEAT
    IF CR_KBSTAT
      THEN
        BEGIN
        C := CR_GETKB ;
        IF C = CR_ATTENCHAR
          THEN
            BEGIN
            MENU ;
            IF NOT (CR_CARRIER OR DONE)
              THEN
                CR_HOOK( FALSE ) ;
            END
          ELSE
            BEGIN
            CR_PUTREM( C ) ;
            IF ECHO
              THEN
                DISPLAY( C ) ;
            END ;
        END ;
    IF NOT CR_CARRIER
      THEN
        BEGIN
        WRITELN ;
        WRITELN('LOST CARRIER');
        WRITELN ;
        MENU ;
        IF NOT (CR_CARRIER OR DONE)
          THEN
            CR_HOOK( FALSE ) ;
        END
      ELSE
        IF CR_REMSTAT
          THEN
            DISPLAY( CR_GETREM ) ;
  UNTIL DONE ;
END ; { EMULATE }
{$N-}


========================================================================================
DOCUMENT :usus Folder:VOL15:term.init.text
========================================================================================

{$P+}
SEGMENT PROCEDURE INITIALIZE ;
VAR
  AUTOLOGON    : BOOLEAN ;
  B            : BOOLEAN ;
  C            : CHAR ;
  HAVEDIAL     : BOOLEAN ;
  HAVEREM      : BOOLEAN ;
  RESULT       : CR_BAUD_RESULT ;

SEGMENT PROCEDURE SETLOGON ;
CONST
{ Nine (9) is the max allowed, due to the way its coded. }
   DEFINED_LOGONS        = 5 ;
VAR
  C             : CHAR ;
  INDEX         : 1 .. DEFINED_LOGONS ;
  RESULT        : INTEGER ;
  VALID_LOGONS  : INTEGER ;
  
  LOGON_LIST    : PACKED ARRAY [1..DEFINED_LOGONS] OF RECORD
    SERVICE     : STRING[29] ;
    USER_ID     : STRING[21] ;
    PASSWORD    : STRING[21] ;
    PROMPT      : CHAR ;
    PHONE_NUM   : STRING[21] ;
    SWITCHES    : PACKED RECORD
      FILTERCONTROL     : BOOLEAN ;
      LOGTEXT           : BOOLEAN ;
      ECHO              : BOOLEAN ;
      VIDEOTEXT         : BOOLEAN ;
      END ; { SWITCHES }
    END ;

PROCEDURE SETUP_LIST ;
TYPE
  STRING7       = STRING[7] ;
VAR
  LINE          : STRING ;
  TRUE_SET      : SET OF CHAR ;
  
  IN_FILE       : TEXT ;

PROCEDURE CHECKIT ;
BEGIN
  RESULT := IORESULT ;
  IF RESULT <> 0
    THEN
      EXIT( SETUP_LIST ) ;
  IF EOF( IN_FILE )
    THEN
      EXIT( SETUP_LIST ) ;
  {  WRITELN( LINE ) ;  }{ Debugging only }
END ;

FUNCTION TRY_FILE( PREFIX : STRING7 ) : BOOLEAN ;
BEGIN
{$I-}
  RESET( IN_FILE, CONCAT( PREFIX, LOGON_FILENAME ) ) ;
  TRY_FILE := IORESULT = 0 ;
{$I+}
END ; { TRY_FILE }


BEGIN
{$I-}
  VALID_LOGONS := 0 ;
  IF NOT TRY_FILE( '' )         { Prefix first }
    THEN IF NOT TRY_FILE( '*' ) {  then root }
    THEN IF NOT TRY_FILE( '#4') {  then the world . . . }
    THEN IF NOT TRY_FILE( '#5')
    THEN IF NOT TRY_FILE( '#9')
    THEN IF NOT TRY_FILE( '#10')
    THEN IF NOT TRY_FILE( '#11')
    THEN IF NOT TRY_FILE( '#12')
    THEN IF NOT TRY_FILE( '#13')
    THEN IF NOT TRY_FILE( '#14')
    THEN IF NOT TRY_FILE( '#15')
    THEN IF NOT TRY_FILE( '#16')
    THEN IF NOT TRY_FILE( '#17')
    THEN
      BEGIN
      WRITELN ;
      WRITELN( 'Cannot find ', LOGON_FILENAME,
               ' on any drive.  Predefined logon aborted.' ) ;
      EXIT( SETUP_LIST ) ;
      END ;
  TRUE_SET := ['t', 'T', 'y', 'Y'] ;
  WHILE (NOT EOF( IN_FILE )) AND (VALID_LOGONS < DEFINED_LOGONS) DO
    WITH LOGON_LIST[ VALID_LOGONS + 1 ] DO
      BEGIN
      REPEAT                    { Skip blank lines. }
        READLN( IN_FILE, LINE ) ;
        CHECKIT ;
      UNTIL LENGTH( LINE ) > 0 ;
      { This IF will guarantee we don't get a string overflow. }
      IF SIZEOF( SERVICE ) - 1 >= LENGTH( LINE )
        THEN
          SERVICE := LINE
        ELSE
          SERVICE := COPY( LINE, 1, SIZEOF( SERVICE ) - 1 ) ;
      READLN( IN_FILE, LINE ) ;
      CHECKIT ;
      IF SIZEOF( USER_ID ) - 1 >= LENGTH( LINE )
        THEN
          USER_ID := LINE
        ELSE
          USER_ID := COPY( LINE, 1, SIZEOF( USER_ID ) - 1 ) ;
      READLN( IN_FILE, LINE ) ;
      CHECKIT ;
      IF SIZEOF( PASSWORD ) - 1 >= LENGTH( LINE )
        THEN
          PASSWORD := LINE
        ELSE
          PASSWORD := COPY( LINE, 1, SIZEOF( PASSWORD ) - 1 ) ;
      READLN( IN_FILE, LINE ) ;
      CHECKIT ;
      IF LENGTH( LINE ) > 0
        THEN
          PROMPT := LINE[1]
        ELSE
          PROMPT := '?' ;
      READLN( IN_FILE, LINE ) ;
      CHECKIT ;
      IF SIZEOF( PHONE_NUM ) - 1 >= LENGTH( LINE )
        THEN
          PHONE_NUM := LINE
        ELSE
          PHONE_NUM := COPY( LINE, 1, SIZEOF( PHONE_NUM ) - 1 ) ;
      WITH SWITCHES DO
        BEGIN
        READLN( IN_FILE, LINE ) ;
        CHECKIT ;
        IF LENGTH( LINE ) > 0
          THEN
            FILTERCONTROL := LINE[1] IN TRUE_SET 
          ELSE
            FILTERCONTROL := FALSE ;
        READLN( IN_FILE, LINE ) ;
        CHECKIT ;
        IF LENGTH( LINE ) > 0
          THEN
            LOGTEXT := LINE[1] IN TRUE_SET 
          ELSE
            LOGTEXT := FALSE ;
        READLN( IN_FILE, LINE ) ;
        CHECKIT ;
        IF LENGTH( LINE ) > 0
          THEN
            ECHO := LINE[1] IN TRUE_SET 
          ELSE
            ECHO := FALSE ;
        READLN( IN_FILE, LINE ) ;
        CHECKIT ;
        IF LENGTH( LINE ) > 0
          THEN
            VIDEOTEXT := LINE[1] IN TRUE_SET 
          ELSE
            VIDEOTEXT := FALSE ;
        END ; { WITH SWITCHES }
      VALID_LOGONS := VALID_LOGONS + 1 ;
      END ; { WITH LOGON_LIST }
  CLOSE( IN_FILE, LOCK ) ;
{$I-}
END ;

BEGIN
  LOGON_DEFINED := FALSE ;
  LOGON1        := '' ;
  LOGON2        := LOGON1 ;
  LOGPROMPT     := ' ' ;
  NUMBER        := LOGON1 ;
  TIMESHARE_SERVICE := LOGON1 ;
  IF QUESTION( 'Auto-Logon ' )
    THEN
      BEGIN
      IF QUESTION( 'Predefined ' )
        THEN
          BEGIN
          WRITELN ;
          WRITELN( 'One moment please . . .' ) ;
          SETUP_LIST ;
          IF VALID_LOGONS > 0
            THEN
              BEGIN
              CLEAR_THE_SCREEN ;
              WRITELN( 'Predefined logons are' ) ;
              FOR INDEX := 1 TO VALID_LOGONS DO
                WITH LOGON_LIST[INDEX] DO
                  WRITELN( INDEX:2,
                           ' ', 
                           SERVICE, 
                           ' [', USER_ID, ']',
                           ' Phone ', PHONE_NUM ) ;
              WRITELN ;
              WRITE( 'Select a digit (Q to select none):' ) ;
              REPEAT
                READ( KEYBOARD, C ) ;
              UNTIL ((ORD( C ) - ORD( '0' )) IN [1..VALID_LOGONS])
                 OR (C IN ['Q', 'q']) ;
              WRITE( C ) ;
              IF C IN ['Q', 'q']
                THEN
                  LOGON_DEFINED := FALSE
                ELSE
                  WITH LOGON_LIST[ORD(C)-ORD('0')] DO
                    BEGIN
                    LOGON_DEFINED     := TRUE ;
                    LOGON1            := USER_ID ;
                    LOGON2            := PASSWORD ;
                    LOGPROMPT         := PROMPT ;
                    NUMBER            := PHONE_NUM ;
                    TIMESHARE_SERVICE := SERVICE ;
                    FILTERCONTROL     := SWITCHES.FILTERCONTROL ;
                    LOGTEXT           := SWITCHES.LOGTEXT ;
                    ECHO              := SWITCHES.ECHO ;
                    VIDEOTEXT         := SWITCHES.VIDEOTEXT ;
                    END ;
              END ;
          END ;
      IF NOT LOGON_DEFINED
        THEN
          IF QUESTION( 'Specify logon manually' )
            THEN
              BEGIN
              TIMESHARE_SERVICE := 'Manually specified' ;
              WRITELN ;
              REPEAT
                WRITE('What is the first line?' ) ;
                READLN( LOGON1 ) ;
              UNTIL QUESTION( 'OK ' ) ;
              WRITELN ;
              REPEAT
                WRITE('What is the last line?' ) ;
                READLN( LOGON2 ) ;
              UNTIL QUESTION( 'OK ' ) ;
              WRITELN ;
              REPEAT
                WRITE(
                      'What is the last character of the password prompt?' );
                READ( LOGPROMPT ) ;
              UNTIL QUESTION( 'OK ' ) ;
              WRITELN ;
              REPEAT
                WRITE( 'What is the associated phone number?' ) ;
                READLN( NUMBER ) ;
              UNTIL QUESTION( CONCAT( 'Is ', NUMBER, ' correct' )) ;
              OPTIONS ;
              LOGON_DEFINED := TRUE ;
              END ;
      END ;
END ; { SETLOGON }


SEGMENT PROCEDURE DIAL ;
VAR
  DIAL_RESULT   : CR_DIALRESULT ;
  TEMP          : STRING ;
BEGIN
  IF QUESTION( 'Dial' )
    THEN
      REPEAT
        WRITELN ;
        WRITE( 'What number (<cr>=', NUMBER, ') :' ) ;
        READLN( TEMP ) ;
        IF LENGTH( TEMP ) > 0
          THEN
            IF TEMP[1] = CHR( 27 )  { Watch for <escape>. }
              THEN
                BEGIN
                PROCEED ;
                EXIT( DIAL ) ;
                END
              ELSE
                NUMBER := TEMP ;
        IF LENGTH( NUMBER ) > 0
          THEN
            BEGIN
            CR_DIAL( NUMBER, ',', DIAL_RESULT ) ;
            IF DIAL_RESULT <> CR_OFF_HOOK
              THEN
                WRITELN( 'Dial failed.  Response was ',
                         ORD( DIAL_RESULT ) ) ;
            END ;
      UNTIL (LENGTH( NUMBER ) = 0)
         OR (DIAL_RESULT = CR_OFF_HOOK)
    ELSE
      PROCEED ;
END ; { DIAL }

BEGIN

  WRITELN ;
  WRITELN( 'TERMINAL PROGRAM.', VERSION ) ;
  WRITELN( 'COPYRIGHT 1980, 1981, 1982 BY ROBERT W. PETERSON' ) ;
  WRITELN( 'ALL RIGHTS RESERVED' ) ;
  WRITELN( 'Bytes available = ', MEMAVAIL * 2 ) ;
  WRITELN( 'Log buffer size = ', LOGLIMIT ) ;
  
  DONE      := FALSE ;
  FILTERSET := [ CHR( 0 ) .. CHR( BACKSPACE-1 ), 
                 CHR( BACKSPACE+1 ) .. CHR( CR-1 ), 
                 CHR( CR+1 ) .. CHR( 31 ) ] ;
  NEARLY    := (LOGLIMIT DIV 100) * 80 ;
  
  WRITELN ;
  {  The "attention character" is used in several places to
     allow the user to cancel an activity.  For example, while
     the program is transmitting a file to the other system,
     the keyboard is monitored.  If the "attention character" is
     read, the transmission is aborted.
     
     The "attention character" is constrained to be a non-printing
     character if it is entered by the user.
   }
  IF QUESTION('Is <control E> a suitable attention character ')
    THEN
      C := CHR( 5 )
    ELSE
      REPEAT
        WRITELN ;
        B := FALSE ;
        REPEAT
          WRITE( 'What character will be used? ' ) ;
          WHILE NOT CR_KBSTAT DO ;
          C := CR_GETKB ;
          WRITELN( '<', ORD( C ), '>' ) ;
          IF C IN [' '..'~']
            THEN
              WRITELN( 
                      'You cannot use a displayable character')
            ELSE
              B := QUESTION( 'Is this correct ' ) ;
        UNTIL B ;
      UNTIL NOT (C IN [' '..'~']) ;
  WRITELN ;
  
  CR_COMMINIT( CR_ORIG, C, HAVEREM, HAVEDIAL ) ;
  IF NOT HAVEREM
    THEN
      BEGIN
      WRITELN( ' REMOTE not supported in current environment.' ) ;
      WRITELN( ' Program is terminating.' ) ;
      EXIT( TERMINAL ) ;
      END ;
  
  { RESULT is set good so that if none of the suggested models
    are available the program will not call CR_SETCOMMUNICATIONS. }
  RESULT := CR_SET_OK ;
  IF QUESTION( 'Is this a 990/5 or Model 2? ' )
    THEN
      IF QUESTION( '1200 BAUD' )
        THEN
          CR_SETCOMMUNICATIONS( 
                        FALSE,
                        TRUE,
                        1200,
                        8,
                        1,
                        CR_ORIG,
                        '990/5',
                        RESULT )
        ELSE
          CR_SETCOMMUNICATIONS( 
                        TRUE,
                        TRUE,
                        300,
                        7,
                        1,
                        CR_ORIG,
                        '990/5',
                        RESULT )
    ELSE
      IF QUESTION( 'Polymorphic' )
        THEN
          CR_SETCOMMUNICATIONS( 
                        TRUE,
                        TRUE,
                        300,
                        7,
                        1,
                        CR_ORIG,
                        'POLYMORPHIC',
                        RESULT )
        ELSE
          IF QUESTION( 'IBMPC' )
            THEN
              CR_SETCOMMUNICATIONS( 
                            FALSE,
                            TRUE,
                            300,
                            8,
                            1,
                            CR_ORIG,
                            'IBMPC',
                            RESULT ) ;
      
  IF RESULT <> CR_SET_OK
    THEN
      BEGIN
      WRITELN ;
      WRITELN ;
      WRITELN( 'Setting of baud rate failed!  Program is exiting.' ) ;
      EXIT( PROGRAM ) ;
      END ;
      
  SETLOGON ;
  
  { The options are normally set by selecting one of the predefined
    logons, or by manually specifying a logon.  If a logon
    was not specified, set the options here.             }
  IF NOT LOGON_DEFINED
    THEN
      OPTIONS ;
  
  { If CR_COMMINIT said dial support is available, try to dial
    the number.  Otherwise simply tell the unit to go off-hook.  }
  IF HAVEDIAL
    THEN
      DIAL
    ELSE
      PROCEED ;
  
  WRITELN ;
  WRITELN ;
  
END ;



========================================================================================
DOCUMENT :usus Folder:VOL15:term.log.text
========================================================================================

{$P+}
SEGMENT PROCEDURE CLOSELOG ;
VAR
  RESULT        : INTEGER ;
BEGIN
  IF LOGOPEN
    THEN
      BEGIN
      WRITELN ;
      IF BLOCKED
        THEN
          BEGIN
          IF LOGINDEX > 0
            THEN
              FLUSHBLOCKED ;
          WRITELN( 'Current logfile size is ',
                   BLOCKS_WRITTEN,
                   ' blocks.' ) ;
          IF QUESTION( CONCAT( 'Save ', LOGFILENAME ) )
            THEN
              CLOSE( BLOCKFILE, LOCK )
            ELSE
              CLOSE( BLOCKFILE, PURGE ) ;
          END
        ELSE
          CLOSE( LOGFILE, LOCK ) ;
      RESULT := IORESULT ;
      WRITELN ;
      WRITE( LOGFILENAME ) ;
      IF RESULT = 0
        THEN
          BEGIN
          WRITELN(' HAS BEEN CLOSED.' ) ;
          LOGOPEN := FALSE ;
          END
        ELSE
          WRITELN(' FAILED TO CLOSE.  IORESULT = ', RESULT ) ;
      END ;
END ;


{$P+}
SEGMENT PROCEDURE SETLOGFILENAME ;
VAR
  LEN           : INTEGER ;
  RESULT        : INTEGER ;
  BLOCK         : PACKED ARRAY[0..1023] OF CHAR ;
  
PROCEDURE FOLD( VAR STR : STRING ) ;
VAR
  I     : INTEGER ;
BEGIN
  FOR I := 1 TO LENGTH( STR ) DO
    IF STR[I] IN ['a'..'z']
      THEN
        STR[I] := CHR( ORD( STR[I] ) - 32 ) ;
END ; { FOLD }

BEGIN

  WRITELN ;
  CLOSELOG ;
  
(*$I-*)

  REPEAT
    WRITELN ;
    WRITE  ( 'What is the new log filename? ') ;
    READLN ( LOGFILENAME ) ;
    LEN := LENGTH( LOGFILENAME ) ;
    IF LEN = 0 
      THEN
        EXIT( SETLOGFILENAME ) ;
    FOLD( LOGFILENAME ) ;
    IF (LOGFILENAME = 'PRINTER:') OR 
       (LOGFILENAME = '#6:'     ) OR
       (LOGFILENAME = '#6'      ) OR
       (LOGFILENAME = 'CONSOLE:') OR
       (LOGFILENAME = '#1:'     ) OR
       (LOGFILENAME = '#1'      )
      THEN
        BEGIN
        RESULT := 1 ;
        BLOCKED := FALSE ;
        END
      ELSE
        BEGIN
        ADD_TEXT( LOGFILENAME ) ;
        BLOCKED := TRUE ;
        RESET  ( LOGFILE, LOGFILENAME ) ;
        RESULT := IORESULT ;
        END ;
    IF RESULT = 0
      THEN
        BEGIN
        CLOSE( LOGFILE, LOCK ) ;
        RESULT := 1 ;
        WRITELN ;
        WRITELN( LOGFILENAME, ' exists!  Try another name.' ) ;
        END
      ELSE
        IF LENGTH( LOGFILENAME ) > 0
          THEN
            BEGIN
            WRITE( 'OPEN OF ', LOGFILENAME, ' ' ) ;
            IF BLOCKED
              THEN
                REWRITE( BLOCKFILE, LOGFILENAME )
              ELSE
                REWRITE( LOGFILE, LOGFILENAME ) ;
            RESULT := IORESULT ;
            LOGOPEN := RESULT = 0 ;
            IF NOT LOGOPEN
              THEN
                WRITELN( ' FAILED.  REWRITE RESULT = ', RESULT )
              ELSE
                WRITELN( ' WAS SUCCESSFUL.' ) ;
            END ;
  UNTIL LOGOPEN ;
  WRITELN ;

  IF BLOCKED
    THEN
      BEGIN
      FILLCHAR( BLOCK, SIZEOF(BLOCK), CHR( 0 ) ) ;
      { Write two blocks of nulls as the first two blocks of
        the ".TEXT" file.                       }
      IF BLOCKWRITE( BLOCKFILE, BLOCK, 2, 0 ) <> 2
        THEN
          WRITELN( 'Error writing overhead blocks!' ) ;
      BLOCKS_WRITTEN := 2 ;
      END ;
(*$I+*)

END ;


{$P+}
SEGMENT PROCEDURE SAVELOG ;
CONST
  BLANK         = ' ' ;
  RETURNCHAR    =  13 ;
VAR
  C             : CHAR ;
  I             : 0 .. LOGLIMIT ;
  LINECOUNT     : INTEGER ;
  RESULT        : INTEGER ;
  TILDE         : CHAR ;
  TRASH         : CHAR ;
  UNITSIZE      : INTEGER ;
  WRITTEN       : BOOLEAN ;

PROCEDURE DOTS ;
BEGIN
  IF LINECOUNT >= 50
    THEN
      BEGIN
      WRITELN ;
      WRITE( ' ': 11 ) ;
      LINECOUNT := 1 ;
      END
    ELSE
      LINECOUNT := LINECOUNT + 1 ;
  WRITE( '.' ) ;
END ;


PROCEDURE DO_BLOCKED ;
VAR
  BASE          : INTEGER ;
  INDEX         : 0..1024 ;
  BLK_BUFFER    : PACKED ARRAY[0..1023] OF CHAR ;
BEGIN
  RESULT := 0 ;
  IF LOGINDEX < 1023
    THEN
      EXIT( DO_BLOCKED ) ;
  BASE   := 0 ;
  REPEAT
    MOVELEFT( LOG_ARRAY[BASE], BLK_BUFFER[0], 1024 ) ;
    INDEX := 1024 ;
    REPEAT { Find last <return> in buffer }
      INDEX := INDEX - 1 ;
    UNTIL (INDEX = 0) OR (BLK_BUFFER[INDEX] = CHR(RETURNCHAR) );
    IF INDEX < 1023
      THEN
        FILLCHAR( BLK_BUFFER[INDEX + 1], 1023 - INDEX, CHR( 0 ) ) ;
    IF BLOCKWRITE( BLOCKFILE, BLK_BUFFER, 2 ) <> 2
      THEN
        BEGIN
        WRITELN( 'Failure during logsave.  Logsave aborted.' ) ;
        RESULT := 99 ;
        END
      ELSE
        BLOCKS_WRITTEN := BLOCKS_WRITTEN + 2 ;
    DOTS ;
    BASE     := BASE + INDEX + 1 ;
    LOGINDEX := LOGINDEX - (INDEX + 1) ;
  UNTIL (LOGINDEX < 1023) OR (RESULT <> 0) ;
  MOVELEFT( LOG_ARRAY[BASE], LOG_ARRAY[0], LOGINDEX ) ;
  IF RESULT <> 0 
    THEN
      EXIT(SAVELOG) ;
  WRITELN ;
  WRITELN( 'Current logfile size is ', 
           BLOCKS_WRITTEN,
           ' blocks.' ) ;
END ; { DO_BLOCKED }

BEGIN
  WRITELN ;
  TILDE := '~' ;
  IF NOT LOGOPEN
    THEN
      BEGIN
      WRITELN( 'THE LOG FILE IS NOT OPEN!' ) ;
      WRITELN ;
      EXIT( SAVELOG ) ;
      END ;
  
  IF LOGINDEX < 1
    THEN
      EXIT( SAVELOG ) ;
      
  { LOGINDEX points to the next available character 
    position in the buffer.  Decrement LOGINDEX by one
    so that it points to the last character entered.  }
  LOGINDEX := LOGINDEX - 1 ;
  WRITELN( 'There are ', LOGINDEX, ' characters in the log.');
  
  IF NOT BLOCKED
    THEN
      BEGIN
      REPEAT
        WRITELN( 'How many lines/page? ' ) ;
{$I-}
        READLN( UNITSIZE ) ;
{$I+}
      UNTIL UNITSIZE > 10 ;
      PAGE( LOGFILE ) ;
      WRITELN( 'Writing log to ', LOGFILENAME )
      END
    ELSE
      BEGIN
      WRITELN( 'WRITING LOG (', LOGFILENAME, ').' ) ;
      WRITE  ( ' ':11 ) ;
      END ;
  
  LINECOUNT     := 0 ;
  
  IF BLOCKED
    THEN
      DO_BLOCKED 
    ELSE
      BEGIN
      FOR I := 0 TO LOGINDEX DO
        BEGIN
        C := LOGARRAY[ I ] ;
        IF    (C >= BLANK)
          AND (C <= TILDE)
          THEN
            BEGIN
            WRITTEN := TRUE ;
            WRITE( LOGFILE, C ) ;
            END
          ELSE
            IF C = CHR( RETURNCHAR )
              THEN
                IF WRITTEN
                  THEN
                    BEGIN
                    WRITELN( LOGFILE ) ;
                    IF LINECOUNT >= UNITSIZE
                      THEN
                        BEGIN
                        WRITE( 'PRESS ANY KEY TO CONTINUE' ) ;
                        REPEAT
                        UNTIL CR_KBSTAT ;
                        TRASH := CR_GETKB ;
                        LINECOUNT := 0 ;
                        PAGE( LOGFILE ) ;
                        END
                      ELSE
                        LINECOUNT := LINECOUNT + 1 ;
                    END ;
      CLEAR_LOG ;
      END ;
  
    LOGINDEX := LOGINDEX + 1 ; { Point to next available position. }
    RESULT := IORESULT ;
    IF RESULT <> 0
      THEN
        BEGIN
        WRITELN ;
        WRITELN( 'BAD RETURN IN SAVELOG: ', RESULT ) ;
        WRITELN( 'TERMINATING LOG SAVE' ) ;
        WRITELN ;
        EXIT( SAVELOG ) ;
        END ;
    END ; (* FOR *)
  
  WRITELN ;

END ;


========================================================================================
DOCUMENT :usus Folder:VOL15:term.main.text
========================================================================================

PROGRAM TERMINAL ;     {xL PRINTER: }
(*
  COPYRIGHT 1980, 1981, 1982 BY ROBERT W. PETERSON.
                ALL RIGHTS RESERVED.
                
  This program talks to the REMIN: and REMOUT: and has the
  following capabilities:
    1. Dumb terminal emulation.
    2. Logging to a file the text received.
    3. Transmitting down the line a file.
    4. Echoing or not echoing the characters typed/transmitted.
    5. Selecting the name of the log file dynamically.
    6. Transmitting a predefined logon sequence to REMOUT:
    7. Automatically dialing a telephone number.
    8. Optional Videotex copatibility.


================================================================================
  
  This program references the following files at compile time:
    1. An implementation of the USUS Standard Remote Unit of
       August 1981 stored in the file "STD.UNIT.CODE".
    2. Include file "TERM.INIT.TEXT", containing the program's
       initialization procedure.
    3. Include file "TERM.LOG.TEXT", containing procedures which
       are involved in logging text to disk, including opening
       a log file, moving chunks of the memory buffer to the log file
       but not placing characters into the memory buffer.
    4. Include file "TERM.UTIL.TEXT", containing the program's
       utility procedures, including menu display, option selection,
       transmitting of a logon, and other short utilities.
    5. Include file "TERM.EMUL.TEXT", containing the actual terminal
       emulation code, including receiving characters from remote
       and keyboard, displaying them, and moving them to the memory
       buffer.

================================================================================

     This program was originally developed using Version IV.01
  on a machine with only 56K bytes of memory and contains too
  many segment procedures to successfully compile under most
  other versions. The procedures are organized such that the
  largest procedures are in the early part of the source file.
  These large procedures should probably remain segmented.
  Later procedures are smaller and can be made memory resident
  with only a minor expansion of memory requirements.
  
     The source code has been marked in the appropriate 
  place for native code generation.
*)
{$P+}
(*==============================================================================
     
     Logons are optionally read from the file named in the constant
  "LOGON_FILENAME".  If the file cannot be found, the program ignores
  its absence and proceeds.  Entries in this file consist of nine
  lines:
      Line      Data
        1       Name of the entity being called.
                For example: "Compuserve", "Source", "Local ABBS"
                The name can be a maximum of 29 characters.
        2       Logon ID.  This is the first of two logon
                lines sent using the send logon command.
                The ID can be a maximum of 21 characters
        3       Password.  This is the second of the two
                logon lines sent using the send logon command.
                The password can be a maximum of 21 characters
        4       Prompt character.  The send logon command
                waits for this character to be sent by the remote 
                system before the second logon line is sent.
                The first character of the line is used.  The rest
                of the line is ignored.  If the line contains no
                characters, a question mark is used.
        5       Phone number.  This is the complete
                telephone number of the remote system.  This
                number will be used if auto-dial support is
                available in the Remote Unit.  The number can be a
                maximum of 21 characters.
          The following four lines are flag settings.  Each
          line must begin with a "T" (without quotes) if the
          associated flag is to be set true.  If the flag is
          to be set false the line must begin with "F".
        6       Filter Control Character flag.  If this flag
                is true, control characters sent from the
                remote system will not be displayed nor will
                they be moved into the log buffer.  This
                flag is usually true.
        7       Logging.  If true, received characters will 
                be placed into an internal buffer for later
                movement to a perpherial device.
        8       Echo.  If true the terminal program will
                echo to the screen locally all characters
                typed.  Echo is true for half-duplex
                systems only.  For most systems, this flag
                is false.
        9       VideoText Compatible.  If the remote system
                is sending CRT control characters compatible
                with Compuserve's VideoText control
                characters and you wish to respond to those
                control characters, this flag should be
                true.  Otherwise it should be false.  If you
                intend to set this flag True you must change
                the constants marked as Videotex to match
                your CRT requirements.

*)

{$P+}
{ The following unit must include the majority of the routines
  specified in the USUS Standard Remote Unit of 1981.  For
  a specification of the unit, see USUS News #5, Fall 1981.
  If you are not a USUS member, contact USUS (the UCSD
  p-System User Society) at P.O. Box 1148, La Jolla, 
  California  92038 for membership information.            }
USES {$U       :STD.UNIT.CODE } REMUNIT ;

{$P+}
CONST
  ARROW_DOWN    =    18 ;       { Used only in Videotex code }
  ARROW_LEFT    =    20 ;       { Used only in Videotex code }
  ARROW_RIGHT   =    19 ;       { Used only in Videotex code }
  ARROW_UP      =    17 ;       { Used only in Videotex code }
  BACKSPACE     =     8 ;
  CLEAR_EOLN    =    29 ;       { Used only in Videotex code }
  CLEAR_EOS     =    28 ;       { Used only in Videotex code }
  CLEAR_SCREEN  =    12 ;       { Used only in Videotex code }
  CR            =    13 ;
  ESCAPE        =    27 ;
  FORMFEED      =    12 ;
  HOME_CURSOR   =    11 ;       { Used only in Videotex code }
  KB            =     2 ;
  LINEFEED      =    10 ;
  LOGLIMIT      = 10000 ;
  LOGON_FILENAME= ':LOGONS.TEXT' ; { Leave the colon on! It is required. }
  PRINTER       =     6 ;
  REMIN         =     7 ;
  REMOUT        =     8 ;
  RUBOUT        =   127 ;
  VERSION       = ' VERSION 2.00 20 May 82  Standard USUS remote unit' ;



VAR
  { Short, frequently referenced variables. }
  C             : CHAR ;
  BLOCKED       : BOOLEAN ;
  DONE          : BOOLEAN ;
  ECHO          : BOOLEAN ;
  FILTERCONTROL : BOOLEAN ;
  LOGINDEX      : 0 .. LOGLIMIT ;
  LOGOPEN       : BOOLEAN ;
  LOGPROMPT     : CHAR ;
  LOGTEXT       : BOOLEAN ;
  NEARLY        : 0 .. LOGLIMIT ;
  VIDEOTEXT     : BOOLEAN ;
  FILTERSET     : SET OF CHAR ;
  
  { Larger, structured or infrequently referenced variables. }
  BLOCKFILE     : FILE ;
  BLOCKS_WRITTEN: INTEGER ;
  LOGARRAY      : PACKED ARRAY [ 0 .. LOGLIMIT ] OF CHAR ;
  LOGFILE       : TEXT ;
  LOGFILENAME   : STRING[ 30 ] ;
  LOGON_DEFINED : BOOLEAN ;
  LOGON1        : STRING ;
  LOGON2        : STRING ;
  NUMBER        : STRING ;
  TIMESHARE_SERVICE : STRING[29] ;

{$P+}
SEGMENT PROCEDURE ADD_TEXT( Var S : STRING ) ;          FORWARD ;
SEGMENT PROCEDURE CLEAR_LOG ;                           FORWARD ;
        PROCEDURE CLEAR_THE_SCREEN ;                    FORWARD ;
        PROCEDURE DISPLAY( C : CHAR ) ;                 FORWARD ;
        PROCEDURE LOGIT( C : CHAR ) ;                   FORWARD ;
SEGMENT PROCEDURE FLUSHBLOCKED ;                        FORWARD ;
SEGMENT PROCEDURE OPTIONS ;                             FORWARD ;
SEGMENT PROCEDURE PROCEED ;                             FORWARD ;
SEGMENT FUNCTION  QUESTION( PROMPT : STRING ) : BOOLEAN;FORWARD ;
SEGMENT PROCEDURE SAVELOG ;                             FORWARD ;
SEGMENT PROCEDURE SEND_LOGON ;                          FORWARD ;

{$I      :TERM.INIT.TEXT }
{$I      :TERM.LOG.TEXT  }
{$I      :TERM.UTIL.TEXT }
{$I      :TERM.EMUL.TEXT }

{$P+}
BEGIN { TERMINAL }

  { The following variables are initialized only at 
    program startup.  They are not changed when the user
    requests reinitialization of the program.             }
  BLOCKED   := FALSE ;
  LOG_INDEX := 0 ;
  LOG_TEXT  := FALSE ;
  LOG_OPEN  := FALSE ;
  
  INITIALIZE ;
  
  EMULATE ;

  { Do termination here so we can get off the line ASAP. }
  CR_COMMQUIT ;

  { Now we can, if necessary, save the log at our leisure. }
  IF LOGINDEX > 0
    THEN
      BEGIN
      WRITELN ;
      WRITE  ( 'There are ', LOGINDEX, ' characters in the log which have not' );
      WRITELN( ' been written to disk.');
      IF QUESTION( 'Do you wish to write the log ' )
        THEN
          BEGIN
          WRITELN ;
          IF NOT LOGOPEN
            THEN
              SETLOGFILENAME ;
          IF LOGOPEN
            THEN
              BEGIN
              SAVELOG ;
              IF BLOCKED
                THEN
                  FLUSHBLOCKED ;
              END ;
          END
        ELSE
          { Zero the log index so CLOSELOG won't write anything. }
          LOGINDEX := 0 ;
      END ;
          
  WRITELN ;
  
  CLOSELOG ;

END.



========================================================================================
DOCUMENT :usus Folder:VOL15:term.util.text
========================================================================================

{$P+}
SEGMENT PROCEDURE DUMPFILE ;{ Move a file to the comm line. }
CONST
  CR           = 13 ;
  LF           = 10 ;
  
VAR
  I            : INTEGER ;
  LINEFEED     : BOOLEAN ;
  LOGSTATUS    : BOOLEAN ;
  PACE         : BOOLEAN ;
  RESULT       : INTEGER ;
  WAIT_CHARACTER : CHAR ;
  WAIT_CR      : BOOLEAN ;
  
  READBUFFER   : STRING[255] ;
  XMITFILE     : TEXT ;
  XMITNAME     : STRING ;


PROCEDURE DUMPIT ;
{$N+}
BEGIN

  WRITELN ;
  WRITELN( 'TRANSMITTING ', XMITNAME ) ;
  WRITELN( 'USE <attention character> TO ABORT TRANSMISSION' ) ;
  WHILE NOT EOF( XMITFILE ) DO
    BEGIN
    READLN( XMITFILE, READBUFFER ) ;
    IF LENGTH( READBUFFER ) = 0  { See if the line is empty. }
      THEN
        READBUFFER := ' ' ; { Make the line at least a space long. }
    
    {
      Write the first character before entering the loop.  This results
    in better performance, especially when waiting for each 
    character before sending the next.  The reason is simple:
    The previous character is being returned while the current
    character is being sent, resulting in a character available quite
    soon after the program is ready to receive it.  
      This works best when a specific character is looked for at
    the end of each line, since any extra characters will be displayed
    while looking for the specific character.  That is, it is best
    if the program looks for a character at the start of each line.
    A <return> is always available, if nothing else is appropriate.
    }
    IF CR_CARRIER AND (LENGTH( READBUFFER ) > 0)
      THEN
        CR_PUTREM( READBUFFER[1] ) ;
    FOR I := 2 TO LENGTH( READBUFFER ) DO
      BEGIN
      IF NOT CR_CARRIER
        THEN
          BEGIN
          WRITELN ;
          WRITELN( 'LOST CARRIER.  TRANSMITTING ABORTED.' ) ;
          EXIT( DUMPIT ) ;
          END ;
      CR_PUTREM( READBUFFER[ I ] ) ;
      IF PACE
        THEN
          REPEAT
          UNTIL CR_REMSTAT OR CR_KBSTAT ;
      IF CR_REMSTAT
        THEN
          REPEAT
          UNTIL CR_REMSTAT OR CR_KBSTAT ;
      IF CR_REMSTAT
        THEN
          DISPLAY( CR_GETREM ) ;
      END ;
    CR_PUTREM( CHR( CR ) ) ;
    IF LINEFEED
      THEN
        CR_PUTREM( CHR( LF ) ) ;
    IF WAIT_CR
      THEN
        REPEAT
          IF CR_REMSTAT
            THEN
              BEGIN
              C := CR_GETREM ;
              DISPLAY( C ) ;
              END
            ELSE
              C := CHR( 0 ) ;
        UNTIL (C = WAIT_CHARACTER) OR CR_KBSTAT ;
    IF CR_KBSTAT
      THEN
        IF CR_GETKB = CR_ATTENCHAR
          THEN
            EXIT( DUMPIT ) ;
    END

END ;
{$N-}

  
BEGIN

(*$I-*)

  LOGSTATUS := LOGTEXT ;
  
  WRITELN ;
  WRITELN( 'DUMP A FILE TO REMOUT:' ) ;
  WRITELN( 'To quit, enter an empty filename.' ) ;
  WRITELN ;
  LOGTEXT  := QUESTION( 'Log transmitted data' ) ;
  LINEFEED := QUESTION( 'Transmit Linefeed after each carriage return ' ) ;
  PACE     := QUESTION( 'Wait for each character to be echoed ' ) ;
  WAIT_CR  := QUESTION( 'Wait for a returned character after each line ' ) ;
  IF WAIT_CR
    THEN
      REPEAT
        WRITELN ;
        WRITE( 'ENTER THE CHARACTER TO WAIT FOR:' ) ;
        REPEAT UNTIL CR_KBSTAT ;
        WAIT_CHARACTER := CR_GETKB ;
        IF WAIT_CHARACTER IN [' '..'~']
          THEN
            WRITELN( WAIT_CHARACTER )
          ELSE
            WRITELN( '<', ORD(WAIT_CHARACTER), '>' ) ;
      UNTIL QUESTION( 'Is this the correct character ' )
    ELSE
      WAIT_CHARACTER := CHR( 0 ) ;
  
    REPEAT
      WRITELN ;
      WRITE  ( 'What is the transmit textfile name? ') ;
      READLN ( XMITNAME ) ;
      IF LENGTH( XMITNAME ) > 0
        THEN
          BEGIN
          ADD_TEXT( XMITNAME ) ;
          RESET  ( XMITFILE, XMITNAME ) ;
          RESULT := IORESULT ;
          IF RESULT = 0
            THEN
              BEGIN
              DUMPIT ;
              WRITE( XMITNAME, ' COMPLETED.' ) ;
              LOGTEXT := LOGSTATUS ;
              EXIT( DUMPFILE ) ;
              END
            ELSE
              BEGIN
              WRITELN ;
              WRITELN( 'CANNOT FIND ', XMITNAME ) ;
              END ;
          END ;
  UNTIL (LENGTH( XMITNAME ) = 0 ) ;
  
(*$I+*)

  LOGTEXT := LOGSTATUS ; { Restore original logging status }

END ;
{$P+}
SEGMENT PROCEDURE MENU ;
CONST
  OUTPUTLOGON           = '5' ;
  QUIT                  = '6' ;
  RETURNTOTERMINAL      = '8' ;
VAR
  GOOD                  : BOOLEAN ;
  O                     : CHAR ;

PROCEDURE BACKUP( LINES : INTEGER ) ;
CONST
  MAX_BACKUP    = 1024 ;
VAR
  I                     : INTEGER ;
  INDEX                 : 0..LOGLIMIT ;
  BUFFER                : PACKED ARRAY[0..MAX_BACKUP] OF CHAR ;
BEGIN
  IF LOGINDEX < 2
    THEN
      EXIT( BACKUP ) ;
  INDEX := LOGINDEX ;
  IF LINES > 23
    THEN
      LINES := 23 ;
  I := 0 ;
  REPEAT
    INDEX := INDEX - 1 ;
    IF LOG_ARRAY[INDEX] = CHR( 13 )
      THEN
        I := I + 1 ;
  UNTIL { We have the requested number of lines. }
        (I > LINES) 
     OR { We've run out of saved characters. }
        (INDEX = 0) 
        { And be sure we don't overrun the buffer array. }
     OR ((LOGINDEX - INDEX) >= MAX_BACKUP) ;
  MOVELEFT( LOG_ARRAY[INDEX], BUFFER[0], 
            LOGINDEX - INDEX ) ;
  CLEAR_THE_SCREEN ; { Clear the screen. }
  UNITWRITE( 1, BUFFER, LOGINDEX - INDEX ) ;
END ; { BACKUP }

BEGIN
  REPEAT
    WRITELN ;
    WRITELN( ' ':10, 'TERMINAL PROGRAM MENU' ) ;
    WRITELN( 'Total log space = ', LOGLIMIT,
             '.  Space used = ', LOGINDEX,
              ' (', LOGINDEX DIV (LOGLIMIT DIV 100),
              '%)' ) ;
    IF LOGOPEN AND BLOCKED
      THEN
        WRITELN( 'The logfile is ', BLOCKS_WRITTEN, ' blocks long.' ) ;
    WRITE  ( '1. Set Options (Currently: ' ) ;
    IF ECHO
      THEN
        WRITE( 'Half Duplex' )
      ELSE
        WRITE( 'Full Duplex' ) ;
    IF LOGTEXT
      THEN
        WRITE( ', Logging' ) ;
    IF FILTERCONTROL
      THEN
        WRITE( ', Filter' ) ;
    IF VIDEOTEXT
      THEN
        WRITELN( ', Videotex)' )
      ELSE
        WRITELN( ')' ) ;
    WRITELN( '2. Select Log File Name' ) ;
    IF LOGOPEN
      THEN
        WRITELN( '3. Save Log (', LOG_FILE_NAME, ' is open)' )
      ELSE
        WRITELN( '3. Save Log' ) ;
    WRITELN( '4. Reset (clear) Log' ) ;
    IF LENGTH( LOGON1 ) > 0
      THEN
        WRITELN( '5. Send Logon String (Service is ', 
        TIMESHARE_SERVICE, '; ID is "', LOGON1, '")' )
      ELSE
        WRITELN( '5. Send Logon String (No string specified)' ) ;
    WRITELN( '6. QUIT TERMINAL PROGRAM' ) ;
    WRITELN( '7. Transmit File' ) ;
    WRITELN( '8. Quit Options & Return to terminal emulation' ) ;
    WRITELN( '9. ReInitialize program' ) ;
    WRITELN ;
    WRITE  ( 'Select option number:' ) ;
    REPEAT
      READ   ( KEYBOARD, O ) ;
    UNTIL O IN [ '1' .. '9' ] ;
    WRITE( O ) ;
    CASE O OF
      '1' : OPTIONS ;
      '2' : SETLOGFILENAME ;
      '3' : SAVELOG ;
      '4' : CLEARLOG ;
      OUTPUTLOGON : SENDLOGON ;
      QUIT: DONE := TRUE ;
      '7' : DUMPFILE ;
      RETURNTOTERMINAL : ;
      '9' : INITIALIZE ;
      END ;
  UNTIL O IN [ OUTPUTLOGON, RETURNTOTERMINAL, QUIT, '7', '3' ] ;
  WRITELN ;
  IF O IN [OUTPUTLOGON, RETURNTOTERMINAL, '3']
    THEN
      BACKUP( 10 ) ;
END ;
{$P+}
SEGMENT PROCEDURE CLEARLOG ;
BEGIN
  IF QUESTION( 'CLEAR LOG: Are you sure ' )
    THEN
      LOGINDEX := 0
END ;

{$P+}
SEGMENT PROCEDURE SENDLOGON ;
VAR
  I             : 0 .. LOGLIMIT ;
BEGIN
  WRITELN ;
  WRITELN ;
  WRITELN( 'Transmitting ', TIMESHARE_SERVICE, ' logon.' ) ;
  FOR I := 1 TO LENGTH( LOGON1 ) DO
    BEGIN
    CR_PUTREM( LOGON1[ I ] ) ;
    REPEAT
    UNTIL CR_REMSTAT OR CR_KBSTAT ;
    IF CR_REMSTAT
      THEN
        DISPLAY( CR_GETREM ) ;
    END ;
  CR_PUTREM( CHR(CR) ) ; (* CR *)
  REPEAT
    IF CR_REMSTAT
      THEN
        BEGIN
        C := CR_GETREM ;
        DISPLAY( C ) ;
        END
      ELSE
        C := CHR( 0 ) ;
  UNTIL (C = LOGPROMPT) OR CR_KBSTAT ;
  FOR I := 1 TO LENGTH( LOGON2 ) DO
    CR_PUTREM( LOGON2[ I ] ) ;
  CR_PUTREM( CHR(CR) ) ; (* CR *)
END ;
{$P+}
SEGMENT FUNCTION QUESTION{ PROMPT : STRING ) : BOOLEAN};
VAR
  C             : CHAR ;
BEGIN
  WRITELN ;
  WRITELN ;
  WRITE  ( PROMPT, '(Y or N)?' ) ;
  REPEAT
    READ( KEYBOARD, C ) ;
  UNTIL C IN [ 'y', 'n', 'Y', 'N' ] ;
  WRITE( C ) ;
  QUESTION := C IN ['y', 'Y'] ;
END ;

{$P+}
SEGMENT PROCEDURE OPTIONS ;
BEGIN
  FILTERCONTROL := QUESTION( 'Do you wish to filter control characters' ) ;
  LOGTEXT       := QUESTION( 'Do you wish to log the text' ) ;
  ECHO          := QUESTION( 'Do you wish to echo the keyboard' ) ;
  VIDEOTEXT     := QUESTION( 'Do you wish to respond to videotext control codes' ) ;
  WRITELN ;
  WRITELN ;
  WRITELN ;
END ;
{$P+}
SEGMENT PROCEDURE ADD_TEXT{ VAR S : STRING } ;
VAR
  I     : INTEGER ;
  LEN   : INTEGER ;
BEGIN
  LEN := LENGTH( S ) ;
  FOR I := 1 TO LEN DO  { Make the name all upper-case. }
    IF S[I] IN ['a'..'z']
      THEN
        S[I] := CHR( ORD( S[I] ) - 32 ) ;
  IF POS( ']', S ) = 0  { See if a size specified. }
    THEN
      IF LEN >= 5
        THEN
          BEGIN
          IF    (POS( '.TEXT', S ) <> LEN - 4)
            AND (S[LEN] <> '.')
             THEN
               S := CONCAT( S, '.TEXT' ) ;
          END
        ELSE
          IF S[LEN] <> '.'
           THEN
             S := CONCAT( S, '.TEXT' ) ;
END ;
{$P+}
SEGMENT PROCEDURE PROCEED ;
BEGIN
  { Initialize by going "off hook" then back "on hook" }
  { This should allow manual dialing (or support direct }
  { connection of two computers. }
  CR_HOOK( FALSE ) ;
  CR_HOOK( TRUE  ) ;
  WRITELN ;
  WRITELN( 'Proceed when connection has been made.' ) ;
END ;
{$P+}
SEGMENT PROCEDURE FLUSHBLOCKED ;
{ Write out the remaining characters in the log. }
VAR
  BLK_BUFFER    : PACKED ARRAY[0..1023] OF CHAR ;
BEGIN
  IF LOG_INDEX >= 1023
    THEN
      SAVE_LOG ;
  IF LOG_INDEX > 1023
    THEN
      BEGIN
      WRITELN( 'INTERNAL ERROR IN "FLUSH_BLOCKED".  PROGRAM ABORTS.' ) ;
      IF QUESTION( CONCAT( 'Save ', LOGFILENAME ))
        THEN
          CLOSE( BLOCKFILE, LOCK )
        ELSE
          CLOSE( BLOCKFILE, PURGE ) ;
      EXIT( PROGRAM ) ;
      END ;
  MOVELEFT( LOG_ARRAY[0], BLK_BUFFER[0], LOG_INDEX ) ;
  IF LOG_INDEX < 1024
    THEN
      BEGIN
      FILLCHAR( BLK_BUFFER[ LOG_INDEX ],
                1024 - LOG_INDEX,
                CHR( 0 ) ) ;
      BLK_BUFFER[ LOG_INDEX ] := CHR( 13 ) ;
      END ;
  IF BLOCKWRITE( BLOCKFILE, BLK_BUFFER, 2 ) <> 2
    THEN
      WRITELN( 'Error writing last two blocks of log.' )
    ELSE
      BLOCKS_WRITTEN := BLOCKS_WRITTEN + 2 ;
  LOG_INDEX := 0 ; { We've written everything. }
END ; { FLUSHBLOCKED }
{$P+}
PROCEDURE CLEAR_THE_SCREEN ;
BEGIN
  { For some machines, this might not work!  Therefore clearing
    the screen is centralized for easy modification.          }
  PAGE( OUTPUT ) ; 
END ;


========================================================================================
DOCUMENT :usus Folder:VOL15:tomus3.a.text
========================================================================================



                      INSTRUCTIONS FOR TOMUSUS.03


1.  GENERAL INFORMATION

TOMUSUS stands for "Terminal Option for MUSUS" and is pronounced "to 
muse us".  It is a modified version of Bob Peterson's TERMINAL program 
which utilizes REMUNIT, the standard communication UNIT adopted by 
USUS for all terminal communication programs in UCSD Pascal.

TOMUSUS.03 is an upgraded version of TOMUSUS.02, which was previously
made available for LSI-11 users of MUSUS.  TOMUSUS.03 is more
efficient for disk operations during transmission and also has the
following new features:

     a.  The B(reak option, which transmits the break signal to the
remote computer;

     b.  The X(off option, which transmits the XOFF (control-S) signal
to the remote computer;

     c.  O(ptions will now present a submenu.

It should be noted that REMUNIT.L3, which is used by TOMUSUS.03,
utilizes the two external procedures SET_BREAK and CLR_BREAK.  These
are assembly language programs for the LSI-11 which perform the
simple functions of turning on and off the hardware generated break
signals.  The present code for these procedures assume the standard
addresses for REMIN and REMOUT (177520).  If any other address is to
be used, the value for XCSR in both SET_BREAK and CLR_BREAK must be
altered accordingly.


2.  CONTENTS OF THE TOMUSUS FILES

The MUSUS Library version of TOMUSUS.03 consists of the following 
five files:
        
        TOMUS3.A contains instructions for compiling and executing 
        TOMUSUS.03.  (This is what you are reading now.)
        
        TOMUS3.B1 contains the external procedure SET_BREAK and should
        be renamed SET_BREAK.TEXT.
        
        TOMUS3.B2 contains the external procedure CLR_BREAK and should
        be renamed CLR_BREAK.TEXT.

        TOMUS3.B3 contains the unit REMUNIT for TOMUSUS.03 and should
        be renamed REMUNIT.L3.TEXT.  (The "L" in L3 is to remind you
        that this unit was written primarily for LSI-11s.)
        
        TOMUS3.C1 and TOMUS3.C2 together make up the main TOMUSUS.03
        program.  TOMUS3.C1 contains program comments that should be
        inserted at the beginning of the program just after the copyright
        statement.  TOMUS3.C2  contains the main TOMUSUS.03 program.
        It should be renamed TOMUSUS.03.TEXT.

The following instructions for compiling TOMUSUS.03 will assume that 
you have renamed the files as above.


3.  COMPILING

TOMUSUS.03 uses the unit REMUNIT.L3 which in turn uses the external 
procedures SET_BREAK and CLR_BREAK.  Hence, the procedure for 
compiling the entire program must be done in the appropriate sequence 
of steps, as follows.

Step 1:  Assemble SET_BREAK.TEXT and get SET_BREAK.CODE.

Step 2:  Assemble CLR_BREAK.TEXT and get CLR_BREAK.CODE.

Step 3:  Compile REMUNIT.L3.TEXT and get REMUNIT.L3.CODE.

Step 4:  By executing the system program *LIBRARY.CODE, create a new
library (call it anything you want) which will contain the contents of
*SYSTEM.LIBRARY, SET_BREAK.CODE, CLR_BREAK.CODE, and REMUNIT.L3.CODE.

Step 5:  Do a L(ink of the new library. 

Step 6:  Use the linked library as your new *SYSTEM.LIBRARY.

Step 7:  R(un TOMUSUS.03.TEXT and get TOMUSUS.03.CODE as well as a 
test run of the program.


2.  EXECUTING TOMUSUS.03.CODE

Execution of TOMUSUS should be almost self-explanatory, but the 
following comments may be of some help.

     a.  After you do an eXecute on TOMUSUS, it will display a brief
statement on your screen about the TOMUSUS version, date, author's
name, and a copyright statement.  It will then ask you to press
RETURN.  

     b.  After RETURN has been entered, TOMUSUS is ready to
communicate with the remote computer of your choice.  If you had not
already done so, you should connect your modem to the telephone system
at this time and dial the remote computer.  Nothing else needs to be
done as far as TOMUSUS is concerned.

     c.  At anytime during or prior to establishing your remote
connection (but after the initial RETURN), you may temporarily enter
the offline mode of TOMUSUS by pressing the "attention character". 
The default for this is control-E (or control-e).  When the attention
character is pressed, TOMUSUS will temporarily enter an "off-line"
mode and display a menu of certain things you may choose to do at
this point, as follows:

        (1)     Q(uit will terminate the current TOMUSUS session.

        (2)     C(ontinue will cause an immediate exit from the
                offline mode.  (A control-c will also do the same.)

        (3)     B(reak will send the break signal to the remote.
        
        (4)     X(off will send the XOFF character (control-s) to the
                remote.  (Other control characters can be sent directly
                from the keyboard, except for the TOMUSUS attention
                character.)
                
        (5)     O(ptions stands for "miscellaneous options".  It will
                display its own submenu.  Each selection will result in
                a question to the user concerning certain transmission
                characteristics, echoing, or the attention character.
                If you want to change the attention character or
                communicate with a half duplex remote, this is where
                you would change your parameters.  
        
        (6)     L(ogfile will permit you to initiate or terminate
                logging your session to a diskfile.  It will first
                tell you whether a logfile is currently open or not.
                
                If not open, it will ask you if you want to open a 
                logfile.  If you answer with a "Y" or "y", it will 
                ask for a file name.  You should specify a complete 
                diskfile name.  (Remember to use .TEXT if you will
                subsequently use the Editor on this file.)  If you 
                change your mind, a null entry will cancel this operation.
                
                If open, it will ask if you want to close the diskfile.
                
                Opening and closing diskfiles can be done as many times
                as is desired during a session.  Hence, you can write
                different portions of your session to different disk
                files.
                
        (7)     P(rinter is a toggle switch that allows you to open
                or close the line printer at any time during your
                TOMUSUS session.
                
                The current print routine sends characters to the 
                printer as they are typed or received from the remote
                computer.  Hence, if your printer does not allow the
                immediate printing of characters received (or does not
                have the necessary line buffer to collect a line of
                characters before printing), you may run into problems.
                
                
     d.  The offline mode can be entered at any time and as often as
you wish.  In the current implementation of REMUNIT, you can Q(uit out
of TOMUSUS and re-execute TOMUSUS without affecting your remote
communication.  This also means that if necessary you can even do
some offline maneuvers (like examining your disk directory) and then
return to the online mode without affecting your remote connection.


3.  KNOWN BUGS

There is a bug in TOMUSUS.03 that has not been fixed.  This bug is 
encountered when both the L(ogfile and P(rinter options are on.  The 
result is that both the disk file and printer output will$lose some 
characters.  It does not happen when only one of these options is on.

This bug may only affect those who have the same printer configuration 
as mine, which is a TI-810 connected to a Heath H-11 via the Heath 
serial I/O board for the TI-810.  

     
4.  FINAL COMMENTS

Although TOMUSUS bears my copyright statement, it is the result of a 
cooperative effort between myself and the following persons:

        Robert W. Peterson, who was kind enough to allow me to use his 
program TERMINAL and his unit REMUNIT as the starting point for 
TOMUSUS;

        Walter B. Farrell, who made most of the necessary changes to 
Bob Peterson's REMUNIT that allowed the autolog function of TOMUSUS.02 
to work properly; and

        Dr. Richard Yensen, who provided me with the BLOCKWRITE and 
UNITWRITE changes that speeded up the autolog function.


By the way, TOMUSUS was copyrighted primarily to protect Bob 
Peterson's copyright rather than my own code.  If you wish to make 
further changes for your own use, I see no reason why Bob would 
object.  However, if you distribute any modified version of TOMUSUS, I 
think that you should check with Bob and me first.

I would appreciate any and all comments about TOMUSUS, whether you
like it or not.  I am sure that many improvements can be made, and
would like to have any help you could provide to make TOMUSUS a really
useful and enjoyable program.

If you have any problems with TOMUSUS, feel free to send me messages 
on MUSUS or Telemail, or call me at (213)541-2918 any time I'm there
(day or night).


Mike Ikezawa
03 December 1981


========================================================================================
DOCUMENT :usus Folder:VOL15:tomus3.c1.text
========================================================================================


{
This is a modified version of an unpublished, copyrighted 
program called TERMINAL by Robert W. Peterson.  TOMUSUS
uses the unit REMUNIT by R.W. Peterson as modified by Walt
Farrell and myself.

Modifications by this author are in lower case throughout the
program.  Since the original TERMINAL code was entirely in upper
case, except for a few user prompt output, all modifications can
be identified by the use of lower case.  Original code that have
simply been moved from one location to another retain their upper
case.

TOMUSUS differs from TERMINAL in the following ways:

       (1)  Saving the log file is done automatically.
       
       (2)  The logtext option can be switched on and off
            without re-initializing.
            
       (3)  The printer can be switched on and off at any
            time independent of the logtext options.
       
       (4)  The following options have been deleted:
       
                  Videotext
                  Filter control characters
                  Logtext to printer and console
                  
       (5)  The menu has been changed.  UCSD system style
            menus are used.  The menu is automatically
            exited after each menu function is completed.
            Control-E is used to enter the menu.  Control-C
            or the C(ontinue option will exit the menu
            immediately.  The Q(uit option terminate the
            program after closing previously opened files.
            The L(ogfile option has sub-options to open or 
            close files.  The P(rinter option is a toggle
            switch that opens and closes the printer file.
            The T(ransmit option has been simplified by the
            removal of all sub-options except the filename
            selection.  O(ptions is now the central place for
            all other options previously residing in other
            places, e.g. initialization and transmit.
            
TOMUSUS is designed primarily for the LSI-11, but it may work
on other hardware running UCSD Version IV.0.  It will not run
on Version II.0, because the required REMUNIT does not compile
on II.0.

VERSION 03:  Version 03 differs from Version 02 as follows:

  (1)   The Version 03 menu includes the option B(reak.  Therefore,
        it assumes that CR_BREAK has been implemented in REMUNIT.
        
  (2)   The Version 03 menu also includes the option X(off.  
        This permits XOFF (control-S) to be transmitted to the
        remote computer.  (Typing control-S instead of using X(off
        causes the p-system to pause rather than the remote system.)
        No TOMUSUS option is necessary to transmit XON, because
        control-Q and control-W are passed to the remote system by
        the p-system.
        
  (3)   Execution of the Logfile option has been speeded up consider-
        ably, thanks to Richard Yensen's modification that replaced
        the WRITE to disk statement with the BLOCKWRITE statement.
        This change further permitted the deletion of the XOFF/XON
        sequence thereby making it possible to use the Logfile option
        when communicating with remote systems that do not recognize
        XOFF/XON.
        
        Yensen also replaced the WRITE to console and WRITE to printer
        statements with UNITWRITE statements.
        
  (4)   A submenu has been installed in Options.  This permits a more
        direct access to each TOMUSUS setting.


All inquiries about this program should be addressed to:

        Michael A. Ikezawa
        10 Packsaddle Road West
        Rolling Hills, CA 90274

        (213)541-2918
}


========================================================================================
DOCUMENT :usus Folder:VOL15:tomus4.c2.text
========================================================================================


{ L printer:}

PROGRAM tomusus ;

{
Version 04  15 July 1982

(C) Copyright 1981 ,1982 by Michael A. Ikezawa
}

{The comments contained in the MUSUS Library file TOMUS3.C1 should be
inserted here.  They were made a separate file due to the 30 block
limitation of the Screen Editor.  MAI}

USES  (*$U remunit.l3.code*)REMUNIT ;

CONST
  BACKSPACE     =     8 ;
  CR            =    13 ;
  ESCAPE        =    27 ;
  FORMFEED      =    12 ;
  KB            =     2 ;
  LF            =    10 ;
  LOGLIMIT      =  1024 ;
  PRINTER       =     6 ;
  REMIN         =     7 ;
  REMOUT        =     8 ;
  RUBOUT        =   127 ;
  xon           =    17 ;
  xoff          =    19 ;



VAR
  C             : CHAR ;
  DONE          : BOOLEAN ;
  ECHO          : BOOLEAN ;
  linefeed      : boolean ;
  LOGARRAY      : PACKED ARRAY [ 1 .. LOGLIMIT ] OF CHAR ;
                        {change lower limit from 0 for Yensen stuff}
  LOGFILE       : file ;  {Yensen}
  LOGFILENAME   : STRING[ 30 ] ;
  LOGINDEX      : 0 .. LOGLIMIT ;
  LOGTEXT       : BOOLEAN ;
  pace          : boolean;
  printext      : boolean;
  printfile     : text;
  wait_character: char;
  wait_cr       : boolean;
  outbuf        : packed array [ 1 .. loglimit ] of char;  {gws}

procedure savelog; forward;
procedure openlog; forward;

PROCEDURE LOGIT( C : CHAR ) ;
BEGIN
  logindex := succ(logindex) ; {Yensen}
  LOGARRAY[ LOGINDEX ] := C ;
  IF LOGINDEX >= LOGLIMIT THEN
    savelog;
END ;


PROCEDURE DISPLAY( C : CHAR ) ;

BEGIN

  IF C <> CHR(LF) THEN
    begin
    unitwrite(1,C,1,1) ;   {Yensen}
    IF LOGTEXT THEN
      LOGIT( C ) ;
    If printext then
      unitwrite(printer,C,1,1) ;  {Yensen}
    end
END ;


FUNCTION QUESTION( PROMPT : STRING ) : BOOLEAN ;
VAR
  C             : CHAR ;
BEGIN
  WRITE  ( PROMPT, ' (y or n)? ' ) ;
  REPEAT
    READ( KEYBOARD, C ) ;
  UNTIL C IN [ 'y', 'n', 'Y', 'N' ] ;
  WRITEln( C ) ;
  QUESTION := C IN ['y', 'Y'] ;
END ;

procedure menu; forward;


PROCEDURE OPTIONS ;

var     C       :CHAR;
        B       :BOOLEAN;
        good    :boolean;
        o       :char;
        quit    :boolean;
        
procedure wait;

begin
wait_cr := question( 'Wait for a returned character after each line' );
IF WAIT_CR
  THEN
    REPEAT
      WRITELN ;
      write( 'Enter the character to wait for:' ) ;
      READ( KEYBOARD, WAIT_CHARACTER ) ;
      IF EOLN (keyboard) 
        THEN 
          WAIT_CHARACTER := CHR( CR ) ;
      IF WAIT_CHARACTER IN ['A'..'~']
        THEN
          WRITELN( WAIT_CHARACTER )
        ELSE
          writeln( ' CHR(', ORD(WAIT_CHARACTER), ')' ) ;
    UNTIL QUESTION( 'Is this the correct character ' )
  ELSE
    WAIT_CHARACTER := CHR( 0 ) ;
end;

procedure attention;  {Change attention character}

begin
REPEAT
  REPEAT
    write( 'What attention character will be used? ' ) ;
    read(keyboard,C);
    writeln( 'CHR(', ORD( C ), ')' ) ;
    IF C IN [' '..'~']
      THEN
        WRITELN('You cannot use a displayable character')
      ELSE
        B := QUESTION( 'Is this correct' ) ;
  UNTIL B ;
UNTIL NOT (C IN [' '..'~']) ;
cr_attenchar := C;
end;

BEGIN
  writeln;
  quit := false;
  repeat
    write('OPTIONS: E(cho, L(inefeed, P(ace, W(ait, A(ttention, Q(uit ? ');
    repeat
      read(keyboard,o);
      good := o in ['e','E','l','L','p','P','w','W','a','A','q','Q'];
      if good then
        begin
        writeln(o);
        writeln;
        case o of
          'e','E' : echo    := question( 'Echo the keyboard' );
          'l','L' : linefeed := question( 'Send linefeeds' );
          'p','P' : pace := question( 'Wait for each character to be echoed' );
          'w','W' : wait;
          'a','A' : attention;
          'q','Q' : quit := true;
          end;
        end
      else
        write(chr(7));
    until good;
    writeln;
  until quit;
        
END ;


PROCEDURE INITIALIZE ;

VAR
  B            : BOOLEAN ;
  C            : CHAR ;
  HAVEDIAL     : BOOLEAN ;
  HAVEREM      : BOOLEAN ;
  RESULT       : CR_BAUD_RESULT ;

BEGIN

  gotoxy(10,7);
  write('TOMUSUS       ***********       Version 04, 15 July 1982');
  gotoxy(10,9);
  write('(C) Copyright, 1981, 1982   by Michael A. Ikezawa');
  gotoxy(10,11);
  write( 'This program is based on, and contains material from, the'); 
  gotoxy(10,12);
  write( 'copyrighted program TERMINAL by Robert W. Peterson, 28Mar81');
  writeln;
  writeln;
  writeln;

  DONE      := FALSE ;
  logtext   := FALSE ;
  printext  := false;
  echo      := false;
  linefeed  := false;
  pace      := false;
  wait_cr   := false;

  C := CHR( 5 );

  CR_COMMINIT( CR_ORIG, C, HAVEREM, HAVEDIAL ) ;
  IF NOT HAVEREM
    THEN
      BEGIN
      WRITELN( ' REMOTE not supported in current environment.' ) ;
      WRITELN( ' Program is terminating.' ) ;
      EXIT( TOMUSUS ) ;
      END ;

  CR_SETCOMMUNICATIONS( 
                TRUE,
                TRUE,
                300,
                7,
                1,
                CR_ORIG,
                'LSI-11',
                RESULT ) ;

  WRITEln( 'Press <RETURN> when connection has been made.  Thereafter,' ) ;
  writeln( 'use attention character (default Control-E) for TOMUSUS menu');
  writeln( 'whenever necessary.');
  writeln;
  write('====================     ',
        'begin communication      ',
        '     ====================');
  READLN( KEYBOARD, C ) ;
  CR_ANSWER ;
  WRITELN;

END ;

PROCEDURE CLEARLOG ;
BEGIN
  fillchar(logarray,loglimit,chr(0)) ;  {Yensen}
  LOGINDEX := 0
END ;


PROCEDURE CLOSELOG ;
VAR
  RESULT        : INTEGER ;
BEGIN
  IF logtext
    THEN
      BEGIN
      savelog;
      {$I-}
      CLOSE( LOGFILE, LOCK ) ;
      RESULT := IORESULT ;
      {$I+}
      WRITE( LOGFILENAME ) ;
      IF RESULT = 0
        THEN
          begin
          WRITELN(' closed.' );
          logtext := false;
          end
        ELSE
          WRITELN(' Failed to close.  IORESULT = ', RESULT ) ;
      END 
END ;


PROCEDURE openlog ;
VAR
  RESULT        : INTEGER ;
BEGIN
  REPEAT
    WRITE  ( 'Log filename? ') ;
    READLN ( LOGFILENAME ) ;
    IF LENGTH( LOGFILENAME ) > 0
      THEN
        BEGIN
        if ( pos ( '.text', logfilename ) = 0 ) and
           ( pos ( '.TEXT', logfilename ) = 0 )
          then logfilename := concat ( logfilename , '.TEXT' ); {gws}
        WRITE( 'Open of ', LOGFILENAME, ' ' ) ;
        {$I-}
        REWRITE( LOGFILE, LOGFILENAME ) ;
        RESULT := IORESULT ;
        {$I+}
        logtext := RESULT = 0 ;
        IF NOT logtext
          THEN
            WRITELN( ' failed.  REWRITE RESULT = ', RESULT )
          ELSE
            WRITELN( ' was successful.' ) ;
        END ;
  UNTIL logtext OR (LENGTH( LOGFILENAME ) = 0 ) ;
  
  clearlog;
  result := blockwrite ( logfile, logarray, 2 );  {write header block}
  WRITELN ;

END ;


PROCEDURE SAVELOG ;  {completely rewritten to output a legal textfile - gws}
VAR
  RESULT        : INTEGER ;
  excess_chars : integer;
BEGIN
  
  if logindex = 0 then exit(savelog);
  fillchar ( outbuf, sizeof ( outbuf ), chr ( 0 ) );
  excess_chars := scan ( -1024, = chr ( 13 ),  
                               logarray [ sizeof ( logarray ) ] );
  excess_chars := - excess_chars;
  moveleft ( logarray, outbuf, sizeof ( logarray ) - excess_chars );
  result := (blockwrite(logfile,outbuf,2)) ;  
  if result <> 2 then
    writeln( 'Only ',result,' blocks written') 
  else
     begin
        if excess_char <> 0 then
           begin
              moveleft ( logarray [ sizeof ( logarray ) - excess_chars + 1 ], 
                              logarray, excess_chars );
              fillchar ( logarray [ excess_chars + 1 ],
                              sizeof ( logarray ) - excess_chars - 1, 
                              chr ( 0 ) );
              logindex := excess_chars;
           end
        else clear_log;
     end;
END ;


PROCEDURE SENDLOGON ;

BEGIN
END ;


PROCEDURE DUMPFILE ;

VAR
  I            : INTEGER ;
  READBUFFER   : STRING ;
  RESULT       : INTEGER ;
  XMITFILE     : TEXT ;
  XMITNAME     : STRING ;


procedure endmarker;
begin
  writeln;
  writeln('====================     ',
          'end transmission         ',
          '     ====================');
end;

PROCEDURE DUMPIT ;

BEGIN

  WRITELN( 'Transmitting ', XMITNAME ) ;
  WRITELN( 'Use attention character to abort transmission' ) ;
  writeln('====================     ',
          'begin transmission       ',
          '     ====================');
  WHILE NOT EOF( XMITFILE ) DO
    BEGIN
    READLN( XMITFILE, READBUFFER ) ;
    FOR I := 1 TO LENGTH( READBUFFER ) DO
      BEGIN
      IF NOT CR_CARRIER
        THEN
          BEGIN
          endmarker;
          WRITELN( 'Lost carrier.  Transmitting aborted.' ) ;
          EXIT( DUMPIT ) ;
          END ;
      IF CR_REMSTAT
        THEN
          DISPLAY( CR_GETREM ) ;
      CR_PUTREM( READBUFFER[ I ] ) ;
      IF PACE
        THEN
          REPEAT
          UNTIL CR_REMSTAT OR CR_KBSTAT ;
      END ;
    CR_PUTREM( CHR( CR ) ) ;
    IF LINEFEED
      THEN
        CR_PUTREM( CHR( LF ) ) ;
    IF WAIT_CR
      THEN
        REPEAT
          IF CR_REMSTAT
            THEN
              BEGIN
              C := CR_GETREM ;
              DISPLAY( C ) ;
              END
            ELSE
              C := CHR( 0 ) ;
        UNTIL (C = WAIT_CHARACTER) OR CR_KBSTAT ;
    IF CR_KBSTAT
      THEN
        begin
        c := cr_getkb;
        IF c = CR_ATTENCHAR
          THEN
            begin
            endmarker;
            writeln('Transmission aborted by user.');
            EXIT( DUMPIT ) ;
            end
        end
    END;
  
  endmarker;

END ;


BEGIN

(*$I-*)


  WRITE  ( 'Transmit filename? ') ;
  READLN ( XMITNAME ) ;
  IF LENGTH( XMITNAME ) <> 0
    THEN
      BEGIN
      RESET  ( XMITFILE, XMITNAME ) ;
      RESULT := IORESULT ;
      IF RESULT = 0
        THEN
          BEGIN
          DUMPIT ;
          WRITE( XMITNAME, ' completed.' ) ;
          END
        ELSE
          BEGIN
          WRITELN ;
          WRITELN( 'Cannot find ', XMITNAME ) ;
          END ;
      END ;

(*$I+*)

END ;

procedure openprinter;

var     result  :integer;

begin
  {$I-}
  rewrite(printfile,'printer:');
  result := IORESULT;
  {$I+}
  if result = 0 then
    begin
    printext := true;
    write(printfile,chr(12));
    writeln('Printer opened');
    end
  else
    writeln('Printer not opened.  IORESULT = ',result);
end;


procedure closeprinter;

var     result  :integer;

begin
  writeln(printfile);
  {$I-}
  close(printfile);
  result := IORESULT;
  {$I+}
  if result = 0 then
    begin
    printext := false;
    writeln('Printer closed');
    end
  else
    writeln('Printer not closed.  IORESULT = ',result);
end;


procedure logswitch;

begin
  if logtext then
     begin
     if (question('Logfile is open.  Close it')) then closelog
     end
  else
    if (question('Logfile is closed.  Open it')) then openlog
end;

procedure printswitch;
var     query   :boolean;
begin
  if printext then
    closeprinter
  else
    openprinter;
end;

PROCEDURE MENU ;

VAR
  GOOD                  : BOOLEAN ;
  O                     : CHAR ;

BEGIN
  unitclear(kb);
  writeln;
  writeln('====================     ',
          'TOMUSUS menu on          ',
          '     ====================');
  write('Q(uit, C(ontinue, B(reak, X(off, O(ptions, ');
  write('L(ogfile, P(rinter, T(ransmit ? ');
  repeat
    READ (keyboard, O ) ;
    GOOD := O IN ['q','Q','c','C','b','B','x','X','o','O',
                  'l','L','p','P','t','T'] ;
    IF GOOD
      THEN
        begin
        writeln(o);
        writeln;
        CASE O OF
          'q','Q' : DONE := TRUE;
          'c','C' : ;
          'b','B' : cr_break;
          'x','X' : cr_putrem(chr(xoff));
          'o','O' : options;
          'l','L' : logswitch ;
          'p','P' : printswitch ;
          't','T' : DUMPFILE ;
          END ;
        end
      else
        write(chr(7));
  until good;
  writeln;
  writeln('====================     ',
          'TOMUSUS menu off         ',
          '     ====================');
END ;



BEGIN

  INITIALIZE ;

  REPEAT
    IF CR_KBSTAT
      THEN
        BEGIN
        C := CR_GETKB ;
        IF C = CR_ATTENCHAR
          THEN
            BEGIN
            MENU ;
            IF NOT (CR_CARRIER OR DONE)
              THEN
                CR_ANSWER ;
            END
          ELSE
            BEGIN
            CR_PUTREM( C ) ;
            IF ECHO
              THEN
                DISPLAY( C ) ;
            if linefeed and (C=chr(CR)) then
              cr_putrem(chr(LF));
            END ;
        END ;
    IF NOT CR_CARRIER
      THEN
        BEGIN
        WRITELN ;
        WRITELN('LOST CARRIER');
        WRITELN ;
        MENU ;
        IF NOT (CR_CARRIER OR DONE)
          THEN
            CR_ANSWER ;
        END
      ELSE
        IF CR_REMSTAT
          THEN
            DISPLAY( CR_GETREM ) ;

  UNTIL DONE ;

  writeln('====================     ',
          'end communication        ',
          '     ====================');
  
  CLOSELOG ;

  close(printfile);
  
  CR_COMMQUIT ;
  writeln('Exit TOMUSUS');

END.


========================================================================================
DOCUMENT :usus Folder:VOL15:vol15.doc.text
========================================================================================

                                 USUS Volume 15
                            
                            Communications software
                                        
HSM.UROOT.TEXT    22  A RemoteUnit for the Hayes SmartModem (uses UNITSTATUS)
HSM.UINC1.TEXT    16    an include file of HSM.UROOT.TEXT
STD.UNIT.TEXT     24  A RemoteUnit for a dumb modem         (uses UNITSTATUS)
TERM.MAIN.TEXT    20  Bob Peterson's terminal emulator program
TERM.LOG.TEXT     14    an include file of TERM.MAIN.TEXT
HSM.UINC2.TEXT    14      ditto
TERM.EMUL.TEXT    10      ditto
TERM.INIT.TEXT    22      ditto
TERM.UTIL.TEXT    22      ditto
CONTENTS.TEXT     14  Documentation for TERM.MAIN and Bob's RemoteUnits
SMTREMV5.TEXT     26  A terminal emulator specific to the LSI-11
IOUNIT.TEXT        8    a unit for SMTREMV5.TEXT
TOMUS4.C2.TEXT    24  Mike Ikezawa's terminal emulator
REMUNIT.L3.TEXT   28    Mike's RemoteUnit (specific to an LSI-11)
SET_BREAK.TEXT     4    an external procedure for REMUNIT.L3.TEXT
CLR_BREAK.TEXT     4      ditto
TOMUS3.C1.TEXT    10    comments for TOMUS4.C2.TEXT
TOMUS3.A.TEXT     22  Documentation for TOMUS4.C2.TEXT
COMM.TEXT         24  Jon Bondy's terminal emulator     
REMTALK.TEXT      24  A program to transfer files between two closely coupled
                        UCSD computers at a reasonable rate.
TELETALKER.TEXT   24  Randy Bush's Communications program.  Uses a RemoteUnit.
A.///.REMU.TEXT   72  Arley Dealey's Remote Unit for the Apple ///
VOL15.DOC.TEXT    14  You're reading it.
-----------------------------------------------------------------------------
Please transfer the text below to a disk label if you copy this volume.

    USUS Volume 15 -***- USUS Software Library
                         
   For not-for-profit use by USUS members only.
  May be used and distributed only according to 
      stated policy and the author's wishes.



This volume was assembled by George Schreyer from material collected by
the Library committee.

__________________________________________________________________________

Some notes from the editor:

     This volume contains a whole bunch of communications software.  I put it
all in one volume so that users interested in terminal emulators and such
could get a lot for very little investment.

     Several of the programs use Remote Units.  A Remote Unit is a pre-
compiled module which contains the implementation and hardware specific
interface for remote communications.  This unit follows a USUS standard, found
in News Letter #5.  Once a user writes a remote unit for his particular
processor, anybody else's terminal emulator will work (assuming that the
terminal emulator follows the standard also).  In principle this should work,
and lo and behold, it really does.  I have used Mike Ikezawa's remote unit to
test the other emulators on this disk which also follow the standard, but
which had never been used on a LSI-11 before.

                                   TERM.MAIN

     This is Bob Peterson's terminal emulator program.  It uses a standard
remote unit.  He has provided two which work with his POLYMORPHIC (8080)
computer.  One handles a Hayes SmartModem and the other is for a dumb modem.
You will may have to modify the IMPLEMENTATION part of Bob's RemoteUnit to
work with your computer but this about the most standard version of a remote
unit possible.  It requires IV.0 to work.  If you have an LSI-11, you can use
Mike's RemoteUnit instead.

                                 TOMUS4.C2.TEXT

     This is Mike Ikezawa's terminal emulator program.  It started life as an
old version of Bob's TERMINAL program.  Mike has extensively reworked it and it
doesn't even look the same.  Mike's REMUNIT.L3.TEXT is his remote unit.  I
modified it slightly to conform to the published standard (USUS NL#5) and
it can be used with Bob's program also.  I couldn't test Bob's unit with 
Mike's program as Bob's unit won't work as is with my LSI-11.

     Mike's unit uses two external procedures to set and clear the break bit. 
Since it depends on UNITSTATUS, it will not work with version II.0 (where
UNITSTATUS doesn't exist).  However it could be modified to use UNITBUSY (as it
used to) if desired.

                                      COMM

     This is Jon Bondy's terminal emulator program.  I couldn't test it as it
is specific to his Z-80 adaptable system.  You'll have to modify it and write
some external procedures to use it.

                              SMTREMV5 and IOUNIT

     Way back on Volume 2A there is a program called SMTREMOTE.  It didn't
work. Besides that it was extremely LSI-11 dependant.  It was also somewhat of
a kludge.  However, since it was the closest thing that I had at that time to a
terminal emulator for my LSI-11 on the p-system, I dug in and REALLY hacked it
up.  It is still a kludge, and it is still VERY LSI-11 dependent, but at least
it now works.  It is also dependent on an H-19 as it uses the status line and
function keys.

     It does some of its i/o in the strangest fashion, with trick records which
allow direct access to the hardware buffers.  All this brouha is contained in a
unit, IOUNIT.TEXT, which in no way is anything like a remote unit.

                                    REMTALK

     RemTalk is a program to allow two closely-coupled UCSD computers to
transfer files back and forth.  It includes error checking and will work at
9600 baud even with slow computers (like my H-89 for example, which is about as
slow as they come).  However, even at 9600 baud, the actual data rate is much
slower, about 5 seconds per block due to the handshaking and error checking,
it would probably be painfully slow at 300 baud.

                                   TELETALKER

     This is Randy Bush's communication submission.  It also requires a remote
unit (he supplied one for a MicroEngine which will appear on a future Volume).  
I tested it with Mike's remote unit for the -11.  I think that TeleTalker could 
use a little work.  By the way, in case that fire it up and can't figure how 
to make it quit, try cntl-A.
     
                                                      regards - gws


========================================================================================
DOCUMENT :usus Folder:VOL16:8.inch.text
========================================================================================

PROGRAM WRITLABELS;
USES (*$U crtinput.code*) CRTINPUT;

CONST
  LinesPerLabel = 12;
  Labelwidth = 50 {pica characters};

VAR
  LabelsPerSheet: integer;
  ch: char;
  WantsDECFormat: boolean;
  TypedIn, VolumeLine: STRING;
  DECNote: string;
  S: ARRAY [1..LinesPerLabel] OF string;
  List: text;
  

PROCEDURE GetVolumeData;
VAR     OK: boolean;
BEGIN
  REPEAT
    ClearScreen;  Gotoxy(0,12);  TypedIn := '';  WantsDECFormat := false;
    Writeln('You are set up for ', LabelsPerSheet , ' labels per sheet.');
    Write ('Please type volume number:  ');  GetString (2, TypedIn);
    VolumeLine := CONCAT ('          VOLUME ', TypedIn, ' -***-  ');
    Writeln;
    Write (
'Is the disk format: U)CSD, C)P/M, or W)estern Digital ("U", "C", or "W")? ');
    REPEAT Read (keyboard,ch) UNTIL (ch IN ['U','u','C','c','W','w']);
    CASE ch OF
      'U', 'u':  BEGIN
                   WantsDECFormat := true;
                   VolumeLine := CONCAT (VolumeLine, 'UCSD format')
                 END;
      'C', 'c':  VolumeLine := CONCAT (VolumeLine, 'CP/M format');
      'W', 'w':  VolumeLine := CONCAT (VolumeLine, 'W/D format')
    END;
    Writeln;
    Writeln ('The new label is "', VolumeLine,'".');
    OK := Yes ('Answer when ready to print:  is this label correct');
    IF NOT OK THEN IF Yes('Want to quit') THEN EXIT(program)
  UNTIL OK
END;


PROCEDURE DoWrite;
VAR     LabelNo, i, j: integer;
BEGIN
  IF VolumeLine = '' THEN GetVolumeData 
    ELSE BEGIN
      Gotoxy(0,0);  UnitClear(1);
      IF Yes ('Do you want to print the same label again')
        THEN GoAndClearLine(0)
        ELSE IF Yes('Want to quit') THEN EXIT(program) ELSE GetVolumeData;
    END;
  IF WantsDECFormat THEN i := 11 ELSE i := 12;
  FOR LabelNo := 1 to LabelsPerSheet DO
    BEGIN
      Writeln(List,VolumeLine);  IF WantsDECFormat THEN Writeln(List,DECNote);
      FOR j := 2 TO i DO Writeln(list, S[j]);
      IF (LabelNo MOD 2 = 0) AND (LabelsPerSheet = 3) THEN Writeln(list);
    END;
  FOR j := 1 to 6 DO Writeln(list) {eject sheet};
END;


BEGIN {main program}
  S [2]  := '';
  S [3]  := '              USUS Software Library               ';
  S [4]  := '               Jim Gagne, Chairman';
  S [5]  := '              DATAMED RESEARCH, INC.';
  S [6]  := '          Los Angeles, California 90077';
  S [7]  := '';
  S [8]  := '   For not-for-profit use by USUS members only.';
  S [9]  := '   May be used & distributed only according to';
  S [10] := '     the authors'' wishes and stated policy.';
  S [11] := '';
  S [12] := '';
  DECNote :=' (ie, Skew = 6; Interleave = 2; First track = 1) ';
  Write ('How many labels per sheet? ');  Readln(LabelsPerSheet);
  VolumeLine := '';  Rewrite (list, 'PRINTER:');
  REPEAT DoWrite UNTIL false
END.


========================================================================================
DOCUMENT :usus Folder:VOL16:add.text
========================================================================================

{       

Program: Inv
         an inventory maintanence program.
         
Programmer: Patrick R. Horton

Copyright: Copyright 1980 (c), Associated Computer Industries
           Permission to copy and distribute for non-profit
           purposes is hereby granted provided that this header
           is included on all copies
           
}

{ADD.TEXT}                                   
SEGMENT PROCEDURE Add;
 VAR ininv: BOOLEAN; 
     irecnum : INTEGER;
     ch : CHAR;
 
 PROCEDURE Addinvrec; 
  BEGIN
   WRITELN;
   WRITELN('part #',arcfile^.partnum,' was not found.'); 
   WRITE('do you wish to add an inventory record? ');
   READ(ch);
   IF NOT(ch IN ['Y','y']) THEN EXIT(Add);
   
   Clear; 
   GOTOXY(0,10); WRITELN('part number ',arcfile^.partnum);
   GOTOXY(0,0);
   WRITE('enter the description --->'); 
   Rdata(26,0,24,invfile^.descrip);
   GOTOXY(0,1);
   WRITE('enter the vendor part number --->');
   Rdata(33,1,16,invfile^.vpart);
   GOTOXY(0,2);  
   WRITE('what are the units of distribution --->');
   Rdata(39,2,5,invfile^.units); 
   invfile^.qty := 0;
   invfile^.partnum := arcfile^.partnum;
   nirecs := nirecs + 1;
   SEEK(invfile,nirecs);  
   PUT(invfile);
   irecnum := nirecs;
   Wnirecs;
  END; 
  
  PROCEDURE Getqtydateandcode;  
   BEGIN
    Clear;
    Clrline(0,7);  
    WRITELN(invfile^.descrip);
    WRITELN;
    WRITELN('part # : ',arcfile^.partnum); 
    WRITELN('present qty: ',invfile^.qty:8:2,' ',invfile^.units);    
    WRITELN;
    WRITE('enter qty in transaction ---->');           
    Getreal(0,0,arcfile^.qty);  
    Clrline(0,16);
    WRITE('enter the transaction code --->'); 
    Rdata(31,16,10,arcfile^.code);
    REPEAT
     Clrline(0,17);WRITE('enter the transaction date MMDDYY --->');  
     Rdata(38,17,6,arcfile^.date);
    UNTIL Chkdate(arcfile^.date);
   END; 
   
  PROCEDURE Putrecs;
   BEGIN
    narecs := narecs + 1;
    ntrans := ntrans + 1;
    Str(ntrans,arcfile^.trans);
    SEEK(arcfile,narecs);
    PUT(arcfile);
    SEEK(invfile,irecnum);
    PUT(invfile);
    Wnarecs; 
   END;
 
 BEGIN  
  Clear;
  WRITE('enter part # of items to be added to inventory --->');  
  Rdata(51,0,16,arcfile^.partnum);  
  ininv := FALSE; 
  FOR temp := 1 TO nirecs DO
   BEGIN
    SEEK(invfile,temp);
    GET(invfile);
    IF invfile^.partnum = arcfile^.partnum THEN  
     BEGIN
      irecnum := temp;
      ininv := TRUE;
      temp := nirecs; 
     END;
   END;
  IF NOT ininv THEN Addinvrec;
  Getqtydateandcode;  
  invfile^.ldate := arcfile^.date;  
  WRITELN;
  WRITELN('old qty =',invfile^.qty:8:2,' ',invfile^.units,'    ',   
          'new qty =',(invfile^.qty+arcfile^.qty):8:2,' ',invfile^.units);    
  invfile^.qty := invfile^.qty + arcfile^.qty;
  WRITELN;
  WRITE('O.K.? '); 
  READ(ch); 
  IF NOT (ch IN ['Y','y']) THEN EXIT(Add); 
  Putrecs;
 END;


========================================================================================
DOCUMENT :usus Folder:VOL16:apple.labl.text
========================================================================================

program TypeAppleLabels;
uses (*$U crtinput.code *) crtinput;

const
        maxlines = 7;           {lines per label}
        needxtraline = true;    {if actual lines per label include a 1/2 line}
        maxcol = 45;            {characters per label}
        forever = false;
        
type
        arraylmt = 1..maxlines;

var
        firsttime: boolean;
        totallines, labelno: integer;
        volumeno: string [5];
        s: ARRAY [arraylmt] OF string;
        list: text;


procedure printlabel;
VAR     i, j: integer;
BEGIN
  S[2] := CONCAT ('VOLUME ', volumeno, ' -**- APPLE format');
  FOR labelno := 1 to 4 DO                      {print one pair of labels}
    BEGIN
      FOR i := 1 to maxlines DO
        BEGIN
          j := (MaxCol - Length(s[i])) DIV 2;
          IF j > 0 THEN Write(list,' ':j);  writeln(list, s[i])
        END;
      IF needxtraline AND (labelno = 2) THEN Writeln (List);
    END;
  FOR I := 1 TO 6 DO WRITELN(LIST)
END;


PROCEDURE GetLabel;
BEGIN
  Write ('For what APPLE volume do you wish labels? <ret> to quit ');
  Readln (Volumeno);
  IF Volumeno = '' THEN EXIT (program)
END;


BEGIN
  s[1] := 'USUS SOFTWARE LIBRARY';
  s[3] := 'Jim Gagne, Chairman';
  s[4] := 'DATAMED RESEARCH, INC.';
  s[5] := 'Los Angeles, CA 90077';
  s[6] := 'For use by USUS members only.';
  s[7] := 'May not be published for profit.';
  Rewrite (list, 'PRINTER:');  FirstTime := true;
  REPEAT
    IF FirstTime THEN GetLabel
      ELSE IF NOT Yes('Want the same label again') THEN GetLabel;
    Printlabel;  FirstTime := false
  UNTIL forever;
END.


========================================================================================
DOCUMENT :usus Folder:VOL16:ase.header.text
========================================================================================

(* ASE File Header Page  12 Jul 82
                                   |xjm$v|nx|f8|ejb|. *)

(* This is the current (ASE 0.4 through ASE 0.9) version of the ASE
   Header Page which is the first two blocks of an ASE text file.
   Please note that it may be changed in the future, and the first
   field will be used to reflect this change.                       *)


PROGRAM ASEHeaderPage (INPUT, OUTPUT);

TYPE

  MarkRange         = 0..29;   (* Marker Numbers *)
  MSwRange          = 0..135;  (* Maximum ScreenWidth *)
  Offset            = 0..1023; (* Byte offset within a page *)
  Name              = PACKED ARRAY [0..7] OF CHAR;  (* of a Marker *)
  TabAttribute      = (None, LeftJust, RightJust, DecimalStop);

  DateRec           = PACKED RECORD  (*As used by rest of UCSD system*)
      Month         : 0..12;
      Day           : 0..31;
      Year          : 0..100
      END;

  Content           = RECORD
      Defined       : INTEGER;  (* Current version is 4 *)
      Count         : INTEGER;  (* Count of valid markers *)
      MarkName      : ARRAY [MarkRange] OF Name;
      PageN         : ARRAY [MarkRange] OF INTEGER;
      POffset       : ARRAY [MarkRange] OF Offset;
      TabStop       : PACKED ARRAY [0..127] OF TabAttribute;
      AutoIndent    : BOOLEAN;
      Filling       : BOOLEAN;
      TokDef        : BOOLEAN;
      LMargin       : MSwRange;
      RMargin       : MSwRange;
      ParaMargin    : MSwRange;
      RunOffCh      : CHAR;
      Created       : DateRec;
      LastUpd       : DateRec;
      Revision      : INTEGER;
      AutoPage      : BOOLEAN
      END;
  
  Header            = RECORD CASE INTEGER OF
    0 : ( Dummy     : ARRAY [0..511] OF INTEGER );
    1 : ( Data      : Content )
    END;

BEGIN (* ASEHeaderPage *)
  WRITELN ('Actual size of used Data Content is ', SIZEOF(Content), ' Bytes');
  WRITELN ('Size of a Header Page is ', SIZEOF(Header), ' Bytes')
  END (* ASEHeaderPage *).

========================================================================================
DOCUMENT :usus Folder:VOL16:basproc.text
========================================================================================

{       

Program: Inv
         an inventory maintanence program.
         
Programmer: Patrick R. Horton

Copyright: Copyright 1980 (c), Associated Computer Industries
           Permission to copy and distribute for non-profit
           purposes is hereby granted provided that this header
           is included on all copies
           
}

{BASPROC.TEXT}                                                                
              
FUNCTION rVal{(s : STRING) : REAL};      
 VAR intr,ints : REAL; 
     ts : STRING;
 BEGIN 
  ts := s;
  intr := 0; 
  ints := 0;
  intr := intr + TRUNC(Val(ts));   
  IF POS('.',ts)<>0 THEN
   BEGIN
    DELETE(ts,1,POS('.',ts));   
    ints := TRUNC(VAL(ts));  
    WHILE ints>1 DO ints := ints / 10;    
    WHILE POS('0',ts)=1 DO  
     BEGIN
      DELETE(ts,1,1); 
      ints := ints/10;
     END;
    END;
  rVal := intr + (ABS(intr)/intr)*ints;  
 END;

 {$I-}
 FUNCTION Chkfiles(s : STRING) : BOOLEAN;      
  VAR intb : BOOLEAN;
      infile : FILE;
  BEGIN 
   intb := TRUE;     
   RESET(infile,s);       
   IF IORESULT <> 0 THEN intb := FALSE;
   CLOSE(infile);
   Chkfiles := intb; 
  END;  
{$I+}

PROCEDURE Readingroups;   
 VAR gfile : TEXT;
     line : STRING;
     optr,tptr : ^xrerec; 
     added : BOOLEAN;
 BEGIN   
  first := NIL;
  IF NOT Chkfiles('#4:gfile.text') THEN EXIT(Readingroups);
  RESET(gfile,'#4:gfile.text');
  WRITE('Reading in gfile ');
  WHILE NOT EOF(gfile) DO  
   BEGIN
    WRITE('.');
    READLN(gfile,line);
    NEW(ptr);  
    WHILE POS(' ',line)=1 DO DELETE(line,1,1);  
    ptr^.part1 := COPY(line,1,POS(' ',line)-1); 
    DELETE(line,1,POS(' ',line));
    WHILE POS(' ',line)=1 DO DELETE(line,1,1);
    ptr^.part2 := COPY(line,1,POS(' ',line)-1);       
    DELETE(line,1,POS(' ',line));
    WHILE POS(' ',line)=1 DO DELETE(line,1,1);
    ptr^.qty := rVal(line); 
    tptr := first; 
    optr := NIL;
    added := FALSE; 
    WHILE (tptr <> NIL) AND (NOT added) DO    
     BEGIN
      IF tptr^.part2 <=  ptr^.part2 THEN 
       BEGIN
        IF optr<>NIL THEN  
         BEGIN
          ptr^.link := tptr;
          optr^.link := ptr; 
          added := TRUE;
         END 
        ELSE
         BEGIN
          ptr^.link := first;  
          first := ptr;
          added := TRUE;
         END;
       END  
      ELSE
       BEGIN 
        optr := tptr;
        tptr := tptr^.link;  
       END;  
     END;  
     IF NOT added THEN    
      IF optr = NIL THEN 
       BEGIN
        ptr^.link := first;
        first := ptr;
       END
      ELSE
       BEGIN
        ptr^.link := NIL;
        optr^.link := ptr;       
       END;
   END (* of file *);   
 CLOSE(gfile); 
END; 
 
PROCEDURE Wnirecs;         
 BEGIN  
  Str(nirecs,invfile^.ldate);
  SEEK(invfile,0);  
  PUT(invfile);
 END;
   
PROCEDURE Wnarecs;
 BEGIN
  Str(ntrans,arcfile^.trans);
  Str(narecs,arcfile^.date);   
  SEEK(arcfile,0);    
  PUT(arcfile);  
 END;
 
PROCEDURE Uppercase{(VAR s: STRING)};       
 VAR t : INTEGER;
 BEGIN
  FOR t := 1 TO LENGTH(s) DO
   IF s[t] IN ['a'..'z'] THEN s[t] := CHR(ORD(s[t])-32);      
 END;

PROCEDURE Clear;                      
 BEGIN   
  gotoxy ( 0, 0 );
  WRITE(CHR(27),chr ( 69 ));   {h-19 specific}               
 END; 
  
PROCEDURE Clrline{(x,y : INTEGER)};   
 BEGIN
  GOTOXY(x,y);WRITE(CHR(27),chr ( 75 )); {H-19 specific}               
 END;    

FUNCTION Val{ (s : STRING) : INTEGER};                   
 VAR i,j,k: INTEGER;                     
 BEGIN   
  j := 0; k := 0; i := 1;         
  IF LENGTH(s)<>0 THEN
   BEGIN  
    IF (LENGTH(s)>0) AND (s[1] = '-') THEN BEGIN k := k + 1;i := -1;END;              
    IF k<LENGTH(s) THEN      
     REPEAT
      k := k + 1; 
      IF (k<=LENGTH(s)) AND (s[k] IN ['0'..'9']) THEN    
       BEGIN
        j := j * 10; 
        j := j + ORD(s[k]) - 48;
       END; 
     UNTIL (k=LENGTH(s)) OR NOT(s[k] IN ['0'..'9']);        
   END;
  Val := i*j;   
 END (* Val *);          
        
PROCEDURE Str{(i : INTEGER, VAR s : STRING)};   
 VAR startedstring : BOOLEAN;  
     factor        : INTEGER;
     numstr        : STRING[9];
 BEGIN 
  s := '';
  IF i < 0 THEN
   BEGIN
    s := '-';
    i := - i;
   END;
  numstr := '123456789';
  startedstring := FALSE; 
  factor := 10000;
  WHILE factor<>0 DO    
   BEGIN
    IF i >= factor THEN   
     BEGIN
      s := CONCAT(s,COPY(numstr,i DIV factor,1));        
      i := i - (i DIV factor)*factor;                 
      startedstring := TRUE;
     END
    ELSE IF startedstring THEN s := CONCAT(s,'0');
    factor := factor DIV 10;
   END;  
  IF LENGTH(s) = 0 THEN s := '0';    
 END;  
  

PROCEDURE Rdata{(x,y,l : INTEGER; VAR s: STRING)};                 
 VAR tmpstr : STRING;
 BEGIN  
  REPEAT
   IF (x<>0) OR (y<>0) THEN
    BEGIN   
     Clrline(x,y);
     WRITE(' ':l,'<');                      
     GOTOXY(x,y);
    END;    
   READLN(tmpstr);   
  UNTIL LENGTH(tmpstr)<=l;    
  IF POS('^',tmpstr)=0 THEN s := tmpstr;                                                                     
  IF (x<>0) OR (y<>0) THEN
   BEGIN                   
    Clrline(x,y);
    WRITE(s);  
   END;
 END;         
       
PROCEDURE Getint{(x,y : INTEGER; VAR t1 :INTEGER)};                    
 VAR tstr : STRING;
 BEGIN   
  Str(t1,tstr);
  Rdata(x,y,6,tstr);
  t1 := Val(tstr);
 END;

PROCEDURE Getreal{(x,y : INTEGER; VAR r : REAL)};
 VAR tmpstr : STRING; 
 BEGIN
  Rdata(x,y,8,tmpstr);
  r := rVal(tmpstr);
 END;
 
FUNCTION Chkdate{(s: STRING):BOOLEAN}; 
 VAR intb : BOOLEAN;
 BEGIN
  intb := FALSE;
  IF (Val(COPY(s,1,2))>0) AND (Val(COPY(s,1,2))<12)
     AND (Val(COPY(s,3,2))>0) AND (Val(COPY(s,3,2))<32)    
     AND (Val(COPY(s,5,2))>70) AND (Val(COPY(s,3,2))<90)         
     AND (LENGTH(s)=6) THEN intb := TRUE;
  Chkdate := intb;
 END;


 

PROCEDURE Initfiles;
 
 (*$I-*) 
 
 PROCEDURE Makefile( s : STRING);       
  TYPE tarry = ARRAY[1..512] OF 0..15; 
  VAR  tafile : FILE;     
       ttarry : tarry;
       temp1,temp   : INTEGER;
  BEGIN
   WRITE('Making : ',s);
   REWRITE(tafile,s);  
   FOR temp := 1 TO 512 DO ttarry[temp] := 0; 
   temp := 0;
   REPEAT            
    WRITE('.'); 
    temp1 := BLOCKWRITE(tafile,ttarry,1);     
    temp := temp + 1;   
   UNTIL (temp1=0) OR (temp>=242) OR (IORESULT<>0);                 
   WRITELN;
   CLOSE(tafile,lock); 
  END;
 (*$I+*)        
 
 BEGIN  
  IF (NOT Chkfiles('#5:inv.data')) AND (NOT Chkfiles('#5:arc.data')) THEN    
   BEGIN
    WRITELN('Program: Inv');   
    WRITELN('an inventory maintanence program.');  
    WRITELN;  
    WRITELN('Programmer: Patrick R. Horton '); 
    WRITELN;  
    WRITELN('Copyright: Copyright 1980 (c), Associated Computer Industries '); 
    WRITELN('Permission to copy and distribute for non-profit '); 
    WRITELN('purposes is hereby granted provided that this header '); 
    WRITELN('is included on all copies '); 
    WRITELN;  
    WRITELN('place a formatted and zeroed diskette in drive #5:');       
    WRITE('<cr> when ready ');
    READLN; 
    Makefile('#5:inv.data[*]');  
    Makefile('#5:arc.data[0]'); 
   END
  ELSE IF NOT Chkfiles('#5:inv.data') THEN   
   BEGIN
    WRITELN('<cr> to create ''#5:inv.data''');
    READLN;
    Makefile('#5:inv.data[]')     
   END  
  ELSE IF NOT Chkfiles('#5:arc.data') THEN 
   BEGIN
    WRITELN('<cr> to create ''#5:arc.data'''); 
    READLN;
    Makefile('#5:arc.data[]')   
   END;
     
  RESET(invfile,'#5:inv.data');
  RESET(arcfile,'#5:arc.data');   
  SEEK(invfile,0);
  GET(invfile);
  SEEK(arcfile,0);
  GET(arcfile);
  narecs := Val(arcfile^.date);
  nirecs := Val(invfile^.ldate);
  ntrans := Val(arcfile^.trans);
  
  Readingroups;
 END;
 
PROCEDURE Closefiles;
 BEGIN
  CLOSE(invfile);  
  CLOSE(arcfile); 
 END;



========================================================================================
DOCUMENT :usus Folder:VOL16:basproc2.text
========================================================================================

{     

Program: Inv
         an inventory maintanence program.
         
Programmer: Patrick R. Horton

Copyright: Copyright 1980 (c), Associated Computer Industries
           Permission to copy and distribute for non-profit
           purposes is hereby granted provided that this header
           is included on all copies
           
}

{BASPROC2.TEXT}                             

PROCEDURE Change;
 VAR temp : INTEGER;
     opartnum,npartnum : STRING[16];
     ch : CHAR;
 BEGIN 
  Clear;
  WRITE('Change :: I)nventory, A)rchive, B)oth ::');
  READ(ch);
  IF ch IN ['I','i','A','a','B','b'] THEN
   BEGIN
    Clrline(0,2); 
    WRITE('enter partnumber to be changed --->');
    Rdata(35,2,16,opartnum); 
    Clrline(0,3);
    WRITE('enter new partnumber ------------->'); 
    Rdata(35,3,16,npartnum);
    IF (opartnum='') OR (npartnum='') THEN EXIT(Change);
    CASE ch OF
     'I','i' : BEGIN
                WRITELN;
                WRITE('searching inventory');
                FOR temp := 1 TO nirecs DO 
                 BEGIN
                  SEEK(invfile,temp);
                  GET(invfile);
                  IF invfile^.partnum = opartnum THEN 
                   BEGIN
                    invfile^.partnum := npartnum;     
                    SEEK(invfile,temp);
                    PUT(invfile);
                   END;
                  WRITE('.');
                 END;
                WRITELN;
               END;
     'A','a' : BEGIN
                WRITELN;
                WRITE('searching archive');
                FOR temp := 1 TO narecs DO 
                 BEGIN
                  SEEK(arcfile,temp);
                  GET(arcfile);
                  IF arcfile^.partnum = opartnum THEN 
                   BEGIN
                    arcfile^.partnum := npartnum;                    
                    SEEK(arcfile,temp);        
                    PUT(arcfile);
                   END;
                  WRITE('.');
                 END;
                WRITELN;
               END;
     'B','b' : BEGIN
                WRITELN;
                WRITE('searching inventory');
                FOR temp := 1 TO nirecs DO 
                 BEGIN
                  SEEK(invfile,temp);
                  GET(invfile);
                  IF invfile^.partnum = opartnum THEN 
                   BEGIN
                    invfile^.partnum := npartnum;
                    SEEK(invfile,temp);
                    PUT(invfile);
                   END;
                  WRITE('.');
                 END;
                WRITELN;
                WRITELN;
                WRITE('searching archive');
                FOR temp := 1 TO narecs DO 
                 BEGIN
                  SEEK(arcfile,temp);
                  GET(arcfile);
                  IF arcfile^.partnum = opartnum THEN 
                   BEGIN
                    arcfile^.partnum := npartnum;
                    SEEK(arcfile,temp);
                    PUT(arcfile);
                   END;
                  WRITE('.');
                 END;
                WRITELN;
               END;
           END {CASE}; 
       END {IF}; 
 END {Change}; 
 
PROCEDURE Delete;
 VAR temp,temp1 : INTEGER;
     dpartnum : STRING[16];
     ch : CHAR;
 BEGIN
  Clear;
  WRITE('Delete :: A)rchive, I)nventory, B)oth ::');
  READ(ch);
  IF ch IN ['A','a','I','i','B','b'] THEN
   BEGIN
    Clrline(2,0);
    WRITE('enter partnumber to be deleted ---->');                    
    READLN(dpartnum);
    CASE ch OF 
     'A','a' : BEGIN
                WRITELN;
                WRITE('searching archive');
                temp := 0; 
                FOR temp1 := 1 TO narecs DO
                 BEGIN
                  SEEK(arcfile,temp1);
                  GET(arcfile);
                  IF arcfile^.partnum<>dpartnum THEN
                   BEGIN
                    temp := temp + 1;
                    SEEK(arcfile,temp);
                    PUT(arcfile);
                   END;
                  WRITE('.');
                 END; 
                narecs := temp;
                Wnarecs;
                WRITELN;
               END;
     'I','i' : BEGIN
                WRITELN;
                WRITE('searching inventory');
                temp := 0; 
                FOR temp1 := 1 TO nirecs DO
                 BEGIN
                  SEEK(invfile,temp1);
                  GET(invfile);
                  IF invfile^.partnum <> dpartnum THEN
                   BEGIN
                    temp := temp + 1;
                    SEEK(invfile,temp);
                    PUT(invfile);
                   END;
                  WRITE('.');
                 END;
                nirecs := temp; 
                Wnirecs;
                WRITELN;
               END;
     'B','b' : BEGIN
                WRITELN;
                WRITE('searching archive');
                temp := 0; 
                FOR temp1 := 1 TO narecs DO
                 BEGIN
                  SEEK(arcfile,temp1);
                  GET(arcfile);
                  IF arcfile^.partnum<>dpartnum THEN
                   BEGIN
                    temp := temp + 1;
                    SEEK(arcfile,temp);
                    PUT(arcfile);
                   END;
                  WRITE('.');  
                 END; 
                narecs := temp;
                Wnarecs;
                WRITELN;
                WRITELN;  
                WRITE('searching inventory');  
                temp := 0;  
                FOR temp1 := 1 TO nirecs DO
                 BEGIN
                  SEEK(invfile,temp1);
                  GET(invfile);
                  IF invfile^.partnum <> dpartnum THEN
                   BEGIN
                    temp := temp + 1;
                    SEEK(invfile,temp);
                    PUT(invfile);
                   END;
                  WRITE('.');
                 END;
                nirecs := temp; 
                Wnirecs;
                WRITELN;
               END;
         END;
     END;
 END; 
 
PROCEDURE Sort;
 VAR ch : CHAR; 
     trec1,trec2 : invrec; 
 BEGIN (* Sort *)      
  Clear;
  WRITE('Are you sure you want to sort the inventory file ?');
  READ(ch);
  IF ch IN ['Y','y'] THEN
   BEGIN
    temp := 1;
    WRITELN;WRITELN('Sorting ');
    WHILE temp < nirecs DO   
     BEGIN
      WRITE('.');
      SEEK(invfile,temp);  
      GET(invfile);
      trec1 := invfile^;
      SEEK(invfile,temp+1);
      GET(invfile);
      IF (invfile^.partnum<trec1.partnum) THEN
       BEGIN
        SEEK(invfile,temp);
        PUT(invfile);
        invfile^ := trec1;
        SEEK(invfile,temp + 1);
        PUT(invfile);
        IF temp > 1 THEN temp := temp - 1; 
       END
      ELSE temp := temp + 1;
     END;
   END;
 END;
  

========================================================================================
DOCUMENT :usus Folder:VOL16:bdebug.text
========================================================================================

 (*------------------------------------------------------------------*)
 PROCEDURE errtrap (*errmsg:STRING*);
 (*         Print an error message and halt execution until 
                                        a <cr> is recieved.*)
 
 BEGIN
 
 WRITELN(' ***ERROR*** ',errmsg,' Hit <cr> to continue.');
 READLN;
 
 END; (*PROCEDURE errtrap*)
 
 (*------------------------------------------------------------------*)
 PROCEDURE bdump (*VAR r: brecord*);
 (*      Dump contents of r to terminal*)
 
 VAR      j:INTEGER; 
 
 BEGIN
         WITH r DO BEGIN
         CASE use OF
 
         0:BEGIN
           WRITELN('next free record available is  ',nextfree);
           END;(*case use=0*)
 
         1:BEGIN
           WRITELN('number of records in use  ', desc.nrec);
           WRITELN;
           WRITELN('number of records in btree  ', desc.maxrec);
           WRITELN;
           WRITELN('record number of btree root  ', desc.root);
         WRITELN;
         WRITELN('first free record in file     ', desc.freehead);
           END;(*case use=1*)
 
         2:BEGIN WITH r.pg DO BEGIN
           WRITELN('number of keys in this page  ', count);
           WRITELN;
           WRITELN('parent page is  ',prntpage);
           WRITELN;
           WRITELN('parent entry is  ',prntentry);
           WRITELN;
           WRITELN('first pointer in this page  ', bpointer[0]);
           WRITELN;
           WRITELN('            KEY','      DATA','   POINTER');
           
           FOR j:=1 TO count DO
              WRITELN(bentry[j].key:15,bentry[j].data:10,bpointer[j]:10);
           END; (* WITH *) END;(*case use=2*)
 
         END; (*CASE*)
         END;(*WITH*)
 
 END; (* PROCEDURE bdump *)
 (*------------------------------------------------------------------*)
 PROCEDURE showit(*VAR f:btree; pagenbr : btpointer; entrynbr : bpagesize*);
 (*      Display contents of tree f, at pagenbr,entrynbr , formatted *)
 
 VAR entry : btentry;
 
 BEGIN
 
 bread (f,pagenbr);
 entry := f^.pg.bentry[entrynbr];
 
 WRITE('Current: ');
 WRITELN('PAGE':11,'ENTRY':15,'KEY':15,'DATA':15);
 WRITELN(pagenbr:20,entrynbr:15,entry.key:15,entry.data:15);
 WRITELN;
 
 END; (*PROCEDURE showit*)
 



========================================================================================
DOCUMENT :usus Folder:VOL16:bdoc1.text
========================================================================================


                Documentation for B-Tree Unit
                

        The B-Tree is an ingenious storage structure used principally for
     maintaining ordered indices to files. It can also be used to maintain
     ordered data directly.  It was first reported by Bayer and McCreight
     in 1972, although it appears to be an outgrowth of a great deal of
     previous work on multi-way trees and ordered indices.
     
        The B-Tree is technically a height-balanced, muti-way tree. It is
     perhaps best explained by analogy to a binary tree. The single best
     explanation of both can be found in Niklaus Wirth's book Algorithms +
     Data Structures = Programs (although the Bayer and McCreight article
     is fairly accessible).  I will attempt to give a short course below.
     
        
                       What is a Binary Tree?
     
        A binary tree is a data structure in which each record (called a
     node) contains one datum, one key, and two pointers.  Each pointer
     points to a child node, which has pointers to two more children. When
     any pointer is null, you have reached a leaf. The first entry is
     called the root node. A Pascal declaration of a binary tree node
     might be:
     
           binary_tree_node = RECORD 
                                person_name : sometype; 
                                person_data : someothertype 
                                left_child, right_child : pointers; 
                              END;
     
        The person_name element would be the key, i.e. the part of the
     record used for ordering the records.  The person_data element would
     be the datum to be retrieved. Left_child and right_child are pointers
     to the children.  They are deliberately not declared as Pascal
     pointer types because they could be disk block numbers, or some other
     sort of pointer.
     
        An example of what such a tree might look like is shown below. The
     root is at the top (don't ask, it's the traditional representation
     of a tree). Only the person_name values are shown.
     
        
                                 john
                                   |
                        ___________|___________
                        |                      |
                _____frank______       ______mike________
                |              |       |                |
                |              |       |                |
      _______charlie        harlan   karla     ______susie_______
      |                                        |                |
    alan                                     roger            zelda


        As you can see, there is no requirement that a binary tree be
     balanced.  A balanced tree can be searched more quickly on the
     average, but it is very difficult to maintain balance in a binary
     tree.  In general the cost is greater than the payoff.
        
        
                         What is a B-Tree?
     
        A B-Tree is a multi-way tree.  It may have more than one key and
     more than one child per node.  Generally, there are fixed-size nodes
     which can be partly full. A simple Pascal declaration of a B-Tree
     node might be:
     
        
            B_Tree_node = RECORD
                            count : integer;
                            person_name1 : sometype;
                            person_data1 : someothertype
                            person_name2 : sometype;
                            person_data2 : someothertype
                            person_name3 : sometype;
                            person_data3 : someothertype
                            child0,
                            child1,
                            child2,
                            child3 : pointers;
                          END;
     
        Obviously, this could get out of hand, so some sort of array is
     usually used.  The count variable specifies how many of the key slots
     are filled.  Note that there is one more pointer than keys.  Although
     this is relatively intuitive in a schematic discussion, it can cause
     no end of trouble in writing or modifying a program if you forget. It
     sometimes helps to think of the nodes pictorially.  The node pictured 
     has room for 3 keys, of which 2 are in use:
     
       ________________________________________________________________
       |  ptr0  |  key1  |  ptr1  |  key2  |  ptr2  |  key3  |  ptr3  |
       |________|________|________|________|________|________|________|
                                                    ^
                                                    | count = 2
        
        
        A B-Tree node is generally called a page.  The ingenuity of the
     design begins with the page layout.  A B-Tree page is constrained to
     have between k and 2k entries, where k is an arbitrary number known
     as the order of the tree. Thus, a B-Tree of order 3 has slots for 6
     entries, and is guaranteed to have no fewer than 3 of those slots
     filled (an odd number is ok, it just dosn't fit the formal definition
     as well). The root page may have fewer than k entries. The advantage
     of multiple entries over a binary tree is analogous to that of a
     Shell sort over a straight insertion sort: fewer comparisons are
     needed to reach the general neighborhood of the key sought.
     
        Every page is either a leaf (no children) or it has j+1 children
     if it has j keys.  All leaves are at the same level, or height (or
     depth, pick your metaphor) as all other leaves. In other words, the
     tree is balanced.  The main trick is in keeping the tree balanced.
        
        
                The B-Tree's Balancing Act
     
        
        The binary tree has one major problem.  If it is completely
     balanced, the search time among N keys will be of order logN.  In the
     degenerate cases (either all right or all left children) the search
     time will be of order N. (This business about orders is called the
     asymptotic complexity of algorithms.  If you don't know about it, you
     probably should find someone who can explain it.  I know of no easy
     text on the subject.) The degenerate case occurs when insertions are
     performed in sorted order, and the closer to sorted order the keys
     are when you start, the worse the performance of the binary tree.
     
        The B-Tree avoids the degeneration by staying balanced, and thus
     its worst case performance is about as good as the average for a
     binary tree.  In a B-Tree of order k, with N entries, the worst case
     search time for an entry is of order log to the base k of (N+1).
     
        Balance is maintained during insertion as follows: Insertion
     always occurs at a leaf.  This is not obvious, so make a diagram of a
     B-Tree and try it.  No matter what key you choose to insert, it will
     always lie between two keys already in the tree (except in the
     degenerate case of a tree containing 0 or 1 entries in the root, in
     which case you are at a leaf by definition).  Every entry in a non-
     leaf node always points to an entry which is greater and one which is
     smaller.  If the node pointed-to is a leaf, then you are at a leaf. 
     If not, then a greater and a lesser entry are pointed-to, and so on. 
     It works out that the entry immediately before or after any entry in
     the tree is always at a leaf node.
     
        If the leaf is not full, the insertion is made at the appropriate
     place in the page.  If the node is full, the central entry in the
     node is inserted into the parent node, and the leaf's keys are
     distributed between it and new leaf which is allocated dynamically
     (thus creating two leaf nodes from one).  The insertion is then made
     in the appropriate one of the two leaf nodes.  However, the parent
     page may also be full.  The same routine occurs with insertion into
     the parent node.  If all successive parent nodes are full, the split
     can propagate all the way to the root, causing the tree to grow one
     level in height (i.e. every path from root to leaf becomes one
     longer).
     
        Deletion proceeds similarly, but for the complication that a key
     to be deleted may not be at a leaf node.  If it is at a leaf node, it
     is simply deleted.  If the key is not at a leaf node, it is swapped
     with the next greater or smaller key, which is guaranteed to be at a
     leaf node for the reasons discussed above.  If the page count is at
     least k, we are done.  If the page count has fallen below k, then we
     would be violating the page fullness constraint, so we boost the
     count by borrowing from adjacent siblings.  This is generally called
     balancing.  Of course, if there are fewer than m times k entries to
     distribute among m siblings, we would still have fewer than k entries
     in a node.  The solution is to delete one node, and distribute its
     keys among the remaining m minus 1 siblings.  As with splitting, this
     concatenation can propagate when the parent suffers loss of an entry
     from having one child fewer than before.  The tree shrinks in height
     when the root is concatenated with its two children. 
     
        
                   Implementation Considerations
     
        There are a number of performance considerations in implementing B-
     Trees that deserve mention.  First, one may choose to implement B-
     Trees entirely in main memory (as is the case shown in most examples) 
     or in secondary storage (which is their principal real-world use). 
     For indices of any serious size, a disk implementation is called
     for.  This means that one must consider optimizing the fetching of
     pages into main memory.  Several common methods include:
     
        - Always keeping the root in memory (rewriting it when it is
          changed) since all searches start at the root.  
     
        - Making pages an even multiple of the hardware page size, so that 
          fast primitive fetches can be used.
        
        - Delaying the splitting of pages just as concatenation is delayed
          by balancing among adjacent siblings. (Knuth, pp 476-479)
     
        - Buffering disk i/o, usually by keeping the most recently used
          pages in main memory (in a sequential search, you will revisit 
          a non-leaf node once for every node it points to).
        
        
        Second, one would probably like generality of use.  The easiest 
     way to achieve some generality is not to mix the data into the tree,
     but to maintain some sort of pointer to the data. One could go so far
     as not to keep the keys in the tree either, in order to allow
     variable length keys.  In both cases, the pointers would point into 
     some separately maintained (and unordered) list.  
        
        Finally, you can add lots of stuff to the basic idea, and tune the 
     program lots of ways. For example, you could allow for duplicate 
     instances of a particular key by some sort of chaining; or perform 
     some kind of compression on the keys (compression plus duplicates 
     could even be used to allow variable length keys).  Different 
     strategies can be used for splitting, shifting entries around, 
     balancing, etc.  Some have been elevated to the status of a whole 
     separate kind of tree (B+ and B* trees, see Comer).
     
        
        The B-Tree Unit (BUNIT)
        
        
        The B-Tree unit presented here has been run with only trivial
     modifications on three different p-Systems: It was developed on a
     bastard version II.0 p-System on an Onyx micro (a Z-8000, hard-disk
     machine), it was transported to a Northstar running version I.5, and
     it was transported to an Apple ][ running version II.1.  As far as I
     know it contains no machine or version dependencies.  
        
        BUNIT's essential character is described by the global 
     declarations.  The trees store a single datum, which is an integer.  
     It is envisioned that it would be a record or blocknumber on another 
     file storing the actual data.  A key is a string of length keysize. 
     Together, one key and one datum are a btentry. A page consists of
     btree2k btentry's stored in an array called bentry.  A parallel array
     called bpointer stores btree2kp (btree2k + 1) pointers, each of type
     btpointer.  Pages also contain a count of full keys, and pointers to 
     the page number of the parent page and the subscript of the pointer 
     to this page in the parent.
     
         Pages are allocated when a tree is created, and it stays a fixed 
     size.  The unit of allocation is actually a brecord, which has a 
     bpage as one variant. The other variants are bdescrip and btpointer.
     The zeroth brecord of a btree (a file of brecord) is always of the
     bdescrip variant.  It contains nrec: the last record ever used, 
     maxrec: a count of the number of records allocated, root: a pointer 
     to the root of the tree, and freehead: a pointer to the head of a 
     chain of records deallocated by concatenation of pages.  All records 
     in the free chain are of the btpointer variant; they contain a single 
     pointer to the next record in the chain.  A free pointer equal to 0 
     indicates the last record in the free chain.
        
        
        To use the unit without understanding it, very little 
     documentation is required.  The interface section contains 
     declarations and explanations of the routines accessible to the 
     application programmer.  To start a tree, call bnew with a filename 
     and a number of pages to allocate.  Bnew recloses the file, so bopen 
     it before using it.  All BUNIT procedures pass around the file id, so 
     more than one tree can be open at once.  To insert a key, just stick 
     it in a bentry, along with an appropriate datum, and call bsearch.  
     If you find it in the tree, don't insert it.  If it's not there, put 
     it in by calling binsert with the page and entry indices returned by 
     bsearch.  To delete a key, call bsearch to find out where it is, and 
     if you find it, call bdelete with the information from bsearch.
     
        Procedures firstentry and lastentry will return the position of 
     the first and last keys in the tree.  Functions nextentry and 
     preventry will move forward and backward along the tree.  Bdump will 
     display the contents of a brecord at your terminal, and showit will 
     display formatted information on a particular entry.
     
        



========================================================================================
DOCUMENT :usus Folder:VOL16:bdoc2.text
========================================================================================

        
        Understanding BUNIT
     
        Understanding the BUNIT well enough to modify it, for example,
     takes a little more effort.  The following is necessarily a little
     skimpy.  It is meant to be read while holding the listings in the
     other hand.  The program is layered, or built-up.  First a number of
     primitive operators were built.  The file BIO contains the i/o
     primitives, which were built first.  Should one want to implement
     buffering, for example, most of the changes would be isolated in
     these functions.  Of the BIO functions, only bnew is not obvious. It
     basically sets up the descriptor record, creates an empty root page,
     and marks page 2 as free, pointing back to the descriptor.  By
     seeking a record npages away, it allocates space, then closes the
     file with a lock to make it permanent.  The filesize allocated by
     bnew is what you are stuck with.  If the file cannot be opened, it
     returns a false result, otherwise it returns true.
     
        The next primitives implemented were those in BDEBUG. Errtrap is 
     called with an error message at points where "impossible" things are 
     about to occur. It does nothing except warn you and wait for a 
     carriage return.  Bdump and showit are fairly obvious.
     
        BHKEEP contains the next set of primitives implemented.  Broot 
     reads the descriptor record to find the page number of the root page 
     and returns that value.  Getpage is the dynamic page allocation 
     routine.  It examines the freehead variable in the descriptor page to 
     see if any free records are present.  If so, the first is removed 
     from the chain, and the various pointers updated to promote the next 
     record in the chain.  If the free chain is empty, it goes to the end 
     of the pages in use (pointed to by nrec in the descriptor).  If 
     there are no records left, it calls errtrap.  Note that it only 
     allocates up to the number of records set when bnew was called.
     
        Freepage does the reverse of getpage. It deallocates pages which 
     have been discarded in the process of concatenation by returning them 
     to the free list.  Newroot is called when a split has propagated to 
     the root and a new root is required.  The new root will contain only 
     the central entry from the old root, and pointers to the old root and 
     its new sibling.
     
        BMAIN and BINTERN contain the parts that do most of the work of
     the unit.  Bsearch is relatively simple. Given a key and a tree, it
     returns true if the key exists and false if not.  If the key exists, 
     pgnbr and entrynbr will contain the position of the key, otherwise 
     they will contain the position where insertion should take place.  
     Bsearch calls bpgscan to look at each individual page and determine 
     whether the key is there.  Bpgscan searches the page, stopping at the 
     point where the key is found, the point where a larger key is 
     encountered, or the end of the page, whichever comes first.  It 
     returns, in i, the place where it stopped, and a boolean result 
     indicating whether it found the key.  Note that bpgscan is presently 
     implemented as a binary search.  The present page size is probably 
     the smallest for which a binary search holds any advantage over a 
     linear search.  If bpgscan returns true, then bsearch is done, 
     otherwise, bsearch looks at the pointer in position i.  If the 
     pointer is 0, we have reached a leaf without finding the key, and we 
     are done.  If the pointer is not 0, we read the page pointed-to and 
     start again.
     
        Binsert and bsplit are mutually recursive.  If, in the course of 
     insertion, overflow occurs, then binsert will call bsplit to move 
     half of the entries to a new page, and put the central entry into the 
     parent page.  Bsplit calls binsert to perform that insertion into the 
     parent.  Note that the fact that binsert may be called to do an 
     insertion at a non-leaf page (when it is called by bsplit) is the 
     reason for requiring the argument inspointer.  In application 
     programs, that argument must always be zero, since the insertion will 
     always be at a leaf.  This double-purpose use of binsert adds a 
     little to its complexity and is a case where additional layering 
     might present a cleaner (and safer) application program interface.
     
        Binsert reads the page where insertion is to occur and determines 
     whether it is full.  If so it first attempts to balance among 
     siblings by calling bbalance.  Stack overflow can occur on recursive 
     split/insert calls on a deep tree, especially if the balance 
     constants are large.  This is due to the size of the arrays used for 
     balancing.  Removing the call to bbalance will eliminate the problem 
     at the price of lowering storage utilization.  It should also speed 
     insertion significantly.  
     
        If the call to bbalance fails to make room in the page, split is
     called.  Finally, bshiftr is called to move the empty space to the
     right place in the page, and the entry and pointer are written.  Note
     that binsert may modify the position variables pgnbr and entrynbr by
     calling bbalance, but that these modifications are only local to
     binsert.  Consequently, do not count on these variables containing a
     correct position following a call to binsert.  An explicit call to
     bsearch is required.
     
        Bsplit is passed a tree and the number of a page to split.  It 
     returns the page number of the page it created.  It copies the left 
     half of the page into a buffer called oldrec, and the right half into 
     a buffer called newrec.  If the old page was the root, then a new 
     root is created containing just the central entry, otherwise binsert 
     is called to put the central entry into the parent.  In either event, 
     the left and right half buffers are written out.
     
        Fixpointer, called by both binsert and bsplit, is an imperfect
     solution to an interesting design problem.  Backpointers are
     maintained in the tree so that for any node you can travel up or down
     without maintaining a search path. This simplifies several of the
     routines, notably sequential searches.  It also makes it likely that
     a corrupted file can be recovered, since the backpointers are
     redundant information.  Unfortunately, the backpointers extract a
     serious performance penalty.  Every time that an entry is moved
     around in a page, the backpointer of its child must be updated.  If
     several entries are moved, several pointers must be updated. 
     Fixpointer does this job in a rather straightforward way.  Of course,
     it must read a page to update it, and it is this additional I/O that
     is the performance killer. Consequently, operations like insertion
     and deletion perform nowhere near their "book optimum".  Searches, on
     the other hand, are just as fast.  In applications where updating is
     infrequent, this design is satisfactory.  With frequent updates, the
     performance would probably be unacceptable.
     
        The sequential search routines firstentry, lastentry, nextentry, 
     and preventry are rather standard tree-traversals.  If you follow the 
     use of back-pointers, and the order in which entries are stored, 
     these routines should be easy to follow.  If you don't understand any 
     of that stuff, puzzling out these procedures could be tough, but is 
     guaranteed to be educational.
     
        
        The Balancing Act
     
     
        Given the theoretical explanation of a btree, most of the
     remaining routines are easily understood.  The exception is bbalance.
     It was difficult to write; it was nearly impossible to debug; and it
     will not be easy to understand.  I do not recommend attempting to
     mess with it unless you are willing to devote a good deal of time to
     it.
     
        Bbalance is passed a tree, a page and position around which to
     balance (parent_pointer and entry_pointer), and a page and position 
     to keep track of (markpage and markentry).  It reads all of the 
     required pointers and entries into a pair of gigantic arrays, then
     writes out a more or less even number to each of the siblings.  It
     does this even if there is no advantage to be gained, since it can't
     know that until it has read all of the sibling pages.  If the number
     of entries per page will be fewer than k, bbalance returns a page to
     the freelist and distributes the entries among the remaining
     siblings.  Thus it serves the concatenation function as well as the
     balancing function.  Three global constants are of particular
     importance to bbalance. Bal is the number of siblings over which it
     will attempt to balance. Halfbal is bal DIV 2.  Maxentries is the
     size of the giant arrays, and it must be at least (2k + 1) * (bal +
     1).  Some performance tuning of these constants is probably desirable
     based on the choice of page and entry size.
     
        A lot of the code in bbalance is bookkeeping to keep track of 
     markentry and markpage.  Bbalance may be called in the middle 
     of binsert, before the actual insertion has taken place.  Bbalance 
     will move things around, and binsert has to know where to perform the 
     insertion after bbalance is done.  Markpage and markentry serve this 
     purpose. The bookkeeping gets particularly complicated if the 
     position where insertion is to take place is beyond the last valid 
     entry in the page.  In this case, the markentry is decremented by one 
     at the beginning of bbalance, and the flag moved_marker is set to 
     true.  Markentry and markpage are then reset later.
     
        The main body of bbalance checks that we are not trying to balance 
     the root (parent_pointer = 0), reads in the page in question, does 
     some initialization, and then calculates the positions at which to 
     begin and end the balancing( first and last).  There are four cases:
      
     IF      The number of valid entries is less than bal. In order not to   
             balance past both ends of the page, we set first to the first 
             entry in the page and last to the last entry in the page.
     
     ELSE IF Entry_pointer is so far to the left that we might balance off   
             the left end of the page.  To avoid this, we set first to
             the beginning of the page and last to bal-1.
     
     ELSE IF Entry_pointer is so far to the right that the analogous   
             problem may occur there.  In this case we set last to the last 
             entry in the page, and first to (count-(bal-1)).
     
     ELSE    No odd cases exist, so we set first to (entry_pointer- halfbal),
             and last to (entry_pointer+halfbal).
        
        
        Having established the limits of balancing, bbalance calls local 
     procedure fill_arrays to read up the appropriate pages and stick them 
     into the giant arrays.  Then it calculates the number of entries each 
     sibling will have after balancing (newcount).  If that number is less 
     than k, it calls condense to return a page to the freelist and 
     recalculate.  In either event, it calculates how many pages will have 
     an extra entry (extras), since you hardly ever get a newcount with no 
     remainder.  
     
        If we didn't run into an odd case in condense (see below), 
     continue will be true, and we will write out the children.  First we 
     write out any children with an extra entry, then any children with 
     the average number of entries.  A call to the local procedure 
     write_child accomplishes this.  Finally we write out the parent page, 
     and check to see if it has fallen below k entries.  If so, we 
     recursively call bbalance to remedy the situation.  We can, in some 
     cases, reach the root recursively.  Since bbalance uses a lot of 
     memory for its activation record (remember the giant arrays?), stack 
     overflow is a possibility here with certain combinations of page size 
     and bal.  This tail recursion could easily be replaced by a giant 
     loop around the present body of bbalance, with a little extra code to 
     move up the tree each iteration as necessary.  This would cause the 
     same activation record to be reused repeatedly, but at some expense 
     to the readability of the code.
     
        Fill_arrays is basically just two loops controlled by index 
     variables outer (for the outer loop) and inner (for the inner loop).  
     Outer varies from first to last, and controls the reading and 
     processing of pages, inner controls the processing of entries within 
     a page.  The indexing is very complicated, partly because you have to 
     stick the entries from the parent in among the entries from the
     children, but leave the pointers from the parent unmolested.  Since 
     each child page has one more pointer than entries, it works out, but 
     not without a lot of thought.  Ep_index (entry/pointer index) and 
     temp_index are indices to the giant arrays, but ep_index lags 
     temp_index. 
     
        Write_child is pretty much the opposite of fill_arrays, except 
     that the outer loop has been moved out of the procedure to account 
     for the different number of entries per child induced by remainders 
     in the division (extras).  It also has a lot more bookkeeping to 
     contend with for markpage and markentry.  Note that place is an index 
     into the big arrays which marks where markentry ended up during 
     fill_arrays.
     
        Condense serves the concatenation function in a fairly obvious 
     way.  It returns the rightmost child page to the freelist, throws 
     away its pointer in the parent page (by calling bshiftl), and 
     recalculates newcount and last.  It also deals with a special case.  
     If we are attempting to condense the root page, and it contains only 
     one entry, it is much easier to deal with as a special case.  We copy 
     the two children into the root page, return both children (there can 
     only be two if the root has only one entry) to the freelist, and fix 
     up some back-pointers.  By setting continue to false, the body of 
     bbalance is informed that it is not necessary to write the children.
     
        If you followed all of that, I salute you.




========================================================================================
DOCUMENT :usus Folder:VOL16:bdoc3.text
========================================================================================


        Modification and Optimization
     
        
        There are a number of improvements, changes, and alternatives that 
     have been mentioned throughout the text.  Several others have come to 
     mind.  I want to close by offering some observations on how the 
     program might be altered.  
     
        First, the chosen key size, page size, and balancing constants are
     essentially arbitrary in the submitted version.  It is a good idea
     to choose a key size that matches your application, and then modify
     the other constants appropriately.  Page size should generally be
     the amount your operating system can grab in one swipe from the
     disk, or a multiple thereof (for UCSD p-System, 512 bytes).  The
     balancing constants should be optimized for a given key and page
     size, but I can only suggest an empirical approach to finding an
     optimum.  I would also suggest that most applications could benefit
     from some form of key compression layered on top of the b-tree. 
     With string keys, for example, one might want to remove spaces and
     punctuation and convert to a single case (upper or lower).
        
        
        A relatively simple modification would be the allocation of more
     space, either automatically or on demand.  Getpage, rather than
     calling errtrap when it runs out of space, could allocate more.  To
     be sure that a full volume is handled gracefully, getpage might
     check to see if the next allocation (rather than this one) will run
     you out, and attempt to allocate then.  That way, if it can't, it
     could return a code indicating impending disaster.
        
        
        The i/o primitives could be improved in several ways.  The easiest 
     is to substitute blockread/blockwrite for get and put.  Assuming 
     optimal page sizes, i/o could be sped considerably.  A more ambitious 
     project would be to add buffering.  If the most recently used pages 
     are kept around in buffers, and supplied to the program on demand 
     instead of reading, fewer i/o's can be expected.  Buffering can be 
     dangerous, especially if any kind of program or hardware error occurs 
     before a modified page is written.  I would recommend always writing 
     a modified page, even if it is kept in the buffer to avoid a later 
     read.  With or without buffering, it might be wise to modify the i/o 
     primitives to keep a change log.  Since the integrity of the tree is 
     not guaranteed during balancing, insertion, or deletion, any program 
     or hardware failure during these operations is likely to leave the 
     tree in an indeterminate state.  To insure absolute integrity, a log 
     of at least the last (depth-of-tree * bal) page alterations would be
     necessary.  Another difficulty with buffering is that you either need
     access to the file information block (fib) and window variable (f^)
     or you need to completely rewrite the way files are passed, read, and
     written.  The first solution is possible if you use the system
     globals available on Volume 8 of the Library (for version II and
     III).
     
        
        Two modifications were suggested to deal with deep trees in a
     limited amount of memory (i.e. avoid stack overflow).  First, the
     call to bbalance in binsert is not required for the integrity of the
     tree.  It just improves storage utilization.  Removing it would 
     improve the speed of insertion and avoid memory problems, at the cost 
     of lowered storage efficiency.  Perhaps a crunching utility could be 
     written using bbalance to close up unused space when the tree is not 
     otherwise in use.  It would be a long-running program, but it would 
     be very useful for highly static data-bases.  The other memory 
     modification is to change the tail-recursion in bbalance to 
     iteration.  Unlike LISP and LOGO, Pascal is not smart enough to 
     recognize tail-recursion as iteration automatically.
     
     
        A very ambitious project would be to eliminate the backpointers 
     and the fixpointer performance penalty by maintaining an explicit 
     search path.  I have begun such a modification and can assure you 
     that it is non-trivial as they say.  If you are using the program for 
     multiple files, then you need multiple paths, which need to be 
     passed, along with the tree, to each routine.  Treating the path as 
     a stack is the best idea, and you know that its depth will not exceed 
     the depth of the tree (which is unlikely, with a reasonable page 
     size, to exceed 10 or so).  One problem is that some routines need to 
     look more than one up the path.  Either provide a means of looking 
     back that far, or provide local temporaries to pop the top of stack 
     into.  If you don't need the extra performance, don't bother.
     
        
        Finally, the unit's interface is not very transparent.  Too much
     internal detail of the data structure is open to an application
     program, and too much bookkeeping is required of it.  I would suggest
     adding a layer between the unit and an application program to
     simplify its use.  By using the system globals, for example, an
     appplication program could actually look at an indexed file as a
     regular file with special access methods available as a bonus.
     Another ambitious project...
     
        
        For all of my self-criticism, the unit has one outstanding 
     advantage - it works. It has been in daily use on a fairly large 
     geographic data base for several months without problems.  I would 
     not wager a nickel that it is totally bug-free, but I would wager a 
     princely sum (a couple of bucks) that it hasn't any egregious errors, 
     and that it works basically as promised.  Use it in good health, and 
     please let me hear about any changes, improvements, bugs, etc. I'm in 
     the USUS membership roster, and on MUSUS (ppn 70105,772).
     
        
        REFERENCES
     
        
      Bayer, R. and McCreight, E. "Organization and Maintenance of Large
           Ordered Indexes", 12 ACTA INFORMATICA 1, 1972 (Springer-Verlag)
           p. 173-189.

           The original work on b-trees by the inventor. A good article.


      Comer, Douglas  "The Ubiquitous B-Tree", COMPUTING SURVEYS Vol.11,
           Number 2, June 1979 (Assn. for Computing Machinery) p. 121-137.

           An excellent survey article. Use Comer's bibliography to pur-
           sue the subject further.
           

      Knuth, D.E. THE ART OF COMPUTER PROGRAMMING: VOLUME 3, SEARCHING AND
           SORTING, 1973 (Addison-Wesley) esp. pages 476-479.

           The definitive (if unreadable) work on the subject of searching
           and sorting in general.  Some interesting ideas for altering 
           b-trees.

      Wirth, Niklaus, ALGORITHMS + DATA STRUCTURES = PROGRAMS, 1976
           (Prentice-Hall), esp.pages 242-264.

           The author of Pascal speaks on a variety of subjects, including
           example programs in Pascal.  A good, accessible treatment of
           b-trees.
      
        
     
        



========================================================================================
DOCUMENT :usus Folder:VOL16:bdriver.text
========================================================================================

 {$S+}
 PROGRAM btreetest;
 (*      B-tree creation  and update routines
                 Marvin White
                 Kyle Goldman
                 Michael Adams
                 Robert Sims
                 Applications Mathematics Research Staff
                 U.S. Census Bureau
                 Washington, D.C.
                                         *)
 USES {$U bunit.code} BUNIT;
 
 (*------------------------------------------------------------------*)
 PROCEDURE seqsearch(VAR f: btree; VAR entrynbr : bpagesize;
                     VAR pagenbr : btpointer);
 
 (*      Driver for interactive sequential search of a btree (f) starting at
         pagenbr,entrynbr. These are modified by seqsearch.*)
 VAR code : CHAR;
 
 BEGIN
 
 code := 'z';
 
 showit (f,pagenbr, entrynbr);
 
 WHILE NOT (code IN ['Q','q']) DO BEGIN
    WRITE('F(orward, R(everse, B(eginning, E(nd, Q(uit ?   ');
    READ (code);
    WRITELN;
    CASE code OF
         'F','f' : IF nextentry(f,pagenbr,entrynbr,pagenbr,entrynbr) THEN 
                    showit(f,pagenbr,entrynbr)
                   ELSE WRITELN('Cant"t go forward, already at last entry.');
         'R','r' : IF preventry(f,pagenbr,entrynbr,pagenbr,entrynbr) THEN
                     showit(f,pagenbr,entrynbr)
                    ELSE WRITELN('Can"t go back, already at first entry.');
         'B','b' : BEGIN firstentry(f,pagenbr,entrynbr); 
                         showit(f,pagenbr,entrynbr); END;
         'e','E' : BEGIN lastentry(f,pagenbr,entrynbr);
                         showit(f,pagenbr,entrynbr); END;
         'Q','q' : ;
    END; (*Case*)
 END;(*While*)
 END;(*PROCEDURE seqsearch*)
 
 (*------------------------------------------------------------------*)
 PROCEDURE driver;
 (*      Interactive driver for  btree testring and debugging*)
 VAR
         code: CHAR;
         name:STRING;
         f:btree;
         pages:btpointer;
         key:bkey;
         i:INTEGER;
         entry:btentry;
         letter: CHAR;    
 
         pagenbr : btpointer;
         entrynbr : bpagesize;
 
 (*--------------------------------*)
   PROCEDURE driver1;
 
   BEGIN
         WRITE(' O)pen,');
         WRITE(' C)lose,');
         WRITE(' N)ew,');
         WRITE(' L)ist,');
         WRITE(' S)earch,');
         WRITE(' I)nsert,');
         WRITE(' D)elete,');
         WRITE(' Z(earch,');
         WRITE(' Q)uit ?  ');
   END; (*PROCEDURE driver1*)
 
 
 (*--------------------------------*)
   PROCEDURE driver2;
 
    procedure delete_it;
    BEGIN
      WRITE('Key to delete?');
      READLN(entry.key);
      
      IF bsearch(f,pagenbr,entrynbr,entry.key) THEN
            bdelete(f,pagenbr,entrynbr)
      ELSE WRITELN('KEY ',entry.key,'IS NOT IN TREE');
      
      END; (*case bdelete*)

   BEGIN
 
         READ(code);
         WRITELN;
         CASE code OF
 
                 'o','O' : BEGIN
 
                          WRITE('Name of btree ?     ');
                          READLN(name);
                          IF bopen(f,name) THEN BEGIN
                            pagenbr := broot(f);
                            entrynbr := 1;
                            WRITELN('Btree ',name,' has been opened.');
                          END
                          
                          ELSE WRITELN('Can''t open ',name);
 
                          END; (* case bopen *)
                 'c','C' : BEGIN
 
                          bclose(f);
                         WRITELN('Btree ',name,' is closed.');
 
                          END; (* case bclose *)
 
                 'n','N' : BEGIN
 
                          WRITE('What is the name of your new tree ?     ');
                          READLN(name);
                          WRITE('How many pages maximum ?     ');
                          READLN(pages);
                          IF NOT bnew(name,pages) THEN 
                                WRITELN('Can''t open ',name);
                          END; (* case bnew *)
 
                 'l','L' : BEGIN
                          WRITE('Which page ?     ');
                          READLN(pages);
                          bread(f,pages);
                          bdump(f^);
                          END;(*case bdump*)
                          
                 's','S' : BEGIN
                          WRITE('Key to look for?');
                          READLN(key);
                          
                          IF bsearch(f,pagenbr,entrynbr,key) THEN BEGIN
                                WRITELN('SUCCESS');
                                showit(f,pagenbr,entrynbr);  END
                                
                          ELSE BEGIN
                                WRITELN('FAILURE');
                                bdump(f^); END;
                                
                          END; (*case bsearch*)
                          
                 'i','I' : BEGIN
                          WRITE('Key to insert?');
                          READLN(entry.key);
                          
                          WRITE('Data to insert?');
                          READLN(entry.data);
                          
                          IF bsearch(f,pagenbr,entrynbr,entry.key) THEN
                                WRITELN('KEY IS ALREADY THERE.')
                                
                          ELSE 
                             binsert(f,entry,0,pagenbr,entrynbr);
                             
                          END; (*case binsert *)
                          
                 'd','D' : delete_it;
                 'z','Z' : seqsearch(f,entrynbr,pagenbr);
                 
             END; (*Cases*)

  END; (*PROCEDURE driver2*)
  
(*-----------------------------------*)

BEGIN (*driver*)

i:=1;

code := 'o';

WRITELN(chr(12));  (*clear screen with formfeed*)

WRITELN('Driver program for BTREE development.');

WRITELN;

WHILE NOT (code IN ['q','Q']) DO BEGIN

  driver1;
  driver2;
  
END; (*While*)

END; (*PROCEDURE driver*)


(*----------------------------------------------------------------------*)

BEGIN  (*PROGRAM btreetest*)

driver;

WRITELN('End of program btree.');

END. (*PROGRAM btreetest*)




========================================================================================
DOCUMENT :usus Folder:VOL16:bhkeep.text
========================================================================================

 (*------------------------------------------------------------------*)
 FUNCTION broot(*VAR f:btree):btpointer*);
 (*      Returns page number of root of btree f*)
 
 BEGIN
         bread(f,0);
         broot:=f^.desc.root;
 END; (* FUNCTION broot *)
 
 (*------------------------------------------------------------------*)
 FUNCTION getpage(VAR f:btree): btpointer;
 (*      Get new page from free list or from end of
         file *)
 
 VAR
         i, j, k : btpointer;
 
 BEGIN
         bread(f, 0);            (* read descriptor *)
         i := f^.desc.freehead;
         IF i <> 0 THEN BEGIN
                 bread(f, i);
                 j := f^.nextfree;
                 bread(f, 0);
                 f^.desc.freehead := j;
                 bwrite(f, 0);
         END (*THEN*)
         ELSE BEGIN
                 i := f^.desc.nrec + 1;
                 IF i > f^.desc.maxrec THEN  errtrap(' File overflow');
                 f^.desc.nrec := i;
                 bwrite (f, 0);
         END;
         bread(f, i);
         getpage := i;
 END; (* FUNCTION getpage *)
 (*------------------------------------------------------------------*)
 
 PROCEDURE freepage (VAR f : btree; pgnbr : btpointer);
 
 (* Opposite of getpage. Returns page indicated by pgnbr to the
    head of the free list*)
 
 VAR temp : btpointer;
 
 BEGIN
 
 bread(f, 0);
 temp := f^.desc.freehead;
 
 f^.desc.freehead := pgnbr;
 bwrite (f, 0);
 
 f^.use := 0;
 f^.nextfree := temp;
 bwrite(f, pgnbr);
 
 END;  (*PROCEDURE freepage*)
 
 (*------------------------------------------------------------------*)
 PROCEDURE newroot(VAR f:btree; VAR entry: btentry; p0, p1: btpointer);
 (*      Create a new root consisting of just one entry
         and two pointers *)
 
 VAR
         r: btpointer;
 
 BEGIN
         r := getpage(f);        (* get new page *)
         f^.use := 2;            (* btree page *)
         f^.pg.count := 1;
         f^.pg.bentry[1] := entry;
         f^.pg.bpointer[0] := p0;
         f^.pg.bpointer[1] := p1;
         f^.pg.prntpage := 0;
         bwrite(f, r);
 
         bread (f, 0);   (*Update desc. to point to new root*)
         f^.desc.root := r;
         bwrite (f,0);
 
 END;  (*PROCEDURE newroot*)
 
 



========================================================================================
DOCUMENT :usus Folder:VOL16:bintern.text
========================================================================================

 (*------------------------------------------------------------------*)
 PROCEDURE fixpointer (VAR f : btree; pgnbr, prntpage : btpointer;
                         prntent : bpagesize);
 (*       Read  page pointed to by pgnbr, and make backpointers
          point to prntpage, prntent*)
 
 
 BEGIN
 
 
 IF pgnbr > 0 THEN BEGIN
 
         bread (f, pgnbr);
         f^.pg.prntpage := prntpage;
         f^.pg.prntentry := prntent;
         bwrite (f,pgnbr);
 
 END; (*If pgnbr*)
 
 END; (*PROCEDURE fixpointer*)
 (*------------------------------------------------------------------*)
 PROCEDURE bshiftr (VAR f : btree; VAR thispage : bpage;
                 thispgnbr : btpointer; pagepart : bpagesize);
 
 (*IF pagepart points to a full space in thispage, move it and everythin
 to it's right one place to the right, creating a space. In any event,
 increment the counter.Calling routine must know that thispage isn't full,
 bshiftr doesn't check. Bshiftr doesn't actually blank the space either. 
 Calling routine should write something there, or you're in a heap of trouble*)
 
 VAR subscript : 0..btree2k;
 
 BEGIN
 
 IF thispage.count < btree2k THEN BEGIN
 
 
         FOR subscript := thispage.count DOWNTO pagepart DO BEGIN
 
         thispage.bentry[subscript+1] := thispage.bentry[subscript];
         thispage.bpointer[subscript+1] := thispage.bpointer[subscript];
         fixpointer (f, thispage.bpointer[subscript], thispgnbr, (subscript+1));
 
         END; (*For subscript*)
         
         thispage.count := thispage.count + 1;
 
 END; (* IF count*)
 
         
 END; (*PROCEDURE bshiftr*)
 (*------------------------------------------------------------------*)
 PROCEDURE bshiftl (VAR f : btree; VAR thispage : bpage;
                 thispgnbr : btpointer; pagepart : bpagesize);
 
 
 (*Move everything to the right of pagepart one space to the left.
 Calling routine must know that pagepart is empty (or that its okay
 to overwrite it). Decrement the page counter.*)
 
 VAR subscript : 0..btree2k;
 
 BEGIN
 
 
 FOR subscript := pagepart TO (thispage.count - 1) DO BEGIN
 
         thispage.bentry[subscript] := thispage.bentry[subscript+1];
         thispage.bpointer[subscript] := thispage.bpointer[subscript+1];
         fixpointer (f, thispage.bpointer[subscript+1],thispgnbr,subscript);
 
 END; (*For subscript*)
 
 thispage.count := thispage.count - 1;
 
 END; (*PROCEDURE bshiftl*)
 
 (*------------------------------------------------------------------*)
 PROCEDURE bbalance (VAR f : btree; parent_pointer : btpointer; 
                     entry_pointer : bpagesize; 
                 VAR markpage : btpointer; VAR markentry : bpagesize);
 
 (*Balance entries (and pointers) among adjacent children of the parent indicate
   by parent_pointer. Each child gets (total entries DIV number of children).
   The first (total entries MOD number of children) get one more entry.
   If deletion has dropped the avg page count to btreek or below,  will
   balance over prnt page's count - 1 pages and return the extra page to freelis
   Markpage and markentry mark the location of an entry to keep track of 
   following the completion of balance. They are used by binsert. *)
 
 
 VAR entries : ARRAY [0..maxentries] OF btentry;         (* holds entries *)
     pointers : ARRAY [0..maxentries] OF btpointer;      (* holds pointers *)
     parent, child : brecord;
     place : -1..maxentries;     (*index into entries, position of markentry*)
     first, last : 0..btree2kp;          (*begin and end of fill-arrays*)
     temp_index,
     ep_index : 0..maxentries;   (*index to entry and pointer arrays*)
     inner,                      (*index to loop for one child*)
     outer,                      (*index to loop for all children of parent*)
     newcount,                   (*num of entries per child*)
     extras : 0..btree2kp;       (*num of children w extra entry*)
     continue, moved_marker : BOOLEAN;
 
 (*-------------------------------*)
 
 
    PROCEDURE fill_arrays;       (* Local to bbalance*)
 
    BEGIN
 
      FOR outer := first TO last DO BEGIN        (*For each child of parent*)
      
         bread (f,parent.pg.bpointer[outer]);            (*read a child*)
         child := f^;
      
         FOR inner := 1 TO child.pg.count DO BEGIN (*For each entry in child.*)
      
         (*stick the entries into big array of entries, ditto pointers*)
      
         temp_index := ep_index + inner;
         entries[temp_index] := child.pg.bentry[inner];
         pointers[temp_index - 1] := child.pg.bpointer[inner - 1];
 
         IF (parent.pg.bpointer[outer] = markpage) AND
            (inner = markentry) THEN place := temp_index;
      
         END; (*For inner*)
 
      
         IF outer < last THEN BEGIN
            ep_index := temp_index + 1;
         
            (*now put parent's entry into big array*)
            entries[ep_index] := parent.pg.bentry[outer + 1]; END
      
         ELSE ep_index := temp_index;
 
         (* put last pointer in big array*)
         pointers[temp_index] := child.pg.bpointer[child.pg.count];
 
      END; (*For outer*)
 
    END; (*PROCEDURE fill_array*)
 
 (*--------------------------------*)
    PROCEDURE condense; (*Local to  bbalance *)
 
    BEGIN
 
      IF (parent.pg.prntentry = 0) AND (parent.pg.count = 1) THEN BEGIN
         parent.pg.count := ep_index;
         freepage(f,parent.pg.bpointer[0]);
         freepage(f,parent.pg.bpointer[1]);
         parent.pg.bpointer[0] := pointers[0];
         fixpointer(f, pointers[0],parent_pointer,0);
         FOR outer := 1 TO ep_index DO BEGIN
            parent.pg.bentry[outer] := entries[outer];
            parent.pg.bpointer[outer] := pointers[outer];
            fixpointer(f,pointers[outer],parent_pointer,outer); END;
         continue := FALSE; END
 
      ELSE BEGIN
         freepage (f,parent.pg.bpointer[last]); 
         bshiftl(f,parent.pg,parent_pointer,last);
         last := last - 1;
         newcount := (ep_index - (last-first)) DIV ((last-first)+1);
         continue := TRUE; END;
 
    END; (*Local PROCEDURE condense*)
 
 (*--------------------------------*)
 
    PROCEDURE write_child (count:bpagesize); (*Local to bbalance*)
 
    BEGIN
 
       FOR inner := 1 TO count DO BEGIN
 
         temp_index := ep_index + inner;
         child.pg.bentry[inner] := entries[temp_index];
         child.pg.bpointer[inner - 1] := pointers[temp_index - 1];
         fixpointer (f, child.pg.bpointer[inner - 1],
                         parent.pg.bpointer[outer], inner);
 
         IF (temp_index = place) THEN BEGIN
            markpage := parent.pg.bpointer[outer];
            IF moved_marker THEN markentry := inner + 1
            ELSE markentry := inner;  END;
 
      END; (*For inner*)
 
      ep_index := temp_index + 1;
   
      IF outer < last THEN BEGIN 
         parent.pg.bentry[outer + 1] := entries[ep_index];
         IF ep_index = place THEN 
            IF moved_marker THEN BEGIN
              markpage := parent.pg.bpointer[outer+1];
              markentry := 1;  END
            ELSE BEGIN 
               markpage := parent.pg.bpointer[outer];
               markentry := count+ 1; END; END;
 
      child.pg.prntentry := outer;
 
      child.pg.bpointer[count] := pointers[temp_index];
      fixpointer(f,pointers[temp_index],parent.pg.bpointer[outer],count);
      child.pg.count := count;
   
      (*now write the child. we didn't disturb the pointers on the parent*)
   
      f^ := child;
      bwrite(f,parent.pg.bpointer[outer]);
 
    END; (*PROCEDURE write_child*)
 
 (*--------------------------------*)
 
 
 BEGIN  (*PROCEDURE bbalance*)
 
 
 IF parent_pointer = 0 THEN exit(bbalance);
 
 bread(f,parent_pointer);
 parent := f^;
 
 ep_index := 0;
 place := 0;
 continue := TRUE;
 
 (*if marker is at count+1,glue it to count*)
 
 moved_marker := FALSE;
 IF markentry > btree2k THEN BEGIN
    markentry := btree2k;
    moved_marker := TRUE; END;
 
 (*Calculate begin and end for balance *)
 
 IF (parent.pg.count + 1) <= bal THEN BEGIN
         first := 0;
         last := parent.pg.count; END
 ELSE IF entry_pointer - halfbal < 0 THEN BEGIN
         first := 0;
         last := bal - 1; END
 ELSE IF entry_pointer + halfbal > parent.pg.count THEN BEGIN
         first := parent.pg.count - (bal-1);
         last := parent.pg.count; END
 ELSE BEGIN
         first := entry_pointer - halfbal;
         last := entry_pointer + halfbal; END;
      
 fill_arrays; 
 
 (* Calculate entries per child *)
 
 newcount := (ep_index - (last-first)) DIV ((last-first)+1);
 
 (* IF deletion has caused # entries to go below k, decrement
    parent count, return a page to free list, and recalc newcount *)
 
 IF newcount < btreek THEN condense;
 
 (* Calculate # of children w an extra entry *)
 
 extras := (ep_index - (last-first)) MOD ((last-first)+1);
 
 (*Since we have entries and entries per child, we reverse the process*)
 
 
 IF continue THEN BEGIN
    
    ep_index := 0;
    
    IF extras > 0 THEN BEGIN
       FOR outer := first TO (first+(extras-1)) DO write_child(newcount+1);
       FOR outer := (first + extras) TO last DO write_child(newcount); END 
    
    ELSE FOR outer := first TO last DO write_child(newcount); END;
 
 f^ := parent;
 bwrite(f,parent_pointer);       (*Now write the parent*)
 
 IF parent.pg.count < btreek THEN
     bbalance (f,parent.pg.prntpage,parent.pg.prntentry,pointers[0],newcount);
                 (*pointers and newcount above are dummies*)
 
 END; (*PROCEDURE bbalance*)
 
 
 (*------------------------------------------------------------------*)
 FUNCTION bpgscan (VAR f: bpage; VAR testkey : bkey; VAR i : INTEGER) : BOOLEAN;
 
 (*      Given a page (f), searches for testkey. i is place in page
         where found (if found), or place where insert would take
         place if not found. Boolean function result indicates found(T) 
         not found (F).*)
 
 VAR first, last : bpagesize;
     found : BOOLEAN;
 
 BEGIN
         
 first := 1;
 last := f.count;
 bpgscan := FALSE;
 
 IF (testkey < f.bentry[first].key) OR (last = 0) THEN BEGIN
 
        i := first;     EXIT(bpgscan);  END;
        
 IF testkey > f.bentry[last].key THEN BEGIN
 
        i := last + 1;  EXIT(bpgscan);  END;
        
 i := (last + first) DIV 2;
 found := (f.bentry[i].key = testkey);
 
 WHILE NOT found AND (i > first) DO BEGIN
         
         IF (f.bentry[i].key > testkey) THEN last := i;
         IF (f.bentry[i].key < testkey) THEN first := i;
                 
         i := (last + first) DIV 2;
         found := (f.bentry[i].key = testkey);
                 
 END; (*While*)

IF NOT found THEN i := last;
found := (f.bentry[i].key = testkey);
bpgscan := found;

END; (* FUNCTION bpgscan *)





========================================================================================
DOCUMENT :usus Folder:VOL16:bio.text
========================================================================================

 (*------------------------------------------------------------------*)
 PROCEDURE bread (*VAR f : btree; r: btpointer*);
 (*      Read a btree record *)
 
 BEGIN
 
         SEEK(f, r); GET(f); 
 
 END; (* PROCEDURE bread *)
 
 (*------------------------------------------------------------------*)
 PROCEDURE bwrite(VAR f: btree; r:btpointer);
 (*      Write current btree record to file *)
 
 BEGIN
         SEEK (f, r); PUT(f); 
 
 END; (*PROCEDURE bwrite *)
 
 (*------------------------------------------------------------------*)
 FUNCTION bopen (*VAR f: btree; name: STRING) : BOOLEAN*);
 (*      Open B-tree file name *)
 
 BEGIN
         RESET(f, name);
         bopen := (ioresult = 0);
 
 END; (* FUNCTION bopen *)
 
 (*------------------------------------------------------------------*)
 PROCEDURE bclose (*VAR f: btree*);
 (*      Close btree file f *)
 
 BEGIN
         CLOSE(f);
 
 END; (* PROCEDURE bclose *)
 
 (*------------------------------------------------------------------*)
 FUNCTION bnew(*name: STRING; npages: btpointer) : BOOLEAN*);
 (*      Create a new btree named name *)
 
 VAR
         f: btree;
 
 BEGIN
 
 REWRITE(f, name);
 IF ioresult = 0 THEN BEGIN
 
         bnew := TRUE;
         
         WITH f^ DO BEGIN
                 use := 1;       (* mark as descriptor rec *)
                 desc.nrec := 2; (* record 2 is first in free chain *)
                 desc.freehead := 2;     (* first free rec *)
                 desc.maxrec := npages;  (* space to allocate *)
                 desc.root:= 1;  (* record 1 is root of empty tree *)
         END; (* WITH*)
         PUT(f);
 
         WITH f^.pg DO BEGIN     (* create empty root *)
                 f^.use := 2;    (* mark as page *)
                 count:= 0;      (* empty *)
                 bpointer[0] := 0; (*initialize pointer*)
                 prntpage := 0;          (*init backpointer*)
                 prntentry := 0;         (*ditto*)
         END; (* WITH *)
         PUT(f);
 
         WITH f^ DO BEGIN
                 use := 0;       (* mark as free record *)
                 nextfree := 0;  (* end of free chain *)
         END; (* WITH *)
         PUT(f);
 
         SEEK(f, npages);        (* allocate space *)
         PUT(f);
         CLOSE(f,LOCK);
 
 END  {If goodio}
 
 ELSE bnew := false;
 
 END; (* PROCEDURE bnew *)
 



========================================================================================
DOCUMENT :usus Folder:VOL16:bmain.text
========================================================================================

 (*------------------------------------------------------------------*)
 FUNCTION bsearch (*VAR f : btree; VAR pgnbr : btpointer; 
                   VAR entrynbr : bpagesize;key : bkey) : BOOLEAN*);
 
 (*      Given a btree (f), searches for key. Returns pgnbr (page) and entrynbr 
         (place in page) where found or where insertion would take place. Calls
         bpgscan to check each page as necessary. Boolean function result is 
         T if found, F if not found*)
 
 VAR
         p:btpointer;
         found:BOOLEAN;
         i: INTEGER;
 BEGIN
         p:=broot(f);
 
         pgnbr := p;
         found:=FALSE;
         WHILE(NOT found) AND (P<>0) DO BEGIN
                 bread(f,p);
                 found:=bpgscan(f^.pg,key,i);
 
                 entrynbr := i;
                 IF NOT found THEN BEGIN
                         p:=f^.pg.bpointer[i-1];
                         IF p <> 0 THEN pgnbr := p;
                 END; (*If not found*)
         END; (* WHILE *)
         bsearch:=found;
 END; (* FUNCTION bsearch *)
 
 
 (*------------------------------------------------------------------*)
 (*PROCEDURE binsert (VAR f : btree; insentry : btentry; inspointer : btpointer;
                         pgnbr : btpointer; entrynbr : bpagesize);
 FORWARD;*)
 (*------------------------------------------------------------------*)
 FUNCTION bsplit (VAR f : btree; oldpgnbr : btpointer) : btpointer;
 (*      Split the page at oldpgnbr and pop the central entry up one
         level in the tree, by calling binsert (or newroot if the
         page split was the root). Call to binsert may cause the
         parent page to overflow, resulting in another call to
         bsplit by binsert. If the root is split. a new root is
         created, containing only the central entry.
         The function returns the page number of the new page it created.*)
 
 VAR
         i,j : bpagesize;
         newrec, oldrec : brecord;
         midentry : btentry;
         midpointer : btpointer;
         prntpage : btpointer;
 
 BEGIN
 newrec.use := 2;        (* set up new page as btree page *)
 bread (f,oldpgnbr);
 oldrec := f^;
 oldrec.pg.count := btreek;
 newrec.pg.count := btreek;      (* half of the old pg *)
 i := btreek + 1;        (*starting index*)
 midentry := oldrec.pg.bentry[i];
 midpointer := getpage(f);
 newrec.pg.bpointer[0] := oldrec.pg.bpointer[i];
 fixpointer(f,newrec.pg.bpointer[0],midpointer,0);
 
 FOR j := 1 TO btreek DO BEGIN
         newrec.pg.bentry[j] := oldrec.pg.bentry[i+j];
         newrec.pg.bpointer[j] := oldrec.pg.bpointer[i+j];
         fixpointer(f, newrec.pg.bpointer[j],midpointer, j); END;
 
 IF oldrec.pg.prntpage = 0 THEN BEGIN
 
         newroot (f, midentry, oldpgnbr, midpointer);
         prntpage := broot(f);
         newrec.pg.prntpage := prntpage;
         newrec.pg.prntentry := 1;
         oldrec.pg.prntpage := prntpage;
         oldrec.pg.prntentry := 0; 
         f^ := newrec;
         bwrite(f, midpointer);
         f^ := oldrec;
         bwrite(f,oldpgnbr); END
 
 ELSE BEGIN
 
         IF oldrec.pg.prntentry < btree2k THEN BEGIN
                 newrec.pg.prntentry := oldrec.pg.prntentry + 1;
                 newrec.pg.prntpage := oldrec.pg.prntpage; END;
         f^ := newrec;
         bwrite(f,midpointer);
         f^ := oldrec;
         bwrite(f, oldpgnbr);
         binsert (f, midentry, midpointer, oldrec.pg.prntpage, 
                             (oldrec.pg.prntentry + 1 ));
         END; (*Else*)
 
 bsplit := midpointer;
 
 END; (* FUNCTION bsplit *)
 
 (*------------------------------------------------------------------*)
 PROCEDURE binsert (*VAR f : btree; insentry : btentry; inspointer : btpointer;
                         pgnbr : btpointer; entrynbr : bpagesize*);
 (*      Insert the insentry, inspointer at the place pointed to by pgnbr,
         entrynbr. If necessary, balance among siblings or split to make room.
         Split may invoke mutually recursive call of insert.*)
 
 VAR dummy : btpointer;
     buffrec : brecord;
 
 BEGIN
 
 bread (f, pgnbr);
 IF f^.pg.count = btree2k THEN BEGIN
    bbalance (f, f^.pg.prntpage,f^.pg.prntentry,pgnbr,entrynbr);
    bread (f, pgnbr);  END;
 
 IF f^.pg.count = btree2k THEN BEGIN
 
    IF entrynbr > (btreek + 1) THEN BEGIN
         pgnbr := bsplit (f, pgnbr);
         entrynbr := entrynbr - (btreek + 1); END
    ELSE dummy := bsplit (f, pgnbr);
    bread (f, pgnbr); END;
 
 
 buffrec := f^;
 IF entrynbr = btree2kp THEN entrynbr := entrynbr - 1;
 (*Above will happen only when search put location beyond end of full
 page and balance was called, opening rightmost slot in page*)
 bshiftr (f, buffrec.pg, pgnbr, entrynbr);
 f^ := buffrec;
 f^.pg.bentry[entrynbr] := insentry;
 f^.pg.bpointer[entrynbr] := inspointer;
 bwrite (f, pgnbr);
 fixpointer(f, inspointer, pgnbr, entrynbr);
 
 END; (* PROCEDURE binsert *)
 
 (*------------------------------------------------------------------*)
 FUNCTION nextentry (*VAR f : btree;  thispg : btpointer;  thisent : bpagesize;
                 VAR nxtpg : btpointer;  VAR nxtent : bpagesize) : BOOLEAN*);
 
 (* Searches for first entry lexically greater than that pointed to
   by thispg, thisent.  Returns TRUE if there is a next entry, and
   returns its position as nxtpg, nxtent. If there is no greater
   entry, returns FALSE. Nxtpag, nxtent are set to thispg,thisent in this 
   case.*)
 
 VAR temp : brecord;
 
 BEGIN
 
 bread (f,thispg);
 temp := f^;
 
 IF temp.pg.bpointer[thisent] = 0 THEN           (*At a leaf*)
         IF thisent <> temp.pg.count THEN BEGIN  (*Not at end-of-page*)
                 nxtpg := thispg;
                 IF thisent > temp.pg.count THEN BEGIN
                    nxtpg := thispg;
                    nextentry := FALSE; END
                 ELSE BEGIN
                    nxtent := thisent + 1;
                    nextentry := TRUE; END; END
         ELSE BEGIN                              (*At end-of-page*)
                 nxtent := thisent+1;
                 WHILE (temp.pg.count < nxtent) AND (temp.pg.prntpage <> 0) DO 
                    BEGIN                (*Ascend until not at end-of-page*)
                    nxtent:= temp.pg.prntentry+1;
                    nxtpg := temp.pg.prntpage;
                    bread(f,nxtpg);
                    temp := f^; END;
                 IF (temp.pg.prntpage=0) AND (temp.pg.count < nxtent) THEN BEGIN
                    nextentry := FALSE;
                    nxtent := thisent;
                    nxtpg := thispg; END
                 ELSE nextentry := TRUE; END
 ELSE BEGIN                                      (*Not at a leaf*)
         nxtpg := temp.pg.bpointer[thisent];
         bread(f,temp.pg.bpointer[thisent]);
         WHILE f^.pg.bpointer[0] <> 0 DO BEGIN   (*descend until leaf*)
            nxtpg := f^.pg.bpointer[0];
            bread (f, nxtpg);  END; (*While*)
         nxtent := 1;
         nextentry := TRUE; END; (*Else*)
 
 END;  (*FUNCTION nextentry;
 
 
 (*------------------------------------------------------------------*)
 FUNCTION preventry (*VAR f : btree;  thispg : btpointer;  thisent : bpagesize;
                 VAR prvpg : btpointer;  VAR prvent : bpagesize) : BOOLEAN*);
 
 (* Searches for first entry lexically less than that pointed to
   by thispg, thisent.  Returns TRUE if there is a prev entry, and
   returns its position as prvpg, prvent. If there is no lesser
   entry, returns FALSE. Prvpag, prvent are set to thispg,thisent in this 
   case.*)
 
 VAR temp : brecord;
 
 BEGIN
 
 bread (f,thispg);
 temp := f^;
 
 IF temp.pg.bpointer[thisent - 1] = 0 THEN       (*At a leaf*)
         IF thisent <> 1 THEN BEGIN              (*Not at begin-of-page*)
                 prvpg := thispg;
                 prvent := thisent - 1;
                 preventry := TRUE; END
         ELSE BEGIN                              (*At begin-of-page*)
                 prvent := thisent -1;
                 WHILE (prvent = 0) and (temp.pg.prntpage <> 0) DO 
                    BEGIN                        (*Ascend until not begin-page*)
                    prvent := temp.pg.prntentry;
                    prvpg := temp.pg.prntpage;
                    bread(f,prvpg);
                    temp := f^; END;
                 IF (temp.pg.prntpage = 0) AND (prvent = 0) THEN BEGIN
                    preventry := FALSE;
                    prvent := thisent;
                    prvpg := thispg; END
                 ELSE preventry := TRUE; END
 ELSE BEGIN                                      (*Not at a Leaf*)
         prvpg := temp.pg.bpointer[thisent-1];
         bread(f,temp.pg.bpointer[thisent - 1]);
         WHILE f^.pg.bpointer[f^.pg.count] <> 0 DO 
            BEGIN                                (*Descend until leaf*)
            prvpg := f^.pg.bpointer[f^.pg.count];
            bread (f, prvpg);  END; (*While*)
         prvent := f^.pg.count;
         preventry := TRUE; END; (*Else*)
 
 END;  (*FUNCTION preventry;
 
 (*------------------------------------------------------------------*)
 PROCEDURE bdelete (*VAR f : btree; pgnbr : btpointer; entnbr : bpagesize*);
 
 (* Deletes entry (and associated pointer) pointed to by entnbr,pgnbr.
    If necessary, calls bbalance to balance or shrink tree.*)
 
 VAR this, next : brecord;
     nxtpg : btpointer;
     nxtent : bpagesize;
 
 BEGIN
 
 bread(f,pgnbr);
 this := f^;
 
 IF (this.pg.bpointer[entnbr] <> 0) AND          (*Not at a leaf, next is TRUE*)
    (nextentry (f,pgnbr,entnbr,nxtpg,nxtent)) THEN BEGIN
         bread(f,nxtpg);
         next := f^;
         this.pg.bentry[entnbr] := next.pg.bentry[nxtent];
         bshiftl(f, next.pg, nxtpg, nxtent);
         f^ := next;
         bwrite (f, nxtpg);
         f^ := this;
         bwrite(f, pgnbr);
         IF next.pg.count <= btreek THEN 
                 bbalance(f,next.pg.prntpage,next.pg.prntentry,pgnbr,entnbr);END
 ELSE BEGIN                                      (*At a leaf*)
         bshiftl (f, this.pg, pgnbr, entnbr);
         f^ := this;
         bwrite(f, pgnbr);
         IF this.pg.count <= btreek THEN
                 bbalance(f,this.pg.prntpage,this.pg.prntentry,pgnbr,entnbr);END
 END; (*PROCEDURE bdelete*)
 
 
 (*------------------------------------------------------------------*)
 PROCEDURE  firstentry (*VAR f : btree; VAR page : btpointer; 
                         VAR entry : bpagesize*);
 
 (*Returns position of least (first) lexical entry as page, entry*)
 
 BEGIN
 
 page := broot(f);
 bread(f,page);
 
 WHILE f^.pg.bpointer[0] <> 0 DO BEGIN
         page := f^.pg.bpointer[0];
         bread(f,page); END;
 
 entry := 1;
 
 END; (*PROCEDURE firstentry*)
 
 (*------------------------------------------------------------------*)
 PROCEDURE  lastentry (*VAR f : btree; VAR page : btpointer; 
                         VAR entry : bpagesize*);
 
 (*Returns position of greatest (last) lexical entry as page, entry*)
 
 BEGIN
 
 page := broot(f);
 bread(f,page);
 
 WHILE f^.pg.bpointer[f^.pg.count] <> 0 DO BEGIN
         page := f^.pg.bpointer[f^.pg.count];
         bread(f,page); END;
 
 entry := f^.pg.count;
 
 END; (*PROCEDURE lastentry*)
 



========================================================================================
DOCUMENT :usus Folder:VOL16:bunit.text
========================================================================================

 {$S+}
 {$R+}
 {$I-}
 
 UNIT bunit;
 (*      B-tree creation  and update routines
                 Marvin White
                 Kyle Goldman
                 Michael Adams
                 Robert Sims
                 Applications Mathematics Research Staff
                 U.S. Census Bureau
                 Washington, D.C.
                                         *)
 
 
 (******************)  INTERFACE        (*********************)
 
 
 CONST
         btreek = 19;     (*must be btree2k DIV 2*)
         btree2kp = 40;   (*must be btree2k + 1*)
         btree2k = 39;    (* number of entries / page, must be odd *)
         bal = 5;         (*num of children over which to balance*)
         halfbal = 2;     (* bal DIV 2 *)
         maxentries =240; (*used only by bbalance, must equal
                                 btree2kp * (bal + 1) *)
         keysize = 21;   (* number of INTEGER values in key *)
         maxpages=32767; (* maximum possible pages *)
         tempmax = 200; (*DEBUG max on pages*)
 
 TYPE
         btpointer = 0.. maxpages;       (* pointer to btree page *)
 
         bpagesize = 0..btree2kp;
         bkey = STRING[keysize];
 
         bdata= INTEGER;         (* these btrees have only a single
                                 integer datum*)
 
 
 
         btentry = RECORD
                         key : bkey;
                         data: bdata;
                 END; (* RECORD *)
 
         buse = 0..2;            (* use designator for page in file *)
 
         bdescrip = RECORD       (* record 0 in file is descriptor *)
                         nrec: btpointer;        (*current last page *)
                         maxrec: btpointer;      (* current allocation *)
                         root: btpointer;        (* root of tree *)
                         freehead: btpointer;    (* head of free list *)
                 END; (* RECORD *)
 
         bpage = RECORD          (* page in b-tree *)
                         prntpage : btpointer;
                         prntentry : 0..btree2k; (*same # as index of bpointer
                          t???*)
                         count: 0..btree2k;      (* entries in this page *)
                         bentry: ARRAY[1..btree2k] OF btentry;
                         bpointer: ARRAY[0..btree2k] OF btpointer;
                 END; (* RECORD *)       
 
         brecord = RECORD CASE use: buse OF
                 0: (nextfree: btpointer);       (* free record *)
                 1: (desc: bdescrip);            (* record 0 *)
                 2: (pg: bpage);         (* b-tree page *)
                 END; (*CASE*)
 
         btree = FILE OF brecord;
 
 
 FUNCTION broot(VAR f:btree):btpointer;
 {  Returns page number of root of btree f }
 
 FUNCTION bopen (VAR f: btree; name : STRING):BOOLEAN;
 { Open the btree file named name, associate with fileid f }
 
 PROCEDURE bread (VAR f : btree; r: btpointer);
 { Read a btree record number r from tree f  }
 
 PROCEDURE bclose (VAR f: btree);
 { Close btree fileid f }
 
 FUNCTION bnew (name : STRING; npages : btpointer):BOOLEAN;
 { Create a btree file named name, containing npages, and close it }
 
 FUNCTION bsearch (VAR f: btree; VAR pgnbr : btpointer; 
                   VAR entrynbr : bpagesize; key : bkey) : BOOLEAN;
 
 { search btree file f for key. Return TRUE if found, FALSE if not.
   If found, pgnbr and entrynbr contain the location. If not found,
   they contain the correct location for insertion }
   
 PROCEDURE binsert (VAR f: btree; insentry : btentry; inspointer : btpointer;
                pgnbr : btpointer; entrynbr : bpagesize);
                
 { Insert insentry, inspointer, into btree file f at location pgnbr,
   entrynbr.  Bsearch must be called first to insure uniqueness, and to
   determine the insert location. User calls to binsert must set inspointer
   to zero (0). }
                
                
 PROCEDURE bdelete (VAR f: btree; pgnbr : btpointer; entnbr : bpagesize);
 { Delete from btree file f the entry found at location pgnbr and entnbr.
   Bsearch must be called first to determine correct location. }
 
 PROCEDURE firstentry (VAR f: btree; VAR page : btpointer; 
                       VAR entry : bpagesize);
 { Find lexically first entry in tree f. Return location in page, entry. }
 
 PROCEDURE lastentry (VAR f: btree; VAR page : btpointer; 
                      VAR entry : bpagesize);
 { Find lexically last entry in tree f. Return location in page, entry. }
 
 FUNCTION nextentry (VAR f: btree; thispg : btpointer; thisent : bpagesize;
                VAR nxtpg : btpointer; VAR nxtent : bpagesize) : BOOLEAN;
                
 { Start at thispg, thisent in btree f. Find next lexical entry. Return 
   TRUE if not at end, location in nxtpg, nxtent. Return FALSE if at end,
   location of last entry in nxtpg, nxtent. }
   
 FUNCTION preventry (VAR f: btree; thispg : btpointer; thisent : bpagesize;
                VAR prvpg : btpointer; VAR prvent : bpagesize) : BOOLEAN;
                
 { Start at thispg, thisent in btree f. Find previous lexical entry. Return 
   TRUE if not at beginning, location in nxtpg, nxtent. Return FALSE if at 
   beginning, location of last entry in nxtpg, nxtent. }
   
 PROCEDURE bdump (VAR r: brecord);
 (*      Dump contents of r to terminal*)
 
 PROCEDURE showit(VAR f:btree; pagenbr : btpointer; entrynbr : bpagesize);
 (*      Display contents of tree f, at pagenbr,entrynbr , formatted *)
 
 
 (*******************)  IMPLEMENTATION  (************************)
 
 
 PROCEDURE errtrap (errmsg : STRING); FORWARD;

 (*$I BIO.TEXT*)
 
 (*$I BDEBUG.TEXT*)
 
 (*$I BHKEEP.TEXT*)
 
 (*$I BINTERN.TEXT*)
 
 (*$I BMAIN.TEXT*)
 
 END.
 
 



========================================================================================
DOCUMENT :usus Folder:VOL16:checkbook.text
========================================================================================

{$S+}
PROGRAM Checkbook;
USES (*$U crtinput.code*) CRTInput, 
     (*$U getnumber.code*) GetNumber;

CONST
       DFileName = 'CHECK.MASK.DATA';
       BFileName = 'PREV.BAL.TEXT';
       MaxX = 79;
       MaxY = 23;
       MaxData = 50;
       MaxArray = 20;
       PromptLine = 1;
       MaxChecks = 30;
       MaxDeposits = 10;

TYPE
       YLimits = 0..MaxY;
       XLimits = 0..MaxX;
       DataLimits = 1..MaxData;
       CheckLimits = 1..MaxChecks;
       DepositLimits = 1..MaxDeposits;
       CRTLineArray = PACKED ARRAY [XLimits] OF char;
       DataRec = PACKED RECORD
                   X: XLimits;
                   Y: YLimits;
                   Lngth, Decimal: XLimits;
                 END;
       MaskRec = RECORD
                   Line: ARRAY [YLimits] OF CRTLineArray;
                   Data: ARRAY [DataLimits] OF DataRec;
                 END;
       Money = RECORD  Dollars, Cents: integer;  END;
       Entry = RECORD
                 Amount: money;
                 Description: string[12];
               END;
               
VAR  BS: char;
     LastCheckNo, LastDepositNo: integer;
     TotlChecks, TotlDeposits, PrevBal, Balance: Money;
     PrevDate, Date: String[20];
     Check: ARRAY [CheckLimits] OF Entry;
     Deposit: ARRAY [DepositLimits] OF Entry;
     Mask: MaskRec;
     DataFile: FILE OF MaskRec;
     BalFile: interactive;
 

PROCEDURE WritePrompt (prompt: string);
BEGIN
  GoAndClearLine (PromptLine);
  Write (prompt)
END;


FUNCTION WaitForSp (p: string): boolean;
VAR ch: char;
BEGIN
  Write(CHR (7), p);
  Write ('.  Type a space to continue, <ESCAPE> to abort...');
  REPEAT Read (keyboard, ch) UNTIL (ch = ' ') OR (ch = CHR (27));
  Writeln;  WaitForSp := ch = ' '
END;


PROCEDURE WriteError (prompt: string);
VAR ch: char;
BEGIN
  Gotoxy (0, ErrorLine);
  Write (CHR(7), prompt, '.  Type <space> to go on..');
  REPEAT Read (keyboard, ch) UNTIL ch = ' ';
  GoAndClearLine (ErrorLine);
END;


PROCEDURE GotoDataField (n: integer);
BEGIN
  WITH Mask.Data[n] DO Gotoxy (x,y)
END;


PROCEDURE ClearField (n: integer);
BEGIN
  WITH Mask.Data[n] DO
    BEGIN
      Gotoxy (X,Y);
      Write (' ':Lngth)
    END
END;


PROCEDURE ReadMaskData;
VAR i: integer;
     
BEGIN
  REPEAT
{$I-}
    Reset (DataFile, DFileName);
    IF IORESULT > 0 THEN Reset (Datafile, CONCAT ('#4:', DFileName));
    IF IORESULT > 0 THEN Reset (Datafile, CONCAT ('#5:', DFileName));
{$I+}
    i := IORESULT;
    IF i > 0
      THEN BEGIN
        Writeln('I can''t find "', DFileName, 
          '", needed to use this program.');
        IF NOT Yes ('Do you wish me to try to find it again')
          THEN EXIT (Program)
      END;
  UNTIL i = 0;
  Mask := Datafile^;  ClearScreen;
  FOR i := 0 TO MaxY-1 DO Writeln (Mask.Line[i]);
END;


PROCEDURE GetMoney (DN: datalimits; Prompt: string; VAR Amount: Money);
BEGIN
  WritePrompt (Prompt);
  GetDecimal (Mask.Data[DN].x, Mask.Data[DN].Y, 0, 9999, 2, Amount.Dollars, 
    Amount.Cents);
  GoAndClearLine (PromptLine);
END (*GetMoney*);


PROCEDURE WriteMoney (DN: datalimits; amount: money);
VAR m: integer;
BEGIN
  WITH Mask.Data[DN] DO
    BEGIN
      Gotoxy (X, Y);
      m := Lngth - 4;
      IF (Amount.Dollars < 0) OR (Amount.Cents < 0)
        THEN BEGIN
          m := m -1;
          Write ('-');
        END
        ELSE Write (' ', BS);
      Write (ABS(Amount.dollars):m, '.');
      m := ABS (Amount.Cents);
      IF m DIV 10 = 0 THEN Write ('0');
      Write (m MOD 100);
    END;
END;


PROCEDURE AddMoney (Add1, Add2: Money; VAR Sum: Money);
BEGIN
  Sum.Dollars := Add1.Dollars + Add2.Dollars;
  Sum.Cents := Add1.Cents + Add2.Cents;
  IF Sum.Cents > 99
    THEN BEGIN
      Sum.Cents := Sum.Cents -100;
      Sum.Dollars := Sum.Dollars + 1;
    END;
END;


PROCEDURE SubMoney (minuend, subtrahend: money; VAR result: money);
BEGIN
  Result.Dollars := Minuend.Dollars - Subtrahend.Dollars;
  Result.Cents := Minuend.Cents - Subtrahend.Cents;
  WITH Result DO IF (Dollars > 0) AND (Cents < 0) 
    THEN BEGIN
      Cents := Cents + 100;
      Dollars := Dollars - 1
    END
    ELSE IF (Dollars < 0) AND (Cents > 0)
      THEN BEGIN
        Cents := Cents - 100;
        Dollars := Dollars + 1
      END;
END;


PROCEDURE GetOrdinate (n: integer; VAR Ordinate: String);
VAR prefix: string[2];
BEGIN
  CASE (n MOD 100) DIV 10 OF
    0:  prefix := '';
    1:  prefix := '1';
    2:  prefix := '2';
    3:  prefix := '3';
    4:  prefix := '4';
    5:  prefix := '5';
    6:  prefix := '6';
    7:  prefix := '7';
    8:  prefix := '8';
    9:  prefix := '9'
  END;
  CASE n MOD 10 OF
    0:  prefix := CONCAT (prefix, '0');
    1:  prefix := CONCAT (prefix, '1');
    2:  prefix := CONCAT (prefix, '2');
    3:  prefix := CONCAT (prefix, '3');
    4:  prefix := CONCAT (prefix, '4');
    5:  prefix := CONCAT (prefix, '5');
    6:  prefix := CONCAT (prefix, '6');
    7:  prefix := CONCAT (prefix, '7');
    8:  prefix := CONCAT (prefix, '8');
    9:  prefix := CONCAT (prefix, '9')
  END;
  IF (n MOD 10 > 3) OR (n MOD 10 = 0) OR (n IN [11..13])
    THEN Ordinate := CONCAT (prefix, 'th')
    ELSE CASE n MOD 10 OF
      1: Ordinate := CONCAT (prefix, 'st');
      2: Ordinate := CONCAT (prefix, 'nd');
      3: Ordinate := CONCAT (prefix, 'rd')
    END;
END;


PROCEDURE GetAmount(i: integer; n:Datalimits; VAR amount: money;
   VAR description: string);

VAR 
     prompt: string; 
     ordinate: string[5]; 
     j: integer;
BEGIN
  GetOrdinate (i, Ordinate);
  Prompt := CONCAT ('Please list the number, date,  or description of the ',
    Ordinate, ' item.');
  WritePrompt (prompt);  GotoDataField (n);  FOR i := 1 TO 13 DO Write (BS);
  GetString (12, Descriptn);
  GetMoney (n, 'Now the amount.', amount);
END;


PROCEDURE GetCheck (Checkno: integer);
VAR i: integer;
BEGIN
  GotoDataField(CheckNo);  FOR i := 1 TO 17 DO Write(BS);
  Write(CheckNo:2, ':');  
  WITH Check[CheckNo] DO GetAmount (CheckNo, CheckNo, Amount, Description);
END;


PROCEDURE GetDeposit (DepositNo: integer);
VAR i, Thisfield: integer;
BEGIN
  ThisField := (DepositNo + 30);
  GotoDataField (ThisField);  FOR i := 1 TO 17 DO Write (BS);
  Write(DepositNo:2, ':');
  WITH Deposit[DepositNo] DO GetAmount (DepositNo, ThisField, Amount,
     Description);
END;


PROCEDURE AddEntry(ch: char);
BEGIN
  CASE ch OF
    'C':  IF LastCheckNo < MaxCheck
            THEN BEGIN
              LastCheckNo := LastCheckNo +1;
              GetCheck(LastCheckNo)
            END
            ELSE WriteError (
            'Sorry, I don''t have room for that number of checks');
    'D':  IF LastDepositNo < MaxDeposit
            THEN BEGIN
              LastDepositNo := LastDepositNo+1;
              GetDeposit (LastDepositNo)
            END
            ELSE WriteError (
            'Sorry, I don''t have room for that many deposits');
  END
END;


PROCEDURE FixEntry;
VAR i: integer;  s: string;
BEGIN
  IF (LastCheckNo = 0) AND (LastDepositNo = 0)
    THEN WriteError ('First A)dd checks or deposits before correcting')
    ELSE CASE GetLetter (PromptLine, 
'Fix previously entered C)heck or D)eposit', ['C', 'D']) OF
    'C':  IF LastCheckNo > 0
            THEN BEGIN
              Gotoxy (0, PromptLine);
              IF LastCheckNo > 1
                THEN BEGIN
                  Write('Which check do you wish to fix (1 to ',
                    MaxCheck, ')?  ');
                  GetInteger (-1, -1, 1, LastCheckNo, false, i);
                END
                ELSE i := 1;
              GetCheck (i)
            END
            ELSE WriteError ('First ADD a check before correcting it');
    'D':  IF LastDepositNo > 0
            THEN BEGIN
              Gotoxy (0, PromptLine);
              IF LastDepositNo > 1
                THEN BEGIN
                  Write('Which deposit do you wish to correct (1 to ',
                    MaxDeposit, ')?  ');
                  GetInteger (-1, -1, 1, LastDepositNo, false, i);
                END
                ELSE i := 1;
              GetDeposit (i)
            END
            ELSE WriteError ('First ADD a deposit before correcting it')
  END
END;


PROCEDURE FigureBalance;
VAR i: integer;
BEGIN
  TotlChecks.Dollars := 0;  TotlChecks.Cents := 0;
  TotlDeposits.Dollars := 0;  TotlDeposits.Cents := 0;
  FOR i := 1 TO LastCheckNo DO
    AddMoney (Check[i].Amount, TotlChecks, TotlChecks);
  WriteMoney (45, TotlChecks);
  FOR i := 1 TO LastDepositNo DO
    AddMoney (Deposit[i].Amount, TotlDeposits, TotlDeposits);
  WriteMoney (46, TotlDeposits);
  AddMoney (TotlDeposits, PrevBal, Balance);
  SubMoney (Balance, TotlChecks, Balance);
  WriteMoney (47, Balance)
END;
  
  
PROCEDURE GetData;
VAR quit: boolean;

BEGIN
  quit := false;
  IF PrevDate <> ''
    THEN BEGIN
      WriteMoney (42, PrevBal);  GotoDataField (41);  Write (PrevDate) 
    END;
  REPEAT
    CASE GetLetter (PromptLine,
'add new C)heck or D)eposit, F)ix previous entry, set P)revious balance, Q)uit',
        ['C', 'D', 'F', 'P', 'Q']) OF
      'C':  AddEntry('C');
      'D':  AddEntry('D');
      'F':  FixEntry;
      'P':  BEGIN
              GetMoney (42, 'Please enter correct previous balance.', PrevBal);
              WritePrompt ('Please enter date previous balance was valid.');
              GoToDataField (41);  GetString (20, PrevDate);
            END;
      'Q':  quit := true
    END;
    FigureBalance
  UNTIL quit
END;


PROCEDURE Initialize;
VAR i: integer;
BEGIN
  BS := CHR (backspace);  Date := '';  PrevDate := '';
{$I-}
  Reset (BalFile, BFileName);
  i := IORESULT;
  IF i > 0 THEN BEGIN
      Reset (BalFile, CONCAT ('#4:', BFileName));  i := IORESULT 
    END;
  IF i > 0 THEN BEGIN
      Reset (BalFile, CONCAT ('#5:', BFileName));  i := IORESULT;
    END;
{$I+}
  IF i = 0 
    THEN BEGIN
      Writeln ('Reading previously stored account balance...');
      Readln (BalFile, PrevBal.Dollars, PrevBal.Cents);
      Readln (BalFile, PrevDate);  Close (BalFile, Lock)
    END
    ELSE BEGIN PrevBal.Dollars := 0;  PrevBal.Cents := 0 END;
  LastCheckNo := 0;  LastDepositNo := 0;
  FOR i := 1 TO MaxCheck DO WITH Check[i] DO
    BEGIN Amount.Dollars := 0;  Amount.Cents := 0;  Description := '' END;
  FOR i := 1 TO MaxDeposit DO WITH Deposit[i] DO
    BEGIN Amount.Dollars := 0;  Amount.Cents := 0;  Description := '' END;
END;


PROCEDURE PrintChecks;
VAR List: text;  i: integer;


  PROCEDURE PrintMoney (Amount: Money);
  VAR m: integer;
  BEGIN
    Write (List, '  $');
    IF (Amount.Dollars < 0) OR (Amount.Cents < 0)
      THEN BEGIN
        Write (List, '-');
        m := 4
      END ELSE m := 5;
    Write (List, ABS(Amount.dollars):m, '.');
    m := ABS (Amount.Cents);
    IF m DIV 10 = 0 THEN Write (List, '0');
    Writeln (List, m MOD 100);
  END;


BEGIN
  ClearScreen;  Rewrite (List, 'PRINTER:');
  IF NOT WaitForSp ('Ready to print') THEN EXIT (PrintChecks);
  Writeln (List, 'CHECKING ACCOUNT STATUS UPDATE');
  Writeln (List, '      As of:  ', Date);
  Writeln (List);  Writeln (List);
  Writeln (List, 'I.  Summary of Checks.');
  FOR i := 1 TO LastCheckNo DO WITH Check[i] DO
    BEGIN Write(List, Description:12, ':');  PrintMoney (Amount) END;
  Writeln (List);
  Write (List, 'Total amount of checks =');  PrintMoney (TotlChecks);
  Writeln (List);  Writeln (List);
  Writeln (List, 'II.  Summary of Deposits.');
  FOR i := 1 TO LastDepositNo DO WITH Deposit[i] DO
    BEGIN Write(List, Description:12, ':');  PrintMoney (Amount) END;
  Writeln (List);
  Write (List, 'Total amount of deposits =');  PrintMoney (TotlDeposits);
  Writeln (List);
  Write (List, 'III.  CURRENT BALANCE AS OF ', Date, ' =');
  PrintMoney (Balance);
  Writeln (List);
END;


PROCEDURE SaveBalance;
BEGIN
  ClearScreen;
  Writeln ('Saving your account balance in "', BFilename, '"....');
  Rewrite (BalFile, BFileName);
  Writeln (BalFile, Balance.Dollars, ' ', Balance.Cents);
  Writeln (BalFile, Date);
  CLOSE (BalFile, LOCK)
END;


BEGIN
  Initialize;
  REPEAT Write ('Today''s date?  ');  GetString (20, Date);  Writeln
  UNTIL Yes ('OK');  
  ReadMaskData;  GetData;
  Gotoxy (0, PromptLine);
  IF Yes ('Do you want a printed copy of this series of checks/deposits')
    THEN PrintChecks;
  IF Yes ('Do you want to save your current balance on the disk')
    THEN SaveBalance
END.


========================================================================================
DOCUMENT :usus Folder:VOL16:crtinput.text
========================================================================================

UNIT CRTINPUT;

{Special procedures for controlled CRT input of string, textfile,
 and boolean variables.
 
 COPYRIGHT (c) 1980, James Gagne, President
                     DATAMED RESEARCH
                     1433 Roscomare Road
                     Los Angeles, CA 90024
                     213/472-8825
 ALL RIGHTS RESERVED.  These routines may be used for nonprofit, non-
 commercial purposes only, unless written consent of the author is obtained.}
 
INTERFACE
    
    TYPE
      FileAction = (GetOld, Create) {equivalent to Reset/Rewrite};
      FNameString = string [30];
      chset = set OF char;

    
    PROCEDURE GoAndClearLine(y: integer);  
    FUNCTION Yes (prompt: string): boolean;  
    PROCEDURE ClearScreen;  
    PROCEDURE AllCaps (VAR s:string);
        {convert string to all capital letters}
    
    FUNCTION GetLetter (y: integer; s: string; cset: chset): char;
        {  Writes S at line Y; reads w/o echo, converting alpha to upper case,
         until char is in CSET, then returns this char after erasing line Y.
         The cursor is not moved if Y < 0 or > 23.}
    
    PROCEDURE GetString (MaxLength: integer; VAR Typed: string);
        {See description in IMPLEMENTATION section.}
    
    FUNCTION OpenTextFile 
       (Prompt: string       {your request for the filename}; 
    VAR FileName: FNameString{filename string};
        Action: FileAction   {"GetOld" or "Create"};
        Startline: integer   {linenumber on which to start dialogue}; 
    VAR F: text              {file to be opened})
     : boolean               {true = file opened; false = user aborted};
    
    PROCEDURE GetBoolean (x, y: integer;  VAR DesiredValue: boolean);
    
    
IMPLEMENTATION

  CONST 
     {ASCII characters}
        etx = 3;
        bel = 7;
        bs = 8;
        htab = 9;
        esc = 27;
        del = 127;
        
        RCurs = 18      {Control R ==> move cursor right};
        ErrorLine = 23  {last line on screen is for error messages};
        
  VAR
       Response, ch, EscapeCh: char;
       
FUNCTION Yes (*prompt: string*)(*: boolean*);  
var ch : char;
begin
   write ( prompt, ' (y/n) '  );
   repeat
      read ( keyboard, ch );
   until ch in [ 'Y','y','N','n' ];
   if ch in [ 'Y', 'y' ] then
      begin 
         yes := true;
         write ( 'yes' )
      end
   else 
      begin
         yes := false;
         write ( 'no' )
      end;
end;

PROCEDURE GoAndClearLine(*y: integer*);  

begin
   gotoxy ( 0, y );
   write ( chr( 27 ), chr ( 75 ) );  {H-19 specific}
end;

PROCEDURE ClearScreen;  
BEGIN 
   Write(chr(27), chr(69)) 
END;  {H-19 specific}



PROCEDURE OptionalGotoxy (x,y: integer);
{Leave the cursor where it is if x or y is < 0}
BEGIN
  IF (x >= 0) AND (y >= 0) THEN Gotoxy (x,y);
END;


PROCEDURE AllCaps  {(VAR s:string)};
VAR i, LittletoBig : integer;
BEGIN
  LittletoBig := ORD ('A') - ORD ('a');
  FOR i := 1 TO Length (s) DO
    IF s[i] IN ['a'..'z'] THEN s[i] := CHR (Ord (s[i]) + LittletoBig);
END;


FUNCTION GetLetter {(y: integer; s: string; cset: chset): char};
VAR ch: char;

BEGIN
  IF (y>=0) AND (y<24) THEN GoAndClearLine(y);
  Write(s);
  REPEAT
    Read(keyboard, ch);
    IF (ch IN ['a'..'z']) THEN ch := CHR( ORD(ch) + ORD('A') - ORD('a') )
  UNTIL ch IN cset;
  IF (y >= 0) AND (y < 24) THEN GoAndClearLine (y) ELSE writeln(ch);
  GetLetter := ch
END;


{GETSTRING does the following:
  This routine first types the original string (Typed), followed by dots to the 
maximum string length.  If any char is typed but ETX or ESCAPE, the original 
string is replaced by a row of dots to the maximum length of the string as 
passed by the calling routine.  GetString then reads characters 
until terminated by a typed return or escape or at the point that the string 
is filled by the maximum allowed characters.  Typing a control R at any point
will fill that character with one from the original string; a horizontal tab
will either fill in text, or add spaces, depending on whether the end of the
original string has been reached.  If at any time escape is typed, the original 
string (TYPED) is restored and the procedure terminated.  Otherwise, either a 
return or a full string are taken as end-of-string.  Backspace and Delete work 
per the usual UCSD standard.}

PROCEDURE GetString {(MaxLength: integer; VAR Typed: string[255])};
CONST MaxString = 250;
      FillChar = '.';
VAR j, k, MaxL, StringLength: integer;
    ReadCh: boolean;
    HTabCh, backsp, DeleteCh: char;
    Newstring: String[MaxString];
    Didtype: PACKED ARRAY [1..MaxString] OF char;
    
BEGIN
  IF MaxLength > MaxString THEN MaxL := MaxString ELSE MaxL := MaxLength;
  IF MaxLength = 0
    THEN BEGIN
      Typed := '';
      Exit (GetString);
    END;
  backsp := CHR (bs);
  HTabCh := CHR (Htab);
  EscapeCh := CHR (esc);
  DeleteCh := CHR (del);
  REPEAT        {loop repeated only if DELETE typed}
    StringLength := LENGTH (typed);
    IF StringLength > MaxL
      THEN BEGIN
        Delete (Typed, MaxL+1, StringLength-MaxL);
        StringLength := LENGTH (typed);
      END;
    Write (typed);
    FOR j := StringLength+1 TO maxlength DO Write (FillChar);
    FOR j := 1 TO Maxlength DO write (backsp);
    Read (Keyboard, ch);
    IF ch = EscapeCh
      THEN BEGIN
        Write (typed, ' ': MaxL - StringLength);
        EXIT (GetString)
      END
      ELSE BEGIN
        IF ch = CHR (etx)
          THEN ReadCh := true
          ELSE BEGIN   {If the 1st char <> control C,}
            ReadCh := false; {then erase original string.  }
            FOR j := 1 TO StringLength DO Write (FillChar);
            FOR j := 1 TO StringLength DO Write (backsp);
          END;
        j := 1;
        REPEAT
          IF ReadCh THEN Read (keyboard, ch);
          ReadCh := true;
          IF (ch = CHR (RCurs)) AND (j <= StringLength)
            THEN BEGIN  {The Right-cursor character will keep one     }
              ch := Typed [j];  {character at a time from the original string.}
              Write (ch);
              Didtype[j] := ch;
              j := j + 1
            END
          ELSE IF (ch >= ' ') AND (ch < DeleteCh)
            THEN BEGIN
              Write (ch);
              Didtype[j] := ch;
              j := j + 1
            END
          ELSE IF ch = HTabCh
            THEN REPEAT
              IF j <= StringLength THEN ch := Typed [j] ELSE ch := ' ';
              Write (ch);
              Didtype [j] := ch;
              j := j + 1
            UNTIL (j MOD 8 = 1) OR (j > MaxL)
          ELSE IF (ch = backsp) AND (j > 1) 
            THEN BEGIN
              Write (backsp, FillChar, backsp);
              j := j - 1;
            END
        UNTIL (j > MaxL) OR (ch IN [EscapeCh, DeleteCh]) OR EOLN (keyboard);
        k := j - 1;
        IF EOLN (keyboard) AND (k = 1) THEN k := 0;
        FOR j := 1 TO k DO Write (backsp);
      END
  UNTIL ch < DeleteCh;
  IF ch <> EscapeCh
    THEN BEGIN
      NewString := '';
      FOR j := 1 TO k DO 
        BEGIN
          NewString := CONCAT (NewString, ' ');
          NewString [j] := Didtype [j]
        END;
      Typed := NewString
    END;                {else typed is left alone}
  Write (typed, ' ':(maxlength - Length (typed)));
END (*GetString*);


PROCEDURE WriteErr (Message: string);
BEGIN
  Gotoxy (0, ErrorLine);
  Write (CHR (bel), '-** ERROR **-  ', Message, 
         '.  Tap <spacebar> to continue...');
  REPEAT Read (keyboard, ch) UNTIL ch = ' ';
  GoAndClearLine (ErrorLine)
END;


{OPENTEXTFILE will open a textfile, prompting at lines STARTLINE to STARTLINE+3
 --except for the error message, which is always at the bottom of the screen.  
 It returns the filename and the opened file.  ".TEXT" is added to any filename 
 that needs it.  It returns false if the user quit.}
 
FUNCTION OpenTextFile {(Prompt: string; 
                     VAR FileName: FNameString;
                         Action: FileAction;
                         Startline: integer; 
                     VAR F: text) : boolean};

VAR gotfn: boolean;
    Typed: string [255];
  
BEGIN
  REPEAT
    GoAndClearLine (StartLine);
    GoAndClearLine (StartLine+1);
    GoAndClearLine (StartLine+2);
    GoAndClearLine (StartLine+3);
    Gotoxy (5,StartLine);
    Write (Prompt);
    Gotoxy (15,StartLine+1);
    Write ('-->      ');
    Gotoxy (8,StartLine+2);
    Write ('  (Or just press the <return> key if you wish to quit.)');
    Typed := '';
    Gotoxy (20, StartLine+1);
    GetString (23, Typed);
    IF (typed = ' ') OR (typed = '')
      THEN BEGIN
        GoAndClearLine (StartLine+3);
        Gotoxy (11,StartLine+3);
        IF Yes ('Would you prefer to skip this file')
          THEN BEGIN
            OpenTextFile := false;
            EXIT (OpenTextFile);
          END;
        GoAndClearLine (StartLine+3);
      END
      ELSE BEGIN
        FileName := Typed;
        AllCaps (FileName);
        (*$I-*)
        IF Action = getold
          THEN BEGIN
            Reset (F, typed);
            IF IORESULT > 0 THEN Reset (F, CONCAT (typed, '.TEXT'))
          END
          ELSE BEGIN
            IF (POS ('.TEXT', typed) = 0)
              THEN typed := CONCAT (typed, '.TEXT');
            Rewrite (F, typed);
          END;
        (*$I+*)
        Gotfn := IORESULT = 0;
        IF NOT Gotfn
          THEN CASE IORESULT OF
            1, 4:  WriteErr ('Please check your disk--hardware problem');
            2:     WriteErr ('Unit number is incorrect');
            5, 9:  WriteErr ('Unit or Volume is off line at present');
            6, 10: WriteErr ('Can''t find this file on this disk');
            7:     WriteErr ('Illegal file name...probably too long');
            8:     WriteErr ('No room on this disk for this file');
          END;
      END(*else*)
  UNTIL Gotfn;
  OpenTextFile := true
END;
  

{GETBOOLEAN is a routine to read in a boolean variable; gotoxy
 is optional as before.  If you don't want GOTOXY, consider also
 'YES' from SCREENCONTROL.}
 
PROCEDURE GetBoolean {(x, y: integer; VAR DesiredValue:  boolean)};
VAR ch: char;
    DontGotoxy: boolean;

BEGIN
  DontGotoxy := (x<0) OR (y<0);
  Escapech := CHR (esc);
  IF NOT DontGotoxy
    THEN BEGIN
      GoAndClearLine (22);
      Write ('  Type "Y" for yes, or "N" for no.');
      Gotoxy (x,y);
    END;
  REPEAT Read (keyboard, ch) 
  UNTIL (ch IN ['Y', 'y', 'T', 't', 'N', 'n', 'F', 'f', EscapeCh]);
  CASE ch OF
    'Y', 'y', 'T', 't': BEGIN
                          Write ('YES');
                          DesiredValue := true
                        END;
    'N', 'n', 'F', 'f': BEGIN
                          Write (' no');
                          DesiredValue := false
                        END
  END;
  IF NOT DontGotoxy THEN GoAndClearLine (22)
END;


END.

========================================================================================
DOCUMENT :usus Folder:VOL16:getnumber.text
========================================================================================

UNIT GetNumber;

{Special procedures for controlled CRT input of integers in three flavors.
 
 COPYRIGHT (c) 1980, James Gagne, President
                     DATAMED RESEARCH
                     1433 Roscomare Road
                     Los Angeles, CA 90024
                     213/472-8825
 ALL RIGHTS RESERVED.  These routines may be used for nonprofit, non-
 commercial purposes only, unless written consent of the author is obtained.}
 

INTERFACE
uses (*$U crtinput.code *) crtinput;

  CONST                 {The first 4 are standard ASCII control characters.}
        bell = 7;
        backspace = 8;
        escape = 27;
        delete = 127;
        ErrorLine = 23   {Standard line on the CRT for error messages};

  PROCEDURE GetInteger 
          (x, y,        {desired x/y displacements for START of integer}
                        {If either x or y is < 0, no X-Y movement done.}
           LowerLimit, UpperLimit: integer; {bounds of WantedNo values }
                        {If LowerLimit > UpperLimit, then LowerLimit is}
                        { taken as the WIDTH of the field, and limits are}
                        { calculated by width alone within the procedure.}
           RJustify: boolean;         {do you want it justified R or L?}
           VAR WantedNo: integer);    {the number returned: unchanged if}
                        {<ESC> typed during entry.                      }
  
  PROCEDURE GetDecimal 
          (x, y,                      {same as GetInteger}
           LowerLimit, UpperLimit,    {same as GetInteger; work on WHOLE no. }
           MaxPlaces: integer;        {boundary for decimal = max # of places}
           VAR WholePart, FractnPart: integer);         {returned values; 
                       the fractional value is NORMALIZED to the no. of places,
                       i.e., it = number of 1/(10 EXP MaxPlaces)}


IMPLEMENTATION


PROCEDURE QuietRead (VAR ch: char);
{this is implemented separately in case you wish to modify it.}
BEGIN
  Read (keyboard, ch)
END;


FUNCTION LengthOf (int: integer): integer;
VAR i, j:integer;
BEGIN
  j := int;
  IF j < 0
    THEN BEGIN
      i := 1 (*leave room for "-" sign*);
      j := -j
    END
    ELSE i := 0;
  REPEAT 
    i := i + 1;  
    j := j DIV 10;
  UNTIL j = 0;
  LengthOf := i
END;


FUNCTION FigureWidth (x, y: integer): integer;
{returns the number of characters of whichever integer is larger}
VAR i, j: integer;
BEGIN
  i := LengthOf (x);
  j := LengthOf (y);
  IF j > i THEN FigureWidth := j ELSE FigureWidth := i;
END;


PROCEDURE BackUp (distance: integer);
VAR i: integer; bs: char;
BEGIN
  bs := CHR (backspace);
  FOR i := 1 TO distance DO Write (bs, ' ', bs)
END;


PROCEDURE GetSpace (XYEnabled: boolean);
{for getting attention and then cleaning up the error message}
VAR ch: char;
BEGIN
  Write (CHR (Bell), '.  Type <space> to continue...');
  REPEAT Read (ch) UNTIL ch = ' ';
  IF XYEnabled THEN GoAndClearLine (errorline) ELSE Writeln;
END;


FUNCTION IntInProgress (VAR LastCh: char; VAR wanted: integer): boolean;
{This function reads a character quietly, accepting only appropriate ones,
 updates LASTCH (last char typed) and the integer WANTED appropriately, and
 returns an approximate boolean value of whether we're done.  Used by all
 input routines.}
VAR ch: char;
    ValidChar: boolean;
    
BEGIN
  ValidChar := false;
  REPEAT QuietRead (ch)
  UNTIL (ch IN ['0'..'9', ' ', '+', '-', '.', CHR (delete), CHR (backspace),
                CHR (escape)]);
  IF (ch IN ['0'..'9']) AND (ABS (wanted) < MAXINT DIV 10)
    THEN BEGIN
      IF wanted >= 0
        THEN Wanted := wanted * 10 + ORD (ch) - ORD ('0')
        ELSE Wanted := wanted * 10 - ORD (ch) + ORD ('0');
      ValidChar := true;
    END
  ELSE IF ch = CHR (backspace)
    THEN BEGIN
      IF Wanted < 0
        THEN Wanted := -( (-wanted) DIV 10)
        ELSE Wanted := wanted DIV 10;
      ValidChar := true
    END
  ELSE IF ch = CHR (delete)
    THEN BEGIN
      Wanted := 0;
      ValidChar := true
    END
  ELSE IF ch = '+'
    THEN BEGIN
      IF wanted < 0 THEN wanted := - wanted;
      ValidChar := true
    END
  ELSE IF ch = '-'
    THEN BEGIN
      IF wanted > 0 THEN wanted := - wanted;
      ValidChar := true
    END;
  LastCh := ch;
  IntInProgress := ValidChar
END;


PROCEDURE WriteRFlushInteger (int, width: integer; LastChWasMinus: boolean);
VAR i:integer;
BEGIN
  FOR i := LengthOf (int) TO width - 1 DO Write ('.');
  IF int = 0 
    THEN IF LastChWasMinus THEN Write ('-') ELSE Write ('.')
    ELSE Write (int);
END;


PROCEDURE WriteLFlushInteger (int, width: integer; LastChWasMinus: boolean);
VAR i, j, k: integer;
BEGIN
  j := width - LengthOf (int);
  k := j;
  IF int = 0
    THEN IF LastChWasMinus 
      THEN Write ('-')
      ELSE BEGIN
        k := k + 1;
        Write ('.')
      END
    ELSE Write (int);
  FOR i := 1 TO j DO Write ('.');
  FOR i := 1 TO k DO Write (CHR (backspace));
END;


FUNCTION ValidInteger (LowerLimit, UpperLimit, width: integer;
                         RJustify: boolean;
                     VAR LastChTyped: char; VAR Wanted: integer): boolean;

{Get an integer, justifying the number appropriately as you do so.  Quit if 
 escape or carriage return or period or space typed or the number is as large as
 it can get within the limits.  Return a boolean variable attesting to the
 validity of the number.}
                        
VAR PrevLength: integer;
    Done, UnderTopLimit, NumberWasWritten, StillShort, 
      WriteAMinus, NegativeOnly, PositiveOnly: boolean;

BEGIN
  IF (Wanted < LowerLimit) OR (Wanted > UpperLimit) THEN Wanted := 0;
  NumberWasWritten := Wanted <> 0;
  PrevLength := LengthOf (Wanted);
  IF RJustify
    THEN WriteRFlushInteger (Wanted, width, false)
    ELSE WriteLFlushInteger (Wanted, width, false);
  Done := false;
  StillShort := true;
  UnderTopLimit := true;
  WriteAMinus := false;
  NegativeOnly := UpperLimit <= 0;
  PositiveOnly := LowerLimit >= 0;
  WHILE UnderTopLimit AND StillShort AND NOT Done DO
    IF IntInProgress (LastChTyped, Wanted) 
      THEN BEGIN
        IF PositiveOnly AND (Wanted < 0) THEN Wanted := -Wanted;
        IF NegativeOnly AND (Wanted > 0) THEN Wanted := -Wanted;
        UnderTopLimit := Wanted <= UpperLimit;
        IF UnderTopLimit
          THEN BEGIN
            IF RJustify
              THEN BackUp (width)
              ELSE IF NumberWasWritten THEN Backup (PrevLength);
            WriteAMinus := (LastChTyped = '-') AND NOT PositiveOnly;
            IF RJustify 
              THEN WriteRFlushInteger (Wanted, width, WriteAMinus)
              ELSE WriteLFlushInteger (Wanted, width, WriteAMinus);
            NumberWasWritten := (Wanted <> 0) OR WriteAMinus;
            PrevLength := LengthOf (Wanted);
            StillShort := (PrevLength < width) AND (UpperLimit >= Wanted * 10)
          END;
      END
      ELSE Done := true;
  ValidInteger := (LastChTyped IN [' ', '.', '0'..'9']) 
    AND (Wanted >= LowerLimit) AND UnderTopLimit
END;


PROCEDURE GetInteger {(x, y, LowerLimit, UpperLimit: integer;
                      RJustify: boolean; VAR WantedNo: integer)};
{Main procedure that is used; X & y refer to the START of the field.  Field 
 size is inferred from the maximum number of digits in the two limits.  Plus 
 or minus signs typed at any time invert the sign if appropriate.  An escape 
 typed any time before auto-termination (by a number approaching UpperLimit) 
 will restore the original value of WantedNo.  Nice number movement.}
 
VAR TempInt, width, WorkingUpperLimit, WorkingLowerLimit, i, j: integer;
    XYEnabled, OK, Abort: boolean;
    Lastch: char;
    s: string;
BEGIN
  IF LowerLimit > UpperLimit
    THEN BEGIN
      width := LowerLimit MOD 20     {just in case, reasonable limit on width};
      i := 1;
      FOR j := 1 TO width DO i := i * 10;
      WorkingUpperLimit := i - 1;
      WorkingLowerLimit := (i DIV 10) -1;       {room for "-" sign}
    END
    ELSE BEGIN
      WorkingUpperLimit := UpperLimit;
      WorkingLowerLimit := LowerLimit;
      width := FigureWidth (UpperLimit, LowerLimit)
    END;
  XYEnabled := (X>=0) AND (Y>=0);
  REPEAT
    IF XYEnabled THEN Gotoxy (x,y);
    OK := ValidInteger 
    (WorkingLowerLimit, WorkingUpperLimit, width, RJustify, Lastch, TempInt);
    IF OK
      THEN WantedNo := TempInt
      ELSE IF Lastch = CHR (escape) THEN Abort := true
      ELSE IF TempInt > WorkingUpperLimit
        THEN BEGIN
          IF XYEnabled THEN Gotoxy (0, errorline) ELSE Writeln;
          Write ('Please type a number less than ', WorkingUpperLimit + 1);
          GetSpace (XYEnabled);
          TempInt := WorkingUpperLimit
        END
      ELSE IF TempInt < WorkingLowerLimit
        THEN BEGIN
          IF XYEnabled THEN Gotoxy (0, errorline) ELSE Writeln;
          Write ('Please type a number greater than ', WorkingLowerLimit - 1);
          GetSpace (XYEnabled);
          TempInt := WorkingLowerLimit
        END
  UNTIL OK OR Abort;
  IF RJustify THEN i := width ELSE i := LengthOf (TempInt);
  IF XYEnabled THEN Gotoxy (x,y) ELSE Backup (i);
  IF RJustify
    THEN Write (WantedNo: width)
    ELSE Write (WantedNo)
END;


PROCEDURE WriteAFraction (fractn, decplaces, maxplaces: integer;
                includedots: boolean);
VAR i, j, LeadingZeros: integer;

BEGIN
  i := LengthOf (fractn);
  IF fractn = 0 THEN i := 0;
  LeadingZeros := DecPlaces - i;
  FOR j := 1 TO LeadingZeros DO Write ('0');
  IF fractn > 0 THEN Write (fractn);
  IF IncludeDots
    THEN BEGIN
      i := maxplaces - decplaces;
      FOR j := 1 TO i DO Write ('.');
      FOR j := 1 TO i DO Write (CHR(backspace));
    END;
END;
  
  
FUNCTION GetValidFraction (Wholepart, MaxPlaces: integer; 
         VAR LastChTyped: char; VAR fractn: integer): boolean;
{Workhorse decimal fraction-getter; difficult because leading zeros are much
 more significant than trailing ones, which I allowed anyway because people
 like to type them.}
 
VAR dummy, DumpFractn: boolean; 
    i, j, DecPlaces: integer;

BEGIN
  IF fractn < 0 THEN fractn := - fractn;
  DecPlaces := MaxPlaces;
  IF fractn = 0 
    THEN DecPlaces := 0
    ELSE WHILE (fractn MOD 10 = 0) DO
      BEGIN
        fractn := fractn DIV 10;
        DecPlaces := DecPlaces - 1
      END;
  IF LengthOf (fractn) > MaxPlaces
    THEN BEGIN
      fractn := 0;
      DecPlaces := 0;
    END;
  WriteAFraction (fractn, DecPlaces, MaxPlaces, true);
  REPEAT
    dummy := IntInProgress (LastChTyped, fractn);
    IF fractn < 0 THEN fractn := -fractn;
    DumpFractn := (LastChTyped IN [CHR (delete), CHR (escape)]) 
        OR ((LastChTyped = '+') AND (WholePart < 0))
        OR ((LastChTyped = '-') AND (WholePart > 0));
    Backup (DecPlaces);
    IF (LastChTyped = CHR (backspace)) AND (DecPlaces > 0)
      THEN DecPlaces := DecPlaces -1;
    IF (DecPlaces >= MaxPlaces) AND (fractn = 0) 
      THEN DecPlaces := DecPlaces - 1;
    IF LengthOf (fractn) > MaxPlaces THEN fractn := fractn DIV 10;
    IF (LastChTyped IN ['0'..'9']) AND (DecPlaces < MaxPlaces)
      THEN DecPlaces := DecPlaces + 1;
    WriteAFraction (fractn, DecPlaces, MaxPlaces, true);
  UNTIL DumpFraction OR (LastChTyped = ' ') OR (DecPlaces >= MaxPlaces);
  FOR i := DecPlaces TO MaxPlaces - 1 DO fractn := fractn * 10;
  GetValidFraction := NOT DumpFraction;
END;


PROCEDURE GetDecimal {(x, y, LowerLimit, UpperLimit, MaxPlaces: integer;
                      VAR WholePart, FractnPart: integer)};
{  Main decimal-getting procedure; returns two INTEGERS representing the whole
 and the fractional parts.  The later number is <normalized> by the maximum
 number of decimal places allowed (MaxPlaces), so that if you allow 4 decimal
 places, FractnPart represents integral 1/10,000th's; 2 decimal places returns 
 hundredths.  This procedure is the least well debugged of the sequence.
   I'm going to have to live with the features I provided here to see if I like 
 them:  1)  You work on the two parts of the number separately.  If you finish 
 the whole number with a period, you can work on the fractional part.  If you 
 finish the integral portion with a carriage return or space, the routine exits 
 and the fractional portion is unaltered.  Typing an <escape> at any time 
 before termination aborts the procedure and returns the original values.  
  2) During the actual number entry, if the the original values of the integral 
 and fractional portions are within the range set by the user, they are 
 presented for the user's perusal and optional change; otherwise, they are set 
 to zero.
  3) It was simply too complicated to allow for omitting x & y parameters; I
 couldn't keep track of where I was without a GOTOXY.}

VAR  OK, Abort: boolean;
     LastCh: char;
     TempWhole, TempFrac, width, i, j, WorkingLowerLimit, WorkingUpperLimit:
       integer;
     
BEGIN
  IF LowerLimit > UpperLimit
    THEN BEGIN
      width := LowerLimit MOD 20     {just in case, reasonable limit on width};
      i := 1;
      FOR j := 1 TO width DO i := i * 10;
      WorkingUpperLimit := i - 1;
      WorkingLowerLimit := (i DIV 10) -1;       {room for "-" sign}
    END
    ELSE BEGIN
      WorkingUpperLimit := UpperLimit;
      WorkingLowerLimit := LowerLimit;
      width := FigureWidth (UpperLimit, LowerLimit)
    END;
  TempWhole := WholePart;
  TempFrac := FractnPart;
  Abort := false;
  REPEAT
    Gotoxy (x,y);
    OK := ValidInteger 
      (WorkingLowerLimit, WorkingUpperLimit, width, true, Lastch, TempWhole);
    IF NOT OK 
      THEN IF Lastch = CHR (escape)
        THEN Abort := true
      ELSE IF TempWhole > WorkingUpperLimit
        THEN BEGIN
          Gotoxy (0, ErrorLine);
          Write ('Please type a number less than ', WorkingUpperLimit + 1);
          GetSpace (true);
          TempWhole := WorkingUpperLimit
        END
      ELSE IF TempWhole < WorkingLowerLimit
        THEN BEGIN
          Gotoxy (0, ErrorLine);
          Write ('Please type a number greater than ', WorkingLowerLimit - 1);
          GetSpace (true);
          TempWhole := WorkingLowerLimit
        END
      ELSE Write ('whoops! Forgot About This Error!')
    ELSE IF Lastch IN ['.', '0'..'9'] 
      THEN BEGIN
        Write ('.');
        OK := GetValidFraction (TempWhole, MaxPlaces, Lastch, TempFrac);
        IF NOT OK
          THEN IF LastCh = CHR (escape)
              THEN Abort := true
            ELSE IF LastCh IN ['-', '+'] THEN TempWhole := - TempWhole
            ELSE IF LastCh = CHR (delete)
              THEN BEGIN
                TempWhole := 0;
                TempFrac := 0
              END
            ELSE Write ('whoops!  Unforeseen fraction error.')
      END
  UNTIL Abort OR OK;
  IF OK
    THEN BEGIN
      WholePart := TempWhole;
      FractnPart := TempFrac;
    END;
  Gotoxy (x,y);
  Write (WholePart: width, '.');
  WriteAFraction (FractnPart, MaxPlaces, MaxPlaces, false)
END;
  

END.


========================================================================================
DOCUMENT :usus Folder:VOL16:horton.doc.text
========================================================================================

This is an explanation of those files submitted by Pat Horton.     

These are all text files of one sort or another.

INV is the host file for the inventory system. 
 ADD is the segment which adds to the inventory
 ISSUE does the distribution of inventory.
 BASPROC contains the base procedures.
 BASPROC2 contains Delete, Change, and Sort
 REPORT generates the reports in the system.   
 
 INV.DOC is a formatted documentation for the inventory system.
 
TELE is a program to maintain a data base of telephone calls, by
 whom, to whom, date, time, etc....
 
P is a quick word processor lacking in those features which generally make
 word processors hard to use. It is self teaching and very useful.
 
SORTUNIT is a general purpose three key sort. 
 It is a unit which must be linked into the system library before
 using. 
 
SORT2 is a sequential file sort program which allows for header information
 to not be sorted.
 
XREF is the host text file for the Identifier Cross reference program.
XRSEGS contains the segment procedures called by the program. 
 This program is reproduced from the PASCAL SYSTEM USERS GROUP quarterly
 publication.
 
LIFE is the game of life.  

I hope that the text for the above programs will come in handy at  
some point in space-time for someone.

Pat Horton 6/8/80
           6/20/82  ammended  gws

========================================================================================
DOCUMENT :usus Folder:VOL16:inv.doc.text
========================================================================================

                
          
          
          
          
          
          
          
          
          
          
          
          
                                 Documentation                        
                                for the program                       
                                      INV                             
          
                                  Property of                         
                        Associated Computer Industries                
                                with all rights                       
                              pertaining thereto                      
          
          
                        17751 Sky Park East, Suite g-h                
                               Irvine, Ca. 92714                      
                                (714)-557-0560                        
          
                          Patrick Horton, Programmer                  
          



































                                   (Page  1)

          
          
                Welcome to the ACI  Inventory  Program  Users  Manual.
          This  program  and  manual  assume  some  prior  use  of the
          operating system,  especially the system editor. For further
          information  on the use of the UCSD Pascal  Screen  Oriented
          Editor  see the  WD-90  Pascal  Microengine  (tm)  Reference
          Manual.
          
          TABLE OF CONTENTS                                     page 
          ----------------------------------------------------------  
          cover .................................................  1
          intro & table of contents .............................  2
          files in the system ...................................  3
          GFILE.TEXT ............................................  4
          Getting Started .......................................  5
          A)dd ..................................................  5
          I)ssue ................................................  6
          D)elete ...............................................  6
          C)hange ...............................................  6
          Closing ...............................................  7
          R)eports ..............................................  8
          









































                                   (Page  2)

          
          
                              Files in the system                      
                              -------------------                    
          
                There are four  files  associated  with the  Inventory
          program. They are: the program  itself, the inventory  file,
          the  transaction  archive file, and the assembly group file.
          In  addition  to  these  files  you may  specify  a file for
          output of any name  (usually  output is directed to a device
          however).
          
                The  inventory  file  is  made  up  of  records  which
          contain  the part  number,  a  description  of the part, the
          quantity on hand, and the last date of access.
          
                The transaction  file (archive)  contains an entry for
          every  transaction made to the inventory,  including initial
          quantities.  This  allows  for a  complete  balance  of  all
          transactions.  A  transaction  record  is  made up of a part
          number,   quantity,  date,  a  transaction   number,  and  a
          transaction code.
          
                The assembly  group file contains  information to link
          a single  part number or  designator  to multiple  inventory
          parts.  With it you may  specify a single  part number (as a
          major  assembly   number)  and  individual   items  will  be
          subtracted  from the  inventory as nessecary. In other words
          you might  specify  major part  number A, and this  assembly
          might  use two  part  X's, one part Y, and six part  Z's. In
          this way you can inventory out total assemblies  rather than
          having to make an entry for each screw, washer, etc....
































                                   (Page  3)

          
          
          
                                  GFILE.TEXT                          
                                  ----------                         
          
                The file for the groups is a  sequential  (text)  file
          which you must  build  with the  editor.  It must  reside on
          unit #4 and be called 'GFILE.TEXT'.  Without such a file the
          program  will  not run, so even if you are not  going to use
          this  feature  you must at least  create a dummy  file  that
          meets these specifications.
          
                The  format  of this  file is a line for each  type of
          part  in each  major  assembly.  A line  consists  of  three
          numbers  seperated  by  spaces.  Although  they  are  called
          partnumbers  they may be any  combination of  alpha-numerics
          that your  system will  recognize.  The first  number is the
          major  assembly  part  number, the second is the part number
          that is part of this  assembly,  and the third number is the
          quantity of these parts used in this  assembly. For example,
          given the line:
          
          A-102  f-100  3
          
          we are told that  major  assembly  number  A-102  uses three
          f-100's.  There  may be any  number  of these  lines in this
          file.
          
          


































                                   (Page  4)

          
          
                                Getting Started                        
                                ---------------                      
          
                In order to get started you should  first create (with
          the  editor)  a  file  called  'GFILE.TEXT'  on  unit  #4 as
          described  above. You should also have a new  formatted  and
          zeroed diskette in unit #5, and the program  'INV.CODE' on a
          diskette in unit #4.
          
                Type 'X' for  execute,  followed by the word 'INV' and
          a return  <cr>. The  program  will  search unit five for the
          two  files:  'INV.DATA'  and  'ARC.DATA'.  If not  found the
          program  will  allow you to create  them by merely  entering
          another carriage return.
          
                Once you have done this you may build  your  inventory
          using the A)dd command.
          
          
                                     A)dd                            
                                     ----                            
          
                In  order  to add an item to  inventory  type  'A' for
          A)dd and then enter the part  number of the item you wish to
          add. If the part  number is not  already  in  inventory  you
          will  be  allowed  to add it.  Adding  an item to  inventory
          consists  essentially  of entering a description,  the units
          of  distribution,  the  initial  quantity,  the  date, and a
          transaction  code. This  transaction  code may be any (up to
          ten)  characters  you wish but you should be  consistent.  A
          good idea is to use the word  'initial'  as the  transaction
          codes for  beginning  entries.  The  reason for this is that
          later you may wish to produce  reports by  transaction  code
          so it is of utmost  importance that the codes be spelled the
          same (down to the  capitilization of individual  characters)
          in order to utilize this facility most effficiently.
          
                A)dd is also used when you  receive  goods to be added
          to  inventory  after the number is already in the system. In
          this case you may specify another  transaction  code such as
          'reciept' or some such string.





















                                   (Page  5)

          
          
          
                                    I)ssue                             
                                    ------                           
          
                Once you have built an  inventory  you may  distribute
          it using  the  I)ssue  command.  There are two ways to issue
          items:  S)ingle,  and G)roup.  Issuing a single item amounts
          to  entering  a date,  transaction  code (such as 'sales' or
          'returns'), a part number, and a quantity.
          
                Issuing a group is done by entering the group  number.
          Then  for each  line in the  GFILE  for that  group a screen
          display is made, showing the  description and quantity to be
          used, the quantity in inventory  before the  transaction and
          the quantity in inventory after the transaction.
          
                When this  happens  you have  three  choices.  You can
          enter  a  carriage  return  and  the  transaction   will  be
          completed.  Or  you  can  enter  an  escape  <esc>  and  the
          transaction will be aborted  (including all subsequent lines
          in the  group).  Or  lastly,  you may enter an 'S' for S)kip
          and skip that line and go on to the next item in the group.
          
                For each return entered above, an individual  entry in
          the  transaction  file  will  be  made.  In  this  case  the
          transaction   code  is  given  the  group  number.  This  is
          automatic and may not be changed by the user.
          
          
                                   Deleting                          
                                   --------                          
          
                Sooner  or  later  you  are  either  going  to  make a
          mistake  in using the  system,  or are going to stop using a
          specific  item,  and you are going to want to delete an item
          from the  inventory.  In order to do this you will  type 'D'
          for  delete. The program  will ask you if you wish to delete
          from the inventory file, the transaction  file, or both. You
          will enter the proper  command  followed  by the part number
          you wish to delete and it will be removed from the system.
          
          
                                   Changing                          
                                   --------                          
          
                In order to change a part  number  you must  enter the
          command  C)hange. Then you may specify if you wish to change
          the number in the  inventory,  the  archive,  or both. After
          entering  the old  number and the new  number,  the  program
          will change the part number in the specified files.












                                   (Page  6)

          
          
          
                                    Closing                           
                                    -------                          
          
                Every so often  the  archive  file is going to  become
          over-crowded.  The procedure for taking care of this will be
          to copy the  archive  file onto  another  diskette  and then
          R)emoving  it using the  filer. The  program,  when run will
          make a new  version of this file and you may start  entering
          new  transactions.  This process should be done on a monthly
          basis depending on individual requirements.
          
          

















































                                   (Page  7)

          
          
                                    Reports                           
                                    -------                          
          
                There  are  basically  three  reports  which  you  may
          create. They are (once again)  inventory,  archive, or both.
          To create a report,  type 'R' for report, and then  'I','A',
          or 'B' as the  case may be. The  program  will  then ask you
          for the output  device to which the report  will go. You may
          specify '#6:' for a parallel  printer, '#2:' for the screen,
          and '#8:' for the serial port  printer. In addition to these
          you may enter a  filename,  if for some  reason  you wish to
          save the report.
          
                After  designating  the above  parameters, you will be
          allowed to enter what are called  wildcards.  In the case of
          the  I)nventory  report  you will  enter only a part  number
          wildcard.  With  the  other  reports  you  will  enter  part
          number,  date,  transaction  number,  and  transaction  code
          wildcards.
          
                The  wildcards  serve as  selection  criteria by which
          certain  parts of the data are  included  in the  report. If
          you enter blank carriage  returns for all the wildcards then
          all the  information  in the file  will be  included  in the
          report.
          
                The format for a wildcard  is to specify the items you
          wish filled with question marks where you don't care.
          
                i.e. given the  wildcard  'A-???'  for part number the
          report  would  include all parts that  started with 'A-' and
          that were five or less  characters  in length. The  wildcard
          '?' for  transaction  code  will  pull out all  transactions
          with a single  character  code. The wildcard  '07??80'  will
          pull out all of the  transactions  for  July,  1980. In this
          way  you  can  look at  selected  parts  of the  information
          without dumping the whole file.
          
                (note: It would  probably be a good idea to do a B)oth
          report with no  wildcards  before  closing the archive  file
          out.  This  way you have a record  of all  transactions  and
          quantities 'for the books').




















                                   (Page  8)


========================================================================================
DOCUMENT :usus Folder:VOL16:inv.text
========================================================================================

{         

Program: Inv
         an inventory maintanence program.
         
Programmer: Patrick R. Horton

Copyright: Copyright 1980 (c), Associated Computer Industries
           Permission to copy and distribute for non-profit
           purposes is hereby granted provided that this header
           is included on all copies
           
Revised : 7/15/80 to add vendor partnumber
} 

(*  
{$Q+}                     
{$L-REMOTE:} 
*)

PROGRAM Inventory;                                    
 TYPE arcrec = RECORD  
                partnum : STRING[16];
                code    : STRING[10]; 
                date    : STRING[6];
                trans   : STRING[6];
                qty     : REAL; 
               END;
      invrec = RECORD
                partnum : STRING[16];
                descrip : STRING[24];
                vpart   : STRING[16];
                units   : STRING[5]; 
                ldate   : STRING[6];
                qty     : REAL;
               END;
      xrerec = RECORD  
                part1   : STRING[16];
                part2   : STRING[16];
                qty     : REAL; 
                link    : ^xrerec; 
               END;
      
 VAR invfile : FILE OF invrec;
     arcfile : FILE OF arcrec;
     xrefile : TEXT;
     first, ptr : ^xrerec;
     ntrans, narecs, nirecs, temp : INTEGER;       
     command2,command : CHAR;  

PROCEDURE Uppercase(VAR s : STRING);                FORWARD;    
PROCEDURE Clear;                                    FORWARD; 
PROCEDURE Clrline(x,y : INTEGER);                   FORWARD;                 
PROCEDURE Str(i : INTEGER; VAR s : STRING);         FORWARD;          
PROCEDURE Rdata(x,y,l : INTEGER; VAR s : STRING);   FORWARD;                    
PROCEDURE Getint(x,y : INTEGER; VAR t1 : INTEGER);  FORWARD;     
PROCEDURE Getreal(x,y : INTEGER; VAR r : REAL);     FORWARD;
PROCEDURE Wnirecs;                                  FORWARD; 
PROCEDURE Wnarecs;                                  FORWARD;
FUNCTION Val(s : STRING):INTEGER;                   FORWARD;
FUNCTION rVal(s : STRING):REAL;                     FORWARD;
FUNCTION Chkdate(s : STRING): BOOLEAN;              FORWARD;

{$I ADD.TEXT}   
{$I ISSUE.TEXT} 
{$I REPORT.TEXT} 
{$I BASPROC.TEXT} 
{$I BASPROC2.TEXT} 

BEGIN  
 Initfiles;
 Clear;
 REPEAT 
  Clrline(0,0);
  WRITE( 
  'Inventory :: A)dd, C)hange, D)elete, I)ssue, R)eport, S)ort, Q)uit  :: ');    
  READ(command);
  CASE command OF
   'A','a' : Add;
   'C','c' : Change;
   'D','d' : Delete;
   'I','i' : Issue;
   'R','r' : Report;
   'S','s' : Sort;
   END;
 UNTIL command IN ['Q','q'];
 Closefiles;
END.   


========================================================================================
DOCUMENT :usus Folder:VOL16:invcs.mask.data
========================================================================================

< binary file -- not listed >

========================================================================================
DOCUMENT :usus Folder:VOL16:issue.text
========================================================================================

{     

Program: Inv
         an inventory maintanence program.
         
Programmer: Patrick R. Horton

Copyright: Copyright 1980 (c), Associated Computer Industries
           Permission to copy and distribute for non-profit
           purposes is hereby granted provided that this header
           is included on all copies
           
}

{ISSUE.TEXT}                                          
SEGMENT PROCEDURE Issue;
 VAR ch,ch1 : CHAR;
     found  : INTEGER; 
     date   : STRING[6];
 
 PROCEDURE Group;
  VAR iflg : BOOLEAN;
  BEGIN
   iflg := FALSE;
   Clear; 
   WRITE('enter the group number ---->');
   Rdata(28,0,16,arcfile^.code); 
   REPEAT
    Clrline(0,1);
    WRITE('enter the date ------->'); 
    READLN(date); 
   UNTIL Chkdate(date); 
   ptr := first;
   WHILE ptr<>NIL DO 
    BEGIN
     IF ptr^.part1 = arcfile^.code THEN  
      BEGIN
       found := 0;
       FOR temp := 1 TO nirecs DO
        BEGIN
         SEEK(invfile,temp);  
         GET(invfile); 
         IF invfile^.partnum = ptr^.part2 THEN
          BEGIN
           found := temp;
           temp := nirecs;
          END;
        END;
       IF found <> 0 THEN
        BEGIN     
         WRITELN;
         WRITELN('--------------------------------------------------------');
WRITELN('using ',ptr^.qty:8:2,' ',invfile^.units,' ',invfile^.descrip); 
         WRITELN('old qty =',invfile^.qty:8:2,'  new qty =',
                 invfile^.qty - ptr^.qty:8:2);
         IF (invfile^.qty - ptr^.qty) < 0 THEN 
          WRITELN('CAUTION: you are going to exceed the inventory !!',CHR(7));    
         WRITE('<cr> to continue, <''s''> to skip,  <esc> to abort ');  
         READ(ch);
         IF ch = CHR(27) THEN
          BEGIN  
           Clear;    
           EXIT(Group); 
          END;
         IF NOT (ch IN ['S','s']) THEN
          BEGIN
           IF NOT iflg THEN BEGIN ntrans := ntrans + 1; iflg := TRUE; END; 
           Str(ntrans,arcfile^.trans); 
           arcfile^.date := date;
           arcfile^.qty := -ptr^.qty;    
           invfile^.ldate := arcfile^.date;
           arcfile^.partnum := ptr^.part2;  
           invfile^.qty := invfile^.qty - ptr^.qty;      
           narecs := narecs + 1;
           SEEK(arcfile,narecs);
           PUT(arcfile);
           Wnarecs;
           SEEK(invfile,found);
           PUT(invfile);
          END;
        END; 
      END;   
     ptr := ptr^.link;  
    END;
   END;
   
 BEGIN
  Clear; 
  WRITE('Issue :: S)ingle, G)roup ::'); 
  READ(ch);
  CASE ch OF
   'S','s' : BEGIN
              Clear;
              WRITE('enter partnumber to be issued ---->');
              Rdata(35,0,16,arcfile^.partnum); 
              found := 0;
              FOR temp := 1 TO nirecs DO
               BEGIN
                SEEK(invfile,temp);
                GET(invfile);
                IF invfile^.partnum = arcfile^.partnum THEN  
                 BEGIN
                  found := temp;
                  temp := nirecs;
                 END;
               END;
              IF found <> 0 THEN
               BEGIN
                WRITELN;
                WRITELN('there are currently ',
                         invfile^.qty:8:2,' ',
                         invfile^.units,' ',
                         invfile^.descrip,' in the file');   
                WRITE('how many do you wish to issue --->'); 
                Getreal(0,0,arcfile^.qty);  
                IF arcfile^.qty > invfile^.qty THEN 
                 BEGIN
                  WRITELN('Not enough parts to issue ',arcfile^.qty);
                  FOR temp := 1 TO 15000 DO BEGIN END; 
                  EXIT(Issue);
                  Clear;
                 END; 
                WRITE('enter the transaction code ---->');
                Rdata(0,0,10,arcfile^.code);  
                REPEAT
                 WRITE('enter the date (MMDDYY) ---->');   
                 READLN(arcfile^.date);  
                UNTIL Chkdate(arcfile^.date); 
                invfile^.ldate := arcfile^.date;  
                WRITELN;
                WRITELN('old qty ',invfile^.qty:8:2,'  new qty ',
                       invfile^.qty-arcfile^.qty:8:2);
                WRITELN;
                WRITE('O.K.?');
                READ(ch1);
                IF ch1 IN ['Y','y'] THEN 
                 BEGIN
                  ntrans := ntrans + 1;
                  Str(ntrans,arcfile^.trans);
                  narecs := narecs + 1;
                  arcfile^.qty := -arcfile^.qty;
                  SEEK(arcfile,narecs); 
                  PUT(arcfile);
                  Wnarecs;
                  invfile^.qty := invfile^.qty + arcfile^.qty;
                  SEEK(invfile,found);
                  PUT(invfile);
                 END;
               END;
             END;
   'G','g' : Group;
   END;
 END;


========================================================================================
DOCUMENT :usus Folder:VOL16:p.inc.text
========================================================================================

PROCEDURE Makeformat;
 BEGIN
  REWRITE(format,'pformat');
  WITH format^ DO
   BEGIN
    pmgin       := 6;
    lmgin       := 10;
    rmgin       := 10;
    tmgin       := 5;
    lsize       := 80;
    psize       := 66;
    ofilename   := '#6:';
    rflg        := TRUE;
    pflg        := TRUE;
    sflg        := TRUE;
    mflg        := TRUE;
   END; 
  SEEK(format,0);
  PUT(format);
  CLOSE(format,lock);                            
  RESET(format,'pformat');
 END; 
 
PROCEDURE Chkformat;
 VAR ch1,ch2,ch3,ch4 : CHAR;    
 
 PROCEDURE Help1; 
  BEGIN
   Clear;
   WRITELN('This is the program ''P'' (for P)rint).');
   WRITELN;
   WRITELN('It is a program to print files and do simple text processing.');
   WRITELN('When it is first X)ecuted it will automatically make a file ');
   WRITELN('called ''PFORMAT'' which will contain information about where');
   WRITELN('and how the output should be processed.');
   WRITELN;
   WRITELN('The program takes as input a text file. ');
   WRITELN;
   WRITELN('It processes that file for output. You may specify a filename'); 
   WRITELN('for output (such as ''TEST.TEXT'') or you may specify a device');
   WRITELN('(such as ''#6:''). The text processor does the task of right');
   WRITELN('justification, which is filling a line with blanks so that the');
   WRITELN('right margin is nice and even. Any time a blank line or a line ');
   WRITELN('starting with a blank is encountered it is assumed to start a');
   WRITELN('new paragraph.');
   WRITELN; 
   WRITELN;  
   WRITELN('for further information type ''^'' followed by a <return> when');
   WRITELN('you get the original screen prompt back.');
   WRITELN;
   WRITE('<return> to continue >');
   READLN;
  END;
  
  
 PROCEDURE Dispformat;  
  BEGIN
   WITH format^ DO   
    BEGIN
     Clear;
     WRITELN; 
     WRITELN;
     WRITELN('P)aragraph indentation ---->',pmgin); 
     WRITELN('L)eft margin           ---->',lmgin);
     WRITELN('R)ight margin          ---->',rmgin);
     WRITELN('T)op page1 margin      ---->',tmgin);
     WRITELN('C)haracters per line   ---->',lsize);           
     WRITELN('N)umber of lines/page  ---->',psize);
     WRITELN('O)utput filename       ---->',ofilename);   
     WRITELN;
     WRITELN; 
     WRITE  ('S1) right justify      ---->');
     IF rflg THEN WRITELN('Yes') ELSE WRITELN('No');    
     WRITE  ('S2) pagination         ---->');                                             
     IF pflg THEN WRITELN('Yes') ELSE WRITELN('No');  
     WRITE  ('S3) stop between pages ---->');
     IF sflg THEN WRITELN('Yes') ELSE WRITELN('No');  
     WRITE  ('S4) use margins always ---->');        
     IF mflg THEN WRITELN('Yes') ELSE WRITELN('No');
     WRITELN; 
     GOTOXY(40,4);
     WRITELN('H)elp'); 
     GOTOXY(40,5);
     WRITELN('Q)uit');
    END;           
  END;
 
 PROCEDURE Help3; 
  VAR ch6 : CHAR;
  BEGIN
   GOTOXY(0,0);  
   Clr;
   WRITE('Which switch ? ');
   READ(ch6);
   FOR temp1 := 16 TO 23 DO BEGIN  GOTOXY(0,temp1); Clr; END;
   GOTOXY(0,16);
   CASE ch6 OF  
    '1' : BEGIN
           WRITELN('This is the right justification switch.');
           WRITELN('It turns the text processor completely on or off.');  
           WRITELN('When ON all text will be made into paragraphs');
           WRITELN('unless specifically marked otherwise');
           WRITE('<return> to continue');
           READLN(keyboard); 
           FOR temp1 := 16 TO 23 DO
            BEGIN
             GOTOXY(0,temp1);
             Clr;
            END;
           GOTOXY(0,16);             
           WRITELN('The method for marking text which is to be');                             
           WRITELN('right justified or not is to include a ''~'''); 
           WRITELN('in the text. This character (tilde) acts as');
           WRITELN('a switch to turn the right justification on');
           WRITELN('and off from within the text');  
           WRITE('<return> to continue');
           READLN(keyboard);   
           FOR temp1 := 16 TO 23 DO
            BEGIN
             GOTOXY(0,temp1);
             Clr;
            END;
           GOTOXY(0,16);
           WRITELN('The switch must be on or the tilde will have no effect.');
           WRITELN('The justification starts out on, and upon');
           WRITELN('encountering a ''~'' it is turned off.');
           WRITELN('every encounter of this character switches');
           WRITELN('The right justification to its opposite state');
          END;
    '2' : BEGIN  
           WRITELN('This switch specifies whether or not to');
           WRITELN('include page numbers at the end of the');
           WRITELN('page.');
          END;
    '3' : BEGIN  
           WRITELN('This switch tells the program to stop after');
           WRITELN('every page to allow you to change paper.');                   
          END;
    '4' : BEGIN              
           WRITELN('This switch allows you to include or not');
           WRITELN('include the top and left margins on non-');
           WRITELN('right justified text.');
          END;
        END;
  END;
  
 PROCEDURE Help;
  VAR ch5 : CHAR;
  BEGIN
   GOTOXY(0,0);
   Clr;
   WRITE('Help with what? ');
   READ(ch5);
   FOR temp1 := 16 TO 23 DO
    BEGIN  
     GOTOXY(0,temp1);
     Clr;
    END;
   GOTOXY(0,16);
   CASE ch5 OF 
    'P','p' : BEGIN  
               WRITELN('This is the indentation at the beginning of a ');
               WRITELN('paragraph. This only comes into play when the ');        
               WRITELN('right justification is set to yes.');
              END;
    'L','l' : BEGIN
               WRITELN('This is the left margin. It comes into play when');
               WRITELN('either the right justification is set to yes or');
               WRITELN('always use margins is set to yes.');   
              END; 
    'R','r' : BEGIN
               WRITELN('This is the right margin setting. It is only active');
               WRITELN('When the right justification is set to yes.');
              END; 
    'T','t' : BEGIN
               WRITELN('This is the top of the page margin. It is only active');
               WRITELN('at the top of the FIRST page, and only when right');    
               WRITELN('justification is set to yes or always use margins');
               WRITELN('is set to yes.'); 
              END;
    'C','c' : BEGIN 
               WRITELN('This is the number of columns wide the paper is.');
               WRITELN('If you are using 8 by 11 paper with ten characters');  
               WRITELN('per inch then the paper is 80 characters wide.');
              END;  
    'N','n' : BEGIN
               WRITELN('This is the number of lines per page. If you are');
               WRITELN('using 8 by 11 paper with 6 lines per inch then');
               WRITELN('the number of lines per page is 66.'); 
              END;
    'O','o' : BEGIN
               WRITELN('This is the output filename. It may be a file');
               WRITELN('such as ''TEST.TEXT'', or it may be a device. ');
               WRITELN('The common devices are: ''#2:'' is the screen,');
               WRITELN('''#6:'' is the parallel port printer, and ''#8:''');
               WRITELN('is the serial port printer.');
              END; 
    'S','s' : Help3;
    END;  
  END;


========================================================================================
DOCUMENT :usus Folder:VOL16:p.text
========================================================================================

PROGRAM P;                                                                                                                                                                                           
 VAR ifile,ofile         : TEXT;
     temp,page,linat,  
     temp1,temp2,nlwg    : INTEGER; 
     oline,iline,  
     ifilename,
     lmarg,pmarg,token   : STRING;     
     newpar,epar         : BOOLEAN;
     format : FILE OF RECORD
               tmgin,pmgin,
               lmgin,rmgin,lsize,psize : INTEGER; 
               ofilename     : STRING;
               mflg,rflg,pflg,sflg          : BOOLEAN; 
              END;

PROCEDURE Clear;
 BEGIN
  gotoxy (0, 0 );
  WRITE(CHR(27),CHR(69));   {H-19 specific}
 END;
 
PROCEDURE Clr;  
 BEGIN
  WRITE(CHR(27),chr(75));   {h-19 specific}
 END;

 (*$I p.inc.text*)
 
 PROCEDURE Chgformat;    
  BEGIN
   RESET(format,'pformat');            
   SEEK(format,0);
   GET(format);
   Dispformat;
   REPEAT 
    GOTOXY(0,0); 
    Clr;
    WRITE('command ? ');                   
    READ(ch2);    
    WITH format^ DO 
    CASE ch2 OF 
     'H','h' : Help;
     'P','p' : BEGIN GOTOXY(28,2); Clr; READLN(pmgin); END;  
     'L','l' : BEGIN GOTOXY(28,3); Clr; READLN(lmgin); END;  
     'R','r' : BEGIN 
                GOTOXY(28,4); Clr; GOTOXY(40,4); 
                WRITELN('H)elp'); GOTOXY(28,4);
                READLN(rmgin); 
               END;       
     'T','t' : BEGIN 
                GOTOXY(28,5); Clr; GOTOXY(40,5);   
                WRITELN('Q)uit'); GOTOXY(28,5);
                READLN(tmgin); 
               END;  
     'C','c' : BEGIN GOTOXY(28,6); Clr; READLN(lsize); END;       
     'N','n' : BEGIN GOTOXY(28,7); Clr; READLN(psize); END;  
     'O','o' : BEGIN GOTOXY(28,8); Clr; READLN(ofilename); END;   
     'S','s' : BEGIN GOTOXY(0,0);  Clr;   
                WRITE('which switch (1,2 or 3) --->');
                READ(ch3);
                CASE ch3 OF
                 '1' : BEGIN GOTOXY(28,11); Clr; READ(ch4);                    
                        IF ch4 IN ['Y','y'] THEN 
                        BEGIN rflg := TRUE; GOTOXY(28,11); WRITELN('Yes'); END                   
                        ELSE
                        BEGIN rflg := FALSE; GOTOXY(28,11); WRITELN('No'); END;
                       END;     
                 '2' : BEGIN GOTOXY(28,12); Clr; READ(ch4);                       
                        IF ch4 IN ['Y','y'] THEN     
                        BEGIN pflg := TRUE; GOTOXY(28,12); WRITELN('Yes'); END            
                        ELSE   
                        BEGIN pflg := FALSE; GOTOXY(28,12); WRITELN('No'); END;
                       END;     
                 '3' : BEGIN GOTOXY(28,13); Clr; READ(ch4); 
                        IF ch4 IN ['Y','y'] THEN       
                        BEGIN sflg := TRUE; GOTOXY(28,13); WRITELN('Yes'); END
                        ELSE 
                        BEGIN sflg := FALSE; GOTOXY(28,13); WRITELN('No'); END;  
                       END;     
                 '4' : BEGIN GOTOXY(28,14); Clr; READ(ch4);         
                        IF ch4 IN ['Y','y'] THEN         
                        BEGIN mflg := TRUE; GOTOXY(28,14); WRITELN('Yes'); END
                        ELSE 
                        BEGIN mflg := FALSE; GOTOXY(28,14); WRITELN('No'); END;
                       END;     
                 END;   
               END;   
     END;
    UNTIL ch2 IN ['Q','q'];  
    FOR temp1 := 16 TO 23 DO
     BEGIN     
      GOTOXY(0,temp1);              
      Clr;
     END;
    GOTOXY(0,18);
    WRITE('update ?');
    READ(ch2);
    IF ch2 IN ['Y','y'] THEN
     BEGIN
      SEEK(format,0);
      PUT(format);
     END;
    CLOSE(format);
  END;  
  
 
 BEGIN 
  {$I-}
  RESET(format,'pformat'); 
  {$I+}  
  IF IORESULT <> 0 THEN Makeformat;
  CLOSE(format);
  REPEAT 
   Clear;
   WRITELN('Welcome to the P)rint program.');
   WRITELN;
   WRITELN;
   WRITELN('enter a ''H'' followed by a <return> for Help,'); 
   WRITELN('or enter a ''^'' followed by a <return> to change the format,');  
   WRITELN('or enter a lone <return> to exit the program,');  
WRITELN('or enter the filename of a file to be printed followed by <return>.');
   WRITELN;
   WRITE('----->');
   READLN(ifilename);  
   IF LENGTH(ifilename)=0 THEN 
    BEGIN  
     Clear;
     EXIT(P);        
    END;
   IF LENGTH(ifilename)=1 THEN IF ifilename[1] IN ['H','h'] THEN Help1; 
   IF POS('^',ifilename)=1 THEN Chgformat; 
   FOR temp1 := 1 TO LENGTH(ifilename) DO
    IF ifilename[temp1] IN ['a'..'z'] THEN 
     ifilename[temp1] := CHR(ORD(ifilename[temp1])-32);
   IF POS('.TEXT',ifilename)=0 THEN ifilename := CONCAT(ifilename,'.TEXT');                  
  {$I-} 
  RESET(ifile,ifilename);          
  {$I+} 
 UNTIL IORESULT=0;
END;     
 
  
 PROCEDURE Chkline;
 VAR ch : CHAR;
  BEGIN 
   IF format^.ofilename<>'#2:' THEN WRITE('.');          
   linat := linat + 1; 
   IF format^.pflg AND (linat=format^.psize-3)  THEN     
    BEGIN
     linat := 0;
     page := page + 1; 
     IF NOT (EOF(ifile) AND (page=1)) THEN  
      BEGIN
       WRITELN(ofile);   
       WRITE(ofile,' ':((format^.lsize DIV 2)-3)); 
       WRITELN(ofile,'Page ',page:3);
       WRITELN(ofile);
       IF format^.sflg THEN   
        BEGIN
         WRITELN;  
         WRITE('<cr> to continue, <esc> to quit >');      
         READ(keyboard,ch);                 
         WRITELN;
         IF ch = CHR(27) THEN  
          BEGIN
           Clear;
           CLOSE(ofile,lock);
           EXIT(P);
          END;      
         IF format^.ofilename <> '#2:' THEN WRITE('printing '); 
        END;  
      END    
     ELSE FOR temp1 := 1 TO 3 DO WRITELN(ofile);
    END;
  END;
  
PROCEDURE Straightout;          
 BEGIN  
  IF format^.ofilename<>'#2:' THEN
   BEGIN
    WRITELN;        
    WRITE  ('printing ');
   END;
  WHILE NOT(EOF(ifile)) DO
   BEGIN
    IF format^.mflg THEN WRITE(ofile,lmarg);
    READLN(ifile,oline); 
    WRITELN(ofile,oline);
    Chkline; 
   END; 
 END;  
     
PROCEDURE Rjustify; FORWARD;                

PROCEDURE Outline;
 BEGIN  
  (*
  WRITE('outline called w/  '); 
  IF epar THEN WRITE('epar true,') ELSE WRITE('epar false,');  
  IF newpar THEN WRITELN(' newpar true') ELSE WRITELN(' newpar false');  
  *)
  IF NOT epar THEN Rjustify;       
  WRITE(ofile,lmarg);      
  IF newpar THEN WRITE(ofile,pmarg);  
  WRITELN(ofile,oline);   
  Chkline;
  IF newpar AND (LENGTH(oline)<>0) THEN newpar := FALSE; 
  oline := token;         
  token := '';
 END;

PROCEDURE Getnext; 
 BEGIN
  REPEAT
   iline := '';        
   READLN(ifile,iline);  
   IF (LENGTH(iline)=0) OR (POS(' ',iline)=1) OR (POS('~',iline)<>0)              
   THEN                    
    BEGIN
     epar := TRUE;    
     WHILE POS(' ',iline)=1 DO DELETE(iline,1,1);   
     IF LENGTH(oline)<>0 THEN Outline;     
     epar := FALSE; newpar := TRUE;
     IF LENGTH(iline)=0 THEN  
      BEGIN
       WRITELN(ofile);   
       Chkline;  
      END;
     IF POS('~',iline)<>0 THEN
      BEGIN
       WHILE POS('~',iline)<>0 DO DELETE(iline,POS('~',iline),1);
       REPEAT
        IF format^.mflg THEN WRITE(ofile,lmarg);
        WRITELN(ofile,iline); 
        Chkline;
        READLN(ifile,iline);       
       UNTIL (EOF(ifile)) OR (POS('~',iline)<>0);  
       WHILE POS('~',iline)<>0 DO DELETE(iline,POS('~',iline),1);  
       WHILE POS(' ',iline)=1 DO DELETE(iline,1,1);
       IF LENGTH(iline)=0 THEN  
        BEGIN
         WRITELN(ofile);   
         Chkline;
        END;
      END;  
    END;   
  UNTIL (LENGTH(iline)<>0) OR (EOF(ifile));  
 END; 

PROCEDURE Getoken;    
 BEGIN
  token := '';    
  REPEAT 
   IF LENGTH(iline)=0 THEN Getnext; 
   IF POS(' ',iline)<>0 THEN             
    BEGIN    
     token := COPY(iline,1,POS(' ',iline)-1);             
     DELETE(iline,1,POS(' ',iline));    
    END
   ELSE
    BEGIN  
     token := iline;  
     iline := '';
    END;
  UNTIL (LENGTH(token)<>0) OR (EOF(ifile));     
 END;   
     
FUNCTION Addable : BOOLEAN;    
 VAR intb : BOOLEAN;  
     temp3 : INTEGER;
 BEGIN 
  intb := FALSE;    
  temp3 := 0;    
  temp3 := LENGTH(oline)+LENGTH(token)+1;      
  IF newpar THEN temp3 := temp3 + format^.pmgin;
  WITH format^ DO IF temp3 <= (lsize-lmgin-rmgin) THEN intb := TRUE;       
  Addable := intb; 
 END;      
 
PROCEDURE Rjustify;            
 VAR srt,srted,pspace,lwg   : ARRAY[0..50] OF INTEGER;         
     numtoadd               : INTEGER;          
     
 PROCEDURE Addtoall(i : INTEGER);      
  VAR lstcharspace : BOOLEAN;                  
  BEGIN  
   temp1 := 0;  
   lstcharspace := FALSE;      
   WHILE temp1 < LENGTH(oline) DO                   
    BEGIN
     temp1 := temp1 + 1;    
     IF oline[temp1]<>' ' THEN            
      IF lstcharspace THEN                   
       BEGIN
        FOR temp2 := 1 TO i DO INSERT(' ',oline,temp1);                  
        temp1 := temp1 + i;        
        lstcharspace := FALSE;                
       END
      ELSE
     ELSE lstcharspace := TRUE;       
    END;        
  END; 
  
 PROCEDURE Addrems(i : INTEGER);        
  VAR prevhi,temp3 : INTEGER;                    
  BEGIN
   FOR temp1 := 1 TO i DO    
    BEGIN          
     prevhi := 0;                        
     FOR temp2 := 1 TO i DO   
      IF srted[temp2] > prevhi THEN 
       BEGIN    
        prevhi := srted[temp2];        
        temp3 := temp2;
       END;        
     INSERT(' ',oline,pspace[srted[temp3]]+ 
      (srted[temp3]-1)*(numtoadd DIV nlwg));        
     srted[temp3] := 0;     
    END;   
  END; 
  
 PROCEDURE Sortlwg;
  VAR prevhi : INTEGER;          
  BEGIN
   FOR temp1 := 1 TO nlwg DO srt[temp1] := lwg[temp1];                 
   FOR temp1 := 1 TO nlwg DO      
    BEGIN
     prevhi := 0;
     FOR temp2 := 1 TO nlwg DO 
      IF srt[temp2]>prevhi THEN         
       BEGIN
        prevhi := srt[temp2];         
        srted[temp1] := temp2;                             
       END;
     srt[srted[temp1]] := 0;          
    END;
  END;     
 
  BEGIN (* Rjustify *)         
   temp1 := 0;                                      
   nlwg := 0;    
   WHILE temp1 < LENGTH(oline) DO                           
    BEGIN
     temp1 := temp1 + 1;
     IF oline[temp1]=' ' THEN                    
      BEGIN 
       nlwg := nlwg + 1;             
       pspace[nlwg] := temp1;   
      END;    
    END;
   pspace[0] := 0;    
   pspace[nlwg+1] := LENGTH(oline)+1;         
   FOR temp1 := 1 TO nlwg DO         
    lwg[temp1] := pspace[temp1+1] - pspace[temp1-1] - 1;                                    
   Sortlwg;
   WITH format^ DO numtoadd := lsize - lmgin - rmgin - LENGTH(oline);               
   IF newpar THEN numtoadd := numtoadd - format^.pmgin;                     
   IF nlwg <> 0 THEN                           
    BEGIN
     IF numtoadd DIV nlwg >= 1 THEN Addtoall(numtoadd DIV nlwg);    
     IF numtoadd MOD nlwg >= 1 THEN Addrems(numtoadd MOD nlwg);  
    END;   
  END; 


PROCEDURE Justout;       
 BEGIN  
  IF format^.ofilename<>'#2:' THEN
   BEGIN
    WRITELN;  
    WRITE  ('printing ');
   END;
  
  pmarg := '';   
  oline := '';
  iline := '';
  
  FOR temp1 := 1 TO format^.pmgin DO pmarg := CONCAT(pmarg,' ');        
  
  epar := FALSE;         
  newpar := TRUE;
  
  WHILE NOT EOF(ifile) DO         
   BEGIN
    Getoken;
    IF Addable THEN 
     BEGIN 
      IF LENGTH(oline)<>0 THEN oline := CONCAT(oline,' ',token)     
                          ELSE oline := token;  
     END
    ELSE Outline;
   END;
  
  END;  

BEGIN (* P *)   
 REPEAT
  Clear;     
  Chkformat;   
  
  GOTOXY(0,20);
  Clr;
  
  WRITE('enter a carriage return when ready >');    
  READLN;
  
  IF format^.rflg OR format^.mflg THEN linat := format^.tmgin
                  ELSE linat := 0;    
  page  := 0;
  
  REWRITE(ofile,format^.ofilename);
   
  lmarg := '';    
  FOR temp1 := 1 TO format^.lmgin DO lmarg := CONCAT(lmarg,' ');        
  IF format^.rflg OR format^.mflg THEN   
   FOR temp1 := 1 TO format^.tmgin DO WRITELN(ofile);
 
  IF NOT format^.rflg THEN Straightout ELSE Justout;    
    
  IF format^.pflg AND (linat <> 0) THEN    
   REPEAT
    WRITELN(ofile);  
    Chkline;
   UNTIL linat = 0;
    
  CLOSE(ofile,lock);
  CLOSE(ifile);
 
 UNTIL FALSE; 
END.


========================================================================================
DOCUMENT :usus Folder:VOL16:report.text
========================================================================================

{       

Program: Inv
         an inventory maintanence program.
         
Programmer: Patrick R. Horton

Copyright: Copyright 1980 (c), Associated Computer Industries
           Permission to copy and distribute for non-profit
           purposes is hereby granted provided that this header
           is included on all copies
           
}

{REPORT.TEXT}                                                             
SEGMENT PROCEDURE Report;
 VAR ch737,ch : CHAR;
     partwild : STRING[16];
     codewild : STRING[10];
     datewild : STRING[6];
     tranwild : STRING[6];
     ofile    : TEXT;
     oname    : STRING;
     linat    : INTEGER;
 
  PROCEDURE Chkpage;
   VAR ch1 : CHAR;
   BEGIN
    IF (linat >=20) AND (oname = '#2:') THEN    
     BEGIN
      WRITE('<cr> to continue, <esc> to quit'); 
      READ(KEYBOARD,ch1); 
      WRITELN(CHR(11));
      WRITE(CHR(27),'T',CHR(0),CHR(0),CHR(0),CHR(0));
      IF ch1 = CHR(27) THEN
       BEGIN
        Clrline(0,0);
        EXIT(Report);
       END;
      linat := 0; 
     END 
   END; 
 
 FUNCTION Min(a,b : INTEGER) : INTEGER; 
  BEGIN
   IF a<b THEN Min := a ELSE Min := b;
  END;
  
 FUNCTION Trawildok : BOOLEAN;  
  VAR intb : BOOLEAN;
      temp : INTEGER;
  BEGIN
   intb := TRUE;
   
   FOR temp := 1 TO Min(LENGTH(tranwild),LENGTH(arcfile^.trans)) DO    
    IF (tranwild[temp]<>'?') AND (tranwild[temp]<>arcfile^.trans[temp]) 
     THEN intb := FALSE;
     
   IF LENGTH(tranwild)>LENGTH(arcfile^.trans) THEN       
    FOR temp := LENGTH(arcfile^.trans)+1 TO LENGTH(tranwild) DO   
     IF tranwild[temp]<>'?' THEN intb := FALSE;  
   
   IF LENGTH(tranwild)<LENGTH(arcfile^.trans) THEN intb := FALSE;
   
   {tranwild vs. arcfile^.trans}      
   Trawildok := intb;
  END;    
 
 FUNCTION Otherwildok : BOOLEAN;    
  VAR intb : BOOLEAN;
      temp : INTEGER;
  BEGIN
   intb := TRUE;
   
   FOR temp := 1 TO Min(LENGTH(codewild),LENGTH(arcfile^.code)) DO 
    IF (codewild[temp]<>'?') AND (codewild[temp]<>arcfile^.code[temp])
     THEN intb := FALSE;
     
   IF LENGTH(codewild)>LENGTH(arcfile^.code) THEN
    FOR temp := LENGTH(arcfile^.code)+1 TO LENGTH(codewild) DO
     IF codewild[temp]<>'?' THEN intb := FALSE;       
     
   FOR temp := 1 TO Min(LENGTH(datewild),LENGTH(arcfile^.date)) DO
    IF (datewild[temp]<>'?') AND (datewild[temp]<>arcfile^.date[temp])         
      THEN intb := FALSE;
      
   IF LENGTH(datewild)>LENGTH(arcfile^.date) THEN
    FOR temp := LENGTH(arcfile^.date)+1 TO LENGTH(datewild) DO            
     IF datewild[temp]<>'?' THEN intb := FALSE;
         
   IF (LENGTH(codewild)<LENGTH(arcfile^.code)) OR 
      (LENGTH(datewild)<LENGTH(arcfile^.date)) THEN intb := FALSE; 
      
   {codewild vs. arcfile^.code AND datewild vs. arcfile^.date}    
   Otherwildok := intb AND Trawildok;
  END; 
  
 FUNCTION Wpartok : BOOLEAN; 
  VAR intb : BOOLEAN;
      temp : INTEGER;
  BEGIN
   intb := TRUE;
   
   FOR temp := 1 TO Min(LENGTH(partwild),LENGTH(invfile^.partnum)) DO  
    IF (partwild[temp]<>'?') AND (partwild[temp]<>invfile^.partnum[temp]) 
     THEN intb := FALSE;
     
   IF LENGTH(partwild)>LENGTH(invfile^.partnum) THEN   
    FOR temp := LENGTH(invfile^.partnum)+1 TO LENGTH(partwild) DO 
     IF partwild[temp]<>'?' THEN intb := FALSE;
   
   IF LENGTH(partwild)<LENGTH(invfile^.partnum) THEN intb := FALSE;
   
   {partwild vs. invfile^.partnum}      
   Wpartok := intb;
  END;  
   
 FUNCTION Arcwildok : BOOLEAN; 
  VAR intb : BOOLEAN;
      temp : INTEGER;
  BEGIN  
   intb := TRUE;  
   
   FOR temp := 1 TO Min(LENGTH(partwild),LENGTH(arcfile^.partnum)) DO      
    IF (partwild[temp]<>'?') AND (partwild[temp]<>arcfile^.partnum[temp]) 
     THEN intb := FALSE;  
     
   IF LENGTH(partwild)>LENGTH(arcfile^.partnum) THEN   
    FOR temp := LENGTH(arcfile^.partnum)+1 TO LENGTH(partwild) DO   
     IF partwild[temp]<>'?' THEN intb := FALSE;
   
   IF LENGTH(partwild)<LENGTH(arcfile^.partnum) THEN intb := FALSE;
   
   {partwild vs. arcfile^.partnum}      
   Arcwildok := intb;
  END;    
 
 
 PROCEDURE Invreport;    
  VAR temp1 : INTEGER;
      aflg : BOOLEAN;
  BEGIN   
   FOR temp := 1 TO nirecs DO    
    BEGIN
     SEEK(invfile,temp);
     GET(invfile);
     IF Wpartok THEN
      BEGIN
       IF ch IN ['B','b'] THEN 
        BEGIN
         WRITELN(ofile);        
         linat := linat + 1;
         Chkpage;
        END;
       WITH invfile^ DO 
        BEGIN
         WRITE(ofile,partnum);
         IF LENGTH(partnum)<16 THEN WRITE(ofile,' ':(16-LENGTH(partnum)));
         WRITE(ofile,' ',descrip);
         IF LENGTH(descrip)<24 THEN WRITE(ofile,' ':(24-LENGTH(descrip))); 
         WRITE(ofile,' ',vpart);
         IF LENGTH(vpart)<16 THEN WRITE(ofile,' ':(16-LENGTH(vpart))); 
         WRITELN(ofile,' ',units:5,' ',qty:8:2);            
        END;
       linat := linat + 1; 
       Chkpage;
       IF ch IN ['B','b'] THEN   
        BEGIN
         aflg := FALSE;
         FOR temp1 := 1 TO narecs DO   
          BEGIN
           SEEK(arcfile,temp1);
           GET(arcfile);  
           IF arcfile^.partnum = invfile^.partnum THEN
            BEGIN
             IF Otherwildok THEN  
              BEGIN
               IF NOT aflg THEN          
                BEGIN
                 WRITELN(ofile,' ':18,'Transaction  ','Code':10,'  ',     
                         'Date':6,'       ','Qty'); 
                 WRITELN(ofile,'                  ------',  
                         '-----------------------------------');   
                 linat := linat + 2;
                 Chkpage;
                 aflg := TRUE; 
                END; 
                WITH arcfile^ DO 
                 WRITELN(ofile,' ':18,trans,' ':(13-LENGTH(trans)),   
                         code:10,'  ',date:6,'  ',qty:8:2);     
             linat := linat + 1;
             Chkpage;
            END;      
           END;   
        END;  
       END;
     END;
   END;
  END;
  
 PROCEDURE Fpart;
  BEGIN       
   Clear;
   WRITE('Report :: A)rchive, I)nventory, B)oth ::');   
   READ(ch);    
   IF NOT (ch IN ['I','i','A','a','B','b']) THEN
    BEGIN
     Clear;
     EXIT(Report);
    END;
   Clear;
   WRITE('to what device should the report go (<esc-cr> to quit) --->'); 
   Rdata(0,0,30,oname);  
   ch737 := 'N';
   IF oname = '#6:' THEN
    BEGIN
     WRITE('Do you have a centronics 737 printer? ');
     READ(ch737);
    END;
   IF LENGTH(oname)=0 THEN oname := '#2:';     
   IF LENGTH(oname)<>0 THEN IF oname[1]=CHR(27) THEN
    BEGIN
     Clear;
     EXIT(Report);
    END; 
   {$I-}
   REWRITE(ofile,oname);  
   IF IORESULT <> 0 THEN 
    BEGIN
     CLOSE(ofile);
     Clear;  
     EXIT(Report);
    END;
   {$I+} 
   IF ch737 IN ['Y','y'] THEN WRITE(ofile,CHR(27),CHR(19));
   WRITELN; 
   WRITE('enter partnumber wildcard (<esc-cr> to quit) ---->');       
   Rdata(0,0,16,partwild);    
   IF LENGTH(partwild)=0 THEN partwild := '????????????????'; 
   IF LENGTH(partwild)<>0 THEN IF partwild[1]=CHR(27) THEN
    BEGIN 
     CLOSE(ofile);  
     Clear;
     EXIT(Report);
    END; 
   WRITELN;  
   IF ch IN ['A','a','B','b'] THEN  
    BEGIN
     WRITE('enter code wildcard (<esc-cr> to quit) --->');  
     Rdata(0,0,10,codewild);  
     IF LENGTH(codewild)=0 THEN codewild := '??????????';   
     IF LENGTH(codewild)<>0 THEN IF codewild[1]=CHR(27) THEN  
      BEGIN 
       CLOSE(ofile);
       Clear;
       EXIT(Report);
      END; 
     WRITELN;  
     WRITE('enter date wildcard (<esc-cr> to quit) --->');  
     Rdata(0,0,6,datewild); 
     IF LENGTH(datewild)=0 THEN datewild := '??????'; 
     IF LENGTH(datewild)<>0 THEN IF datewild[1]=CHR(27) THEN
      BEGIN 
       CLOSE(ofile);
       Clear;
       EXIT(Report);
      END; 
     WRITELN;  
     WRITE('enter transaction wildcard (<esc-cr> to quit) --->'); 
     Rdata(0,0,6,tranwild);
     IF LENGTH(tranwild)=0 THEN tranwild := '??????'; 
     IF LENGTH(tranwild)<>0 THEN IF tranwild[1]=CHR(27) THEN    
      BEGIN 
       CLOSE(ofile);
       Clear;
       EXIT(Report);
      END; 
     WRITELN;    
    END; 
   WRITELN;
  END;
  
 BEGIN
  Fpart;
  linat := 4;
  CASE ch OF 
   'I','i' : BEGIN
              WRITELN(ofile, 'INVENTORY REPORT');        
              WRITELN(ofile);
              WRITELN(ofile,
'Partnumber       Description              Vendor Part#     Units      Qty'
                            ); 
              WRITELN(ofile,
'-------------------------------------------------------------------------'
                            );          
             END;     
   'A','a' : BEGIN
              WRITELN(ofile, 'ARCHIVE REPORT');
              WRITELN(ofile); 
              WRITELN(ofile,'Transaction  ','Partnumber':16,'  ','Code':10,'  ',
                      'Date':6,'       ','Qty'); 
              WRITELN(ofile,'-------------',
                      '----------------------------------------------');        
             END;     
   'B','b' : BEGIN
              WRITELN(ofile, 'INVENTORY AND ARCHIVE REPORT'); 
              WRITELN(ofile); 
              WRITELN(ofile,
'Partnumber       Description              Vendor Part#     Units      Qty'
                            ); 
              WRITELN(ofile,
'-------------------------------------------------------------------------'
                            );          
             END;     
  END;
  IF NOT (ch IN ['A','a']) THEN Invreport  
   ELSE
    BEGIN
     FOR temp := 1 TO narecs DO
      BEGIN
       SEEK(arcfile,temp); 
       GET(arcfile); 
       IF Arcwildok AND Otherwildok THEN
        BEGIN
         WITH arcfile^ DO 
          WRITELN(ofile,trans,' ':(13-LENGTH(trans)),    
                  partnum:16,'  ',code:10,'  ',date:6,'  ',qty:8:2);  
         linat := linat + 1;
         Chkpage;
        END; 
      END;
    END;
  IF oname = '#2:' THEN BEGIN WRITE('<cr> to continue'); READLN; END 
   ELSE WRITE(ofile,CHR(12));
  CLOSE(ofile,lock);
 END;


========================================================================================
DOCUMENT :usus Folder:VOL16:usus.inv.text
========================================================================================

{$S+}
PROGRAM PRINTINVOICES;
USES (*$U crtinput.code *) CRTInput, 
     (*$U getnumber.code *) GetNumber;

LABEL  1;

CONST
       MaxX = 79;
       MaxY = 23;
       MaxData = 50;
       MaxArray = 20;
       PromptLine = 0;

TYPE
       YLimits = 0..MaxY;
       XLimits = 0..MaxX;
       DataLimits = 1..MaxData;
       CRTLineArray = PACKED ARRAY [XLimits] OF char;
       DataRec = PACKED RECORD
                   X: XLimits;
                   Y: YLimits;
                   Lngth, Decimal: XLimits;
                 END;
       MaskRec = RECORD
                   Line: ARRAY [YLimits] OF CRTLineArray;
                   Data: ARRAY [DataLimits] OF DataRec;
                 END;
      ArrayIndex = 1..MaxArray;
      SystemType = String [20];
      FormatType = (None, Stndrd, UCSD, CPM, NorthStar, Apple);
      Volumes = (i, iia, iib, iii, iv, v, vi, vii, viii, ix, x);
      OrderedSet = SET OF Volumes;
      Money =
        RECORD
          Dollars: integer;
          Cents: -100..200
        END;
      CustRecord =
        RECORD
          Name: String [40];
          Addr1: String [40];
          Addr2: String [40];
          Addr3: String [40];
          Addr4: String [40];
          SalesTax, CanadaMex, Foreign: boolean;
          System: SystemType;
          Format: FormatType;
          Ordered: OrderedSet;
          PrevBal, ThisOrder, PaidNow, BalDue: Money;
          SpecialInstructns: string;
        END;


VAR  j, k, n: integer;
     running, quit: boolean;
     CustCount: ArrayIndex;
     Date: String[20];
     ExtraFee, CreditNow: ARRAY [ArrayIndex] OF Money;
     Frmt: ARRAY [ArrayIndex] OF String [9];
     Mask: MaskRec;
     Customer: ARRAY [ArrayIndex] OF CustRecord;
     List: text;
 

PROCEDURE WritePrompt (prompt: string);
BEGIN GoAndClearLine (PromptLine);  Write (prompt) END;


FUNCTION WaitForSp (p: string): boolean;
VAR ch: char;
BEGIN
  Write(CHR (7), p);
  Write ('.  Type a space to continue, <ESCAPE> to abort...');
  REPEAT Read (keyboard, ch) UNTIL (ch = ' ') OR (ch = CHR (27));
  Writeln;  WaitForSp := ch = ' '
END;


PROCEDURE WriteError(prompt: string);
VAR ch: char;
BEGIN
  Gotoxy (0, 2);  Write (CHR(7), prompt, '  Type <space> to continue..');
  REPEAT Read (keyboard, ch) UNTIL ch = ' ';  GoAndClearLine (2);
END;


PROCEDURE GotoDataField (n: integer);
BEGIN WITH Mask.Data[n] DO Gotoxy (x,y) END;


PROCEDURE ClearField (n: integer);
BEGIN
  WITH Mask.Data[n] DO BEGIN Gotoxy (X,Y);  Write (' ':Lngth) END
END;


PROCEDURE ReadMaskData;
VAR
     i: integer;
     DFileName: string[30];
     DataFile: FILE OF MaskRec;
     
BEGIN
  REPEAT
    DFileName := 'INVCS.MASK.DATA';
    {$I-}
    Reset (DataFile, DFileName);
    IF IORESULT > 0 THEN Reset (Datafile, CONCAT ('#4:', DFileName));
    IF IORESULT > 0 THEN Reset (Datafile, CONCAT ('#5:', DFileName));
    {$I+}
    i := IORESULT;
    IF i > 0
      THEN BEGIN
        Write ('Can''t find "INVCS.MASK.DATA", needed to work this program.');
        IF NOT Yes ('Do you wish me to try to find it again?')
          THEN EXIT (Program)
      END;
  UNTIL i = 0;
  Mask := Datafile^;
  ClearScreen;
  Close (Datafile, lock);
END;


PROCEDURE GetDisk (n: integer);
VAR  ch: char;
BEGIN
  WITH Customer[n] DO IF Format IN [Stndrd..NorthStar]
    THEN BEGIN
      CASE Format OF
        Stndrd:    GotoDataField (9);
        UCSD:      GotoDataField (11);
        CPM:       GotoDataField (14);
        Apple:     GotoDataField (16);
        NorthStar: GotoDataField (19)
      END;
      Write (' ');
    END;
  Gotoxy (13,10);
  ch := GetLetter (PromptLine, 
    'Please describe the disk format with the appropriate letter.',
    ['S', 'U', 'C', 'A', 'N']);
  WITH Customer[n] DO CASE ch OF
    'S':  BEGIN
            Format := Stndrd;  GotoDataField (9);  Frmt[n] := 'standard';
          END;
    'U':  BEGIN
            Format := UCSD;  GotoDataField (11);  Frmt[n] := 'UCSD';
          END;
    'C':  BEGIN
            Format := CPM;  GotoDataField (14);  Frmt[n] := 'CP/M';
          END;
    'A':  BEGIN
            Format := Apple;  GotoDataField (16);  Frmt[n] := 'Apple';
          END;
    'N':  BEGIN
            Format := NorthStar;  GotoDataField (19);  Frmt[n] := 'NorthStar';
          END
  END (*case*);  Write ('x');  GoAndClearLine (PromptLine);
END (*GetDisk*);


PROCEDURE DsplyOrders (n: integer);
VAR m: Volumes;
    mark: ARRAY[Volumes] OF char;
BEGIN
  WITH Customer[n] DO FOR m := i TO x DO 
    BEGIN
      IF m IN Ordered THEN mark[m] := 'x' ELSE mark[m] := ' ';
      CASE m OF
        i:   GotoDataField(10);
        iia: GotoDataField(12);   iib: GotoDataField(13);   
        iii: GotoDataField(15);
        iv:  GotoDataField(17);   v:   GotoDataField(18);
        vi:  GotoDataField(20);   vii: GotoDataField(21);
        viii:GotoDataField(22);   ix:  GotoDataField(23);
        x:   GotoDataField(24)
      END;
      Write (mark[m])
    END
END;


PROCEDURE GetOrders (n: integer);
VAR ch: char;
    Selected: Volumes;
BEGIN
  WritePrompt (
'Type the volume numbers ordered, 1 to 9 or "S".  Type a <return> when done.');
  REPEAT
    REPEAT Read (keyboard, ch) 
    UNTIL ch IN ['0'..'9','s','S',' '];  IF ch = 's' THEN ch := 'S';
    IF ch IN ['1'..'9','S'] THEN WITH Customer[n] DO 
      BEGIN
        CASE ch OF
          '1':  Selected := i;
          '2':  BEGIN
                  GotoDataField (30);  Write ('Volume 2 A or B?');
                  REPEAT READ (keyboard, ch) UNTIL (ch IN ['A', 'a', 'B', 'b']);
                  IF (ch IN ['A', 'a'])
                    THEN Selected := iia ELSE Selected := iib;
                  ClearField (30);
                END;
          '3':  BEGIN
                  WriteError('Are you sure this isn''t discontinued?');
                  Selected := iii;
                END;
          '4':  Selected := iv;
          '5':  Selected := v;
          '6':  Selected := vi;
          '7':  Selected := vii;
          '8':  Selected := viii;
          '9':  Selected := ix;
          'S':  Selected := x
          END (*case*);
        IF Selected IN Ordered 
          THEN Ordered := Ordered - [Selected]
          ELSE Ordered := Ordered + [Selected];
        DsplyOrders (n);
      END
  UNTIL (ch = '0') OR eoln (keyboard);  GoAndClearLine (PromptLine);
END (*GetOrders*);

     
PROCEDURE GetMoney (DN: datalimits; Prompt: string; VAR Amount: Money);
BEGIN
  WritePrompt (Prompt);
  GetDecimal (Mask.Data[DN].x, Mask.Data[DN].Y, -100, 1000, 2, Amount.Dollars, 
    Amount.Cents);
  GoAndClearLine (PromptLine);
END (*GetMoney*);


PROCEDURE WriteMoney (DN: datalimits; amount: money);
VAR m: integer;
BEGIN
  WITH Mask.Data[DN] DO
    BEGIN
      Gotoxy (X, Y); Write (ABS (Amount.dollars):(Lngth-3), '.');
      m := ABS (Amount.Cents); IF m DIV 10 = 0 THEN Write ('0');
      Write (m MOD 100);
      IF Amount.Dollars < 0
        THEN Write (' *CREDIT*') ELSE Write ('         ');
    END;
END;


PROCEDURE AddMoney (Add1, Add2: Money; VAR Sum: Money);
BEGIN
  Sum.Dollars := Add1.Dollars + Add2.Dollars;
  Sum.Cents := Add1.Cents + Add2.Cents;
  IF Sum.Cents > 99
    THEN BEGIN
      Sum.Cents := Sum.Cents -100;  Sum.Dollars := Sum.Dollars + 1;
    END;
END;
      
      
PROCEDURE SubMoney (minuend, subtrahend: money; VAR result: money);
BEGIN
  Result.Dollars := Minuend.Dollars - Subtrahend.Dollars;
  Result.Cents := Minuend.Cents - Subtrahend.Cents;
  WITH Result DO IF (Dollars > 0) AND (Cents < 0) 
    THEN BEGIN
      Cents := Cents + 100;
      Dollars := Dollars - 1
    END
    ELSE IF (Dollars < 0) AND (Cents > 0)
      THEN BEGIN
        Cents := Cents - 100;
        Dollars := Dollars + 1
      END;
END;


PROCEDURE FigureInvoice (n: integer);
VAR AmountPerVolume: 10..15;
    p, TaxCents, OrderPrice: integer;
    TotlCredit: money;
    Count: Volumes;
BEGIN
  WITH Customer [n] DO
    BEGIN
      IF (Format = Apple) OR (Format = NorthStar)
        THEN AmountPerVolume := 15 ELSE AmountPerVolume := 10;
      OrderPrice := 0;
      FOR Count := i TO x DO 
        IF Count IN Ordered THEN OrderPrice := OrderPrice + AmountPerVolume;
      IF SalesTax
        THEN BEGIN
          TaxCents := OrderPrice * 6;
          ExtraFee[n].Dollars := TaxCents DIV 100;
          ExtraFee[n].Cents := TaxCents MOD 100
        END
      ELSE IF Foreign
        THEN BEGIN
          p := 0;
          FOR Count := i TO ix DO IF Count IN Ordered
            THEN p := p + 1;
          ExtraFee[n].Dollars := 3 + TRUNC ((p-1) * 1.5);
          IF ODD (p)
            THEN ExtraFee[n].Cents := 0
            ELSE ExtraFee[n].Cents := 50;
        END
      ELSE BEGIN
        ExtraFee[n].Dollars := 0;
        ExtraFee[n].Cents := 0
      END;
      ThisOrder.Dollars := OrderPrice + PrevBal.Dollars;
      ThisOrder.Cents := PrevBal.Cents;
      AddMoney (ThisOrder, ExtraFee[n], ThisOrder);
      AddMoney (PaidNow, CreditNow[n], TotlCredit);
      SubMoney (ThisOrder, TotlCredit, BalDue);
      WriteMoney (29, BalDue);
    END (*with*)
END (*FigureInvoice*);


PROCEDURE GetName (n: integer);
VAR  Ordinate: String[5];
BEGIN
  IF n > 3
    THEN Ordinate := 'th'
    ELSE CASE n OF
      1: Ordinate := 'st';
      2: Ordinate := 'nd';
      3: Ordinate := 'rd'
    END;
  GoAndClearLine (PromptLine);
  Writeln('What is the name/title?');
  Write('(This is the ', n, Ordinate, ' customer.)');
  GotoDataField (1);  GetString (40, Customer[n].Name)
END;


PROCEDURE GetAddress (n: integer);
BEGIN
  WITH Customer[n] DO
    BEGIN
      WritePrompt ('First line of address?  ');
      GotoDataField (2);  GetString (40, Addr1);
      WritePrompt ('Second line of address?  ');
      GotoDataField (3);  GetString (40, Addr2);
      IF (Addr2 = ' ') OR (Addr2 = '') THEN Addr3 := ''
        ELSE BEGIN
          WritePrompt ('Third line of address?  ');
          GotoDataField (4);  GetString (40, Addr3)
        END;
      IF (Addr3 = ' ') OR (Addr3 = '') THEN Addr4 := ''
        ELSE BEGIN
          WritePrompt ('Fourth line of address?  ');
          GotoDataField (5);  GetString (40, Addr4);
        END;
      GoAndClearLine (PromptLine);
    END
END;


FUNCTION MaskBoolean (DN: integer; prompt: string): boolean;
VAR quick: boolean;
BEGIN
  WritePrompt (prompt);
  WITH Mask.Data[DN] DO GetBoolean (X, Y, quick);
  MaskBoolean := quick;
  GoAndClearLine (PromptLine);
END;


PROCEDURE InitCustomer (n: integer);
BEGIN
  WITH Customer[n] DO
    BEGIN
      Name := '';
      Addr1 := '';
      Addr2 := '';
      Addr3 := '';
      Addr4 := '';
      System := '';
      Format := None;
      Ordered := [];
      PrevBal.Dollars := 0; PrevBal.Cents := 0;
      PaidNow.Dollars := 0; PaidNow.Cents := 0;
    END;
  CreditNow[n].Dollars := 0; CreditNow[n].Cents := 0;
END;


PROCEDURE CheckInvoice (n: integer);
CONST Always = false;
VAR ch: char;
BEGIN
  REPEAT WITH Customer[n] DO
    BEGIN
      ch := GetLetter (PromptLine, 
'Now check customer data.  Type letter of the field to correct; "Q" when done.',
['N', 'A', 'B', 'D', 'P', 'R', 'M', 'S', 'C', 'O', 'V', 'Q']);
      Case ch OF
             'A':  GetAddress (n);
             'B':  BEGIN
                     GotoDataField (8);
                     GetString (20, System);
                   END;
             'D':  GetDisk (n);
             'N':  GetName (n);
             'P':  GetMoney (26, 
    'Now correct past due/credits; preceed credits by a "-" sign', PrevBal);
             'R':  GetMoney (27, 'Correct amount paid by customer.', PaidNow);
             'M':  GetMoney (28, 'Correct credits being applied TODAY',
                     CreditNow[n]);
             'S':  BEGIN
                     GotoDataField (25);
                     GetString (56, SpecialInstructns)
                   END;
             'C':  IF NOT Foreign
                     THEN SalesTax := MaskBoolean (6, 'California sale?')
                     ELSE BEGIN
                       SalesTax := false;
                       GoToDataField (6);
                       Write (' no')
                     END;
             'O':  IF NOT SalesTax
                     THEN Foreign := MaskBoolean (7, 'Overseas sale?')
                     ELSE BEGIN
                       Foreign := false;
                       GoToDataField (7);
                       Write (' no')
                     END;
             'V':  GetOrders (n);
             'Q':  Exit (CheckInvoice);
        END;
      FigureInvoice (n);
    END;
  UNTIL Always;
END;


PROCEDURE GetCustData;

VAR  m, n: integer;
     MoreToDo: boolean;
     ch: char;
     s: string;
          
BEGIN (*GetCustData*)
  ClearScreen;
  FOR m := 0 TO MaxY-1 DO Writeln (Mask.Line[m]);
  n := 1;
  REPEAT
    WITH Customer[n] DO
      BEGIN
        InitCustomer(n);
        GetName (n);
        GetAddress (n);
        SalesTax := MaskBoolean (6, 'Charge sales tax?');
        CanadaMex := false;
        IF SalesTax
          THEN Foreign := false
          ELSE Foreign := MaskBoolean (7, 'Foreign country?');
        WritePrompt ('Describe system briefly (if known).');
        GotoDataField (8);  GetString (20, System);
        GetDisk (n);
        GetOrders (n);
        GetMoney (26,
'Any previous balance (or credit: make negative)?', PrevBal);
        GetMoney (27, 'Amount paid today?', PaidNow);
        GetMoney (28, 'Any special credits today?', CreditNow[n]);
        WritePrompt ('Type any special instructions now.');
        SpecialInstructions := '';
        GotoDataField (25);  GetString (56, SpecialInstructions);
      END (*with*);
    FigureInvoice (n);
    CheckInvoice (n);
    GoAndClearLine (PromptLine);
    MoreToDo := Yes ('More orders to process');
    CustCount := n;
    IF MoreToDo THEN BEGIN n := n+1;  FOR m := 1 TO 25 DO ClearField (m) END;
  UNTIL (n >= MaxArray) OR NOT MoreToDo;
END (*Procedure*);


PROCEDURE DoPrintInvoice (n: integer);
VAR IntAmount, LineCount, j, p: integer;
    FirstLine: boolean;
    ch: char;
    SubTotal, TaxAmount, Shipping: Money;
    Count: Volumes;


PROCEDURE PrintVolLine;

BEGIN
  WITH Customer[n] DO FOR Count := i TO x DO IF Count IN Ordered
    THEN BEGIN
      Write (List, '  1   USUS/UCSD Users'' Library, Vol  ');
      CASE Count OF
        i:     Write (List, '1 ');
        iia:   Write (List, '2A');
        iib:   Write (List, '2B');
        iii:   Write (List, '3 ');
        iv:    Write (List, '4 ');
        v:     Write (List, '5 ');
        vi:    Write (List, '6 ');
        vii:   Write (List, '7 ');
        viii:  Write (List, '8 ');
        ix:    Write (List, '9 ');
        x:     Write(List,'WD')
      END (*case*);
      IF (Format IN [Apple, NorthStar])
        THEN Write (List, '  15     ') ELSE Write (List, '  10     ');
      IF FirstLine
        THEN BEGIN FirstLine := false; Write (List, '$') END
        ELSE Write (List, ' ');
      IF (Format IN [Apple, NorthStar])
        THEN Writeln (List, '15   00') ELSE Writeln (List, '10   00');
      LineCount := LineCount + 1
    END (*with*);
END (*PrintVolLine*);


PROCEDURE PrntHeadLine (s: String; amt: money);
VAR x: integer;
BEGIN
  Write (List, s:49, abs (amt.dollars):2);  x := abs (amt.cents);
  IF x < 10 
    THEN Writeln (List, '   0', x) ELSE Writeln (List, x:5)
END;


BEGIN (*DoPrintInvoices*)
  WITH Customer[n] DO
    BEGIN
      Writeln (List, ' ':41, Date);
      Writeln (List);
      Writeln (List, Name);
      Writeln (List, Addr1);
      Writeln (List, Addr2);
      Writeln (List, Addr3);
      Writeln (List, Addr4);
      FOR j := 1 to 4 DO Writeln (List);
      IF PrevBal.Dollars + PrevBal.Cents <> 0
        THEN BEGIN
          IF PrevBal.Dollars * 100 + PrevBal.Cents > 0
            THEN PrntHeadLine ('PREVIOUS BALANCE:   $', PrevBal)
            ELSE PrntHeadLine ('PREVIOUS CREDIT DUE:$', PrevBal);
          LineCount := 2;
          Writeln (List);
          FirstLine := false
        END ELSE BEGIN  LineCount := 0;  FirstLine := true  END;
      IF POS ('USUS', System) > 0
        THEN BEGIN
          Writeln (list, '      -- ** -- This order through USUS -- ** --');
          LineCount := LineCount + 1
        END;
      Writeln (list, 'Disks were ordered in ', Frmt[n], ' format.');
      Writeln (list);
      PrintVolLine;
      Writeln (List, '________':56);
      IF SalesTax OR Foreign
        THEN BEGIN
          SubMoney (ThisOrder, ExtraFee[n], SubTotal);
          PrntHeadLine ('SUBTOTAL    $', SubTotal);
          Writeln (List);
          IF SalesTax
            THEN PrntHeadLine ('SALES TAX    ', ExtraFee[n])
            ELSE PrntHeadLine ('SHIPPING     ', ExtraFee[n]);
          Writeln (List, '________':56);
          LineCount := LineCount + 4
        END;
      PrntHeadLine ('TOTAL       $', ThisOrder);
      Writeln (List);
      PrntHeadLine ('RECEIVED (check)     ', PaidNow);
      IF CreditNow[n].Dollars + CreditNow[n].Cents > 0
        THEN BEGIN
          PrntHeadLine ('OTHER CREDITS        ', CreditNow[n]);
          LineCount := LineCount + 1
        END;
      Writeln (List, '________':56);
      IF (BalDue.Dollars < 0) OR (BalDue.Cents < 0)
        THEN PrntHeadLine ('CREDIT      $', BalDue)
        ELSE PrntHeadLine ('BALANCE DUE $', BalDue);
      Writeln (List);
      IF (SpecialInstructions = '') OR (SpecialInstructions = ' ')
        THEN Writeln (list)
        ELSE Writeln (list, '           -***- SPECIAL INSTRUCTIONS -***-');
      Writeln (list, SpecialInstructions);
      FOR j := LineCount TO 28 DO Writeln (List)
  END (*for*)
END;

PROCEDURE PrintLabels;
BEGIN 
  IF WaitForSp('Ready to print labels')
    THEN FOR n := 1 TO CustCount DO WITH Customer [n] DO
      BEGIN
        Writeln (List, name);
        Writeln (List, Addr1);
        Writeln (List, Addr2);
        Writeln (List, Addr3);
        Writeln (List, Addr4);
        Writeln (List);
        IF NOT WaitForSp('Align labels again') THEN EXIT(PrintLabels)
      END
END;
  
  
PROCEDURE SaveRecords;
VAR ch: char;
    Opened: boolean;
    CustStore: CustRecord;
    Savefile: FILE OF CustRecord;
    
BEGIN 
  Writeln; Writeln;
  IF NOT Yes ('Would you like to save the customer data on the disk')
    THEN EXIT (SaveRecords);
  Writeln ('Opening UCSDUSERS.DATA.....');
  (*$I-*)
  Reset (Savefile, '#5:UCSDUSERS.DATA');
  IF IORESULT = 0
    THEN Opened := true
    ELSE BEGIN
      Reset (Savefile, 'UCSDUSERS.DATA');
      Opened := (IORESULT = 0);
    END;
  (*$I+*)
  IF Opened 
    THEN WHILE NOT eof (Savefile) DO Get (Savefile)
    ELSE Rewrite (Savefile, '#5:UCSDUSERS.DATA');
  Writeln ('Writing new customer data.....');
  FOR j := 1 TO CustCount DO
    BEGIN
      Savefile^ := Customer [j];
      Put (Savefile)
    END;
  Close (Savefile, lock)
END;
  
  
BEGIN
  REPEAT Write ('Today''s date?  ');  Readln (Date) UNTIL Yes ('OK');
  Rewrite (List, 'PRINTER:');
  ReadMaskData;
  GetCustData;
  quit := false;
  REPEAT
    ClearScreen;  running := true;
    CASE GetLetter (0, 
'PRINT: I(nvoices or L(abels; "Q" = Q(uit printing (type "I", "L", or "Q"):  ',
          ['I', 'L', 'Q']) OF
      'I': FOR n := 1 TO CustCount DO 
             IF running THEN BEGIN
               IF (n-1) MOD 5 = 0
                 THEN IF NOT WaitForSp('Align invoices in printer')
                   THEN running := false;
               IF running THEN DoPrintInvoice (n);
             END;
      'L': PrintLabels;
      'Q': quit := true
    END
  UNTIL quit;
  SaveRecords
END.




========================================================================================
DOCUMENT :usus Folder:VOL16:vol16.doc.text
========================================================================================

                             USUS Library Volume 16
                    A little something from almost everyone

P.TEXT            24  A simple text formatter which is easy to use 
P.INC.TEXT        16    an include file for P
INV.TEXT           8  An inventory management program from Pat Horton
ISSUE.TEXT        10    an include file for INV
BASPROC2.TEXT     12      ditto
ADD.TEXT           8      ditto
REPORT.TEXT       20      ditto
BASPROC.TEXT      18      ditto
INV.DOC.TEXT      34    documentation for INV
Z80.SEEK.TEXT      8  A fast Z80 seek procedure.  Should have been on Volume 8
CHECKBOOK.TEXT    26  Jim Gagne's checkbook balancer
USUS.INV.TEXT     36  A USUS disk order entry program
INVCS.MASK.DATA    5    a data file for USUS.INV
8.INCH.TEXT        8  Prints 8" disk labels
APPLE.LABL.TEXT    6  Prints Apple disk labels
CRTINPUT.TEXT     22  A unit used by Jim's programs
GETNUMBER.TEXT    30  Another unit used by Jim's programs
ASE.HEADER.TEXT    6  The declarations for the ASE Header Page
BUNIT.TEXT        12  Mike Adams's B-tree unit
BDEBUG.TEXT        6    an include file of BUNIT
BHKEEP.TEXT        6      ditto
BINTERN.TEXT      24      ditto
BIO.TEXT           8      ditto
BMAIN.TEXT        22      ditto
BDRIVER.TEXT      12  A main program which uses and demos BUNIT
BDOC1.TEXT        30  Excellent documentation for Mike Adams's B-tree
BDOC2.TEXT        30    More documentation on the b-tree
BDOC3.TEXT        16    Even more documenation
VOL16.DOC.TEXT    12  You're reading it
-----------------------------------------------------------------------------
Please transfer the text below to a disk label if you copy this volume.

    USUS Volume 16 -***- USUS Software Library
                         
   For not-for-profit use by USUS members only.
  May be used and distributed only according to 
      stated policy and the author's wishes.



This volume was assembled by George Schreyer from material collected by
the Library committee.

__________________________________________________________________________

Some notes from the editor:

                                       P

     This is a simple, easy-to-use, and useful text formatter submitted by Pat 
Horton.  It basically does what the UCSD editor does not, justify pre-filled
paragraphs.  It has a nice user interface and built in help functions. All
funtions are controlled interactively, no imbedded commands are used.

                                      INV

     This is a fairly elaborate inventory system submitted by Pat Horton.  It
is easy to use and it works well.

                                    Z80.SEEK

     This routine was supposed to be on Volume 8, but it didn't make it into
many of the masters.  It needs the GLOBALS from volume 8 to compile.

          -----------------------------------------------------------
         
         Jim Gagne's submission -- four utility programs and two units
                                        
                                   CHECKBOOK

     Checkbook will balance your checkbook for you and also act a little like 
a calculator.  It uses CRTINPUT and GETNUMBER.

                                    USUS.INV

     This is the program Jim uses to process USUS orders.  Nice menu.  It uses
CRTINPUT and GETNUMBER.

                                     8.INCH

     This program will print a label for a USUS volume on standard 8" disk
labels.  Use it if you copy disks for another USUS member.  It uses CRTINPUT.
                                        
                                   APPLE.LABL

     Same as above except for Apple labels.

                                    CRTINPUT

     This is a collection of utility procedures.  A version of it is found
on volume 5, but this one doesn't have any EXTERNAL procedures.

                                   GETNUMBER

     More utility routines, specifically to get numbers from the user.

                                   ASE.HEADER

     The RECORD declaration for the first "page" of an ASE TextFile.  This is
meant as an aid for folks writing RunOffs, Spellers, and Grammarians which
might wish to use ASE files.

                               BUNIT and BDRIVER

     This is Mike Adams's B-tree implementation.  There is a general purpose b-
tree unit and a demo program.  The demo is pretty simple, it is intended to
store only integers, probably to be used as keys to another file, but the unit
itself is very general.  Mike has supplied excellent documentation of what a 
b-tree is, what it does and why it works better than other ways to store
data.  He describes his own implementation and how to use it, and how you
might modify it to make it work better for your own application.



========================================================================================
DOCUMENT :usus Folder:VOL16:z80.seek.text
========================================================================================

{Copyright 1980 by
Stuart Lynne
1350 Clifton Ave.
Coquitlam, British Columbia,
Canada
V3J 5K6

Permission granted to use for noncommercial purposes.  All
other rights reserved}
  
  
{ z80.seek }
{$U-,S+}

{$I globals }
{
*
*     Z80 Seek 
*
*
*     This version of the UCSD Pascal Seek algorithm uses a seperate 
*     assembler routine to calculate the block number and offset given
*     the record number and record size.
*
*     
}
{$C Copyright (c) 1980, by Stuart Lynne. All rights reserved }

(*----------------------------------------------------------*)

Separate unit Z80_Seek;
interface
    
  Procedure Fseek(var F: FIB; RECNUM: INTEGER);
  
implementation
    
  Procedure Mul_Div (var Byte: integer; var Block: integer; 
                   Rec_Num, Rec_Size: integer);
    external;
  
  PROCEDURE FSEEK(*VAR F: FIB; RECNUM: INTEGER*);
    LABEL 1;
    VAR BYTE,BLOCK,N: INTEGER;
    
    
  BEGIN SYSCOM^.IORSLT := INOERROR;
    IF F.FISOPEN THEN
      WITH F,FHEADER DO
        BEGIN 
          IF (RECNUM < 0) OR NOT FSOFTBUF OR
                  ((DFKIND = TEXTFILE) AND (FRECSIZE = 1)) THEN
            GOTO 1; (*NO SEEK ALLOWED*)
          {
          * Block := RECNUM*FRECSIZE DIV FBLKSIZE + 1;
          * Byte  := RECNUM*FRECSIZE MOD FBLKSIZE;
          }
          Mul_Div ( Byte, Block, Recnum, Frecsize);
          Block := Block + 1;
          IF BYTE = 0 THEN 
            BEGIN
              BYTE := FBLKSIZE;     
              BLOCK := BLOCK - 1;
              END;
          N := DLASTBLK-DFIRSTBLK;
          IF (BLOCK > N) OR ((BLOCK = N) AND (BYTE >= DLASTBYTE)) THEN
            BEGIN BLOCK := N; BYTE := DLASTBYTE END;
          IF BLOCK <> FNXTBLK THEN
            BEGIN
              IF FBUFCHNGD THEN
                BEGIN FBUFCHNGD := FALSE; FMODIFIED := TRUE;
                  UNITWRITE(FUNIT,FBUFFER,FBLKSIZE,DFIRSTBLK+FNXTBLK-1);
                  IF IORESULT <> ORD(INOERROR) THEN GOTO 1
                END;
              IF (BLOCK <= FMAXBLK) AND (BYTE <> FBLKSIZE) THEN
                BEGIN
                  UNITREAD(FUNIT,FBUFFER,FBLKSIZE,DFIRSTBLK+BLOCK-1);
                  IF IORESULT <> ORD(INOERROR) THEN GOTO 1
                END
            END;
          IF FNXTBLK > FMAXBLK THEN
            BEGIN FMAXBLK := FNXTBLK; FMAXBYTE := FNXTBYTE END
          ELSE
            IF (FNXTBLK = FMAXBLK) AND (FNXTBYTE > FMAXBYTE) THEN
              FMAXBYTE := FNXTBYTE;
          FEOF := FALSE; FEOLN := FALSE; FREPTCNT := 0;
          IF FSTATE <> FJANDW THEN FSTATE := FNEEDCHAR;
          FNXTBLK := BLOCK; FNXTBYTE := BYTE
        END
    ELSE SYSCOM^.IORSLT := INOTOPEN;
  1:
  END (*FSEEK*) ;


END { PASCALIO } ;

(*Dummy level 0 outerblock*)
BEGIN END.


========================================================================================
DOCUMENT :usus Folder:VOL17:booter.text
========================================================================================

PROGRAM BOOTSTRAPCOPIER;
CONST
  BOOTSIZE = 1024;
VAR
  BOOT: PACKED ARRAY[1..BOOTSIZE] OF CHAR;
BEGIN
  IF EOLN THEN READLN;
  WRITE('Please insert the floppy with the source boot and type <return>');
  READLN;
  UNITREAD(4,BOOT,BOOTSIZE,0);
  IF IORESULT <> 0 THEN
    BEGIN
      WRITELN('Error encountered reading boot.');
      EXIT(PROGRAM)
    END;
  WRITELN('Please insert the floppy onto which the boot is to be written and');
  WRITE('type <return>');
  READLN;
  UNITWRITE(4,BOOT,BOOTSIZE,0);
  IF IORESULT <> 0 THEN
    BEGIN
      WRITELN('Error encountered writing boot.');
      EXIT(PROGRAM)
    END;
  WRITELN('Bootstrap has been copied.');
END.

========================================================================================
DOCUMENT :usus Folder:VOL17:comp.a.text
========================================================================================


(*$U-*)
PROGRAM PASCALSYSTEM;

(************************************************)
(*                                              *)
(*        UCSD  PASCAL  COMPILER                *)
(*                                              *)
(*    BASED ON ZURICH P2 PORTABLE               *)
(*    COMPILER, EXTENSIVLY                      *)
(*    MODIFIED BY ROGER T. SUMNER               *)
(*    1976..1977                                *)
(*                                              *)
(*    INSTITUTE FOR INFORMATION SYSTEMS         *)
(*    UC SAN DIEGO, LA JOLLA, CA                *)
(*                                              *)
(*    KENNETH L. BOWLES, DIRECTOR               *)
(*                                              *)
(*    THIS SOFTWARE IS THE PROPERTY OF THE      *)
(*  REGENTS OF THE UNIVERSITY OF CALIFORNIA.    *)
(*                                              *)
(************************************************)

TYPE PHYLE = FILE;
     INFOREC = RECORD
		 WORKSYM,WORKCODE: ^PHYLE;
		 ERRSYM,ERRBLK,ERRNUM: INTEGER;
		 STUPID: BOOLEAN
	       END;

PROGRAM PROCEDURE USERPROGRAM;
BEGIN END (*USERPROGRAM*) ;

PROGRAM PROCEDURE COMPILER(VAR USERINFO: INFOREC);

CONST DISPLIMIT = 12; MAXLEVEL = 8; MAXADDR = 28000;
      INTSIZE = 1; REALSIZE = 2; BITSPERWD = 16;
      CHARSIZE = 1; BOOLSIZE = 1; PTRSIZE = 1;
      FILESIZE = 300; NILFILESIZE = 34; BITSPERCHR = 8; CHRSPERWD = 2;
      STRINGSIZE = 0; STRGLGTH = 255; MAXINT = 32767;
      DEFSTRGLGTH = 80; LCAFTERMARKSTACK = 1;
      EOL = 13; MAXCURSOR = 1023; MAXCODE = 1299;
      MAXJTAB = 24; MAXSEG = 15; MAXPROCNUM = 149;

TYPE
					      (*BASIC SYMBOLS*)

     SYMBOL =  (IDENT,COMMA,COLON,SEMICOLON,LPARENT,RPARENT,DOSY,TOSY,
		DOWNTOSY,ENDSY,UNTILSY,OFSY,THENSY,ELSESY,BECOMES,LBRACK,
		RBRACK,ARROW,PERIOD,BEGINSY,IFSY,CASESY,REPEATSY,WHILESY,
		FORSY,WITHSY,GOTOSY,LABELSY,CONSTSY,TYPESY,VARSY,PROCSY,
		FUNCSY,PROGSY,FORWARDSY,INTCONST,REALCONST,STRINGCONST,
		NOTSY,MULOP,ADDOP,RELOP,SETSY,PACKEDSY,ARRAYSY,RECORDSY,
		FILESY,OTHERSY);


     OPERATOR = (MUL,RDIV,ANDOP,IDIV,IMOD,PLUS,MINUS,OROP,LTOP,LEOP,
		 GEOP,GTOP,NEOP,EQOP,INOP,NOOP);

     SETOFSYS = SET OF SYMBOL;

					      (*CONSTANTS*)
     CSTCLASS = (REEL,PSET,STRG,TRIX);
     CSP = ^ CONSTREC;
     CONSTREC = RECORD CASE CCLASS: CSTCLASS OF
			 TRIX: (CSTVAL: ARRAY [1..8] OF INTEGER);
			 REEL: (RVAL: REAL);
			 PSET: (PVAL: SET OF 0..127);
			 STRG: (SLGTH: 0..STRGLGTH;
				SVAL: PACKED ARRAY [1..STRGLGTH] OF CHAR)
		       END;

     VALU = RECORD CASE BOOLEAN OF
		     TRUE:  (IVAL: INTEGER);
		     FALSE: (VALP: CSP)
		   END;

						  (*DATA STRUCTURES*)
     BITRANGE = 0..BITSPERWD; OPRANGE = 0..80;
     CURSRANGE = 0..MAXCURSOR; PROCRANGE = 0..MAXPROCNUM;
     LEVRANGE = 0..MAXLEVEL; ADDRRANGE = 0..MAXADDR;
     JTABRANGE = 0..MAXJTAB; SEGRANGE = 0..MAXSEG;
     DISPRANGE = 0..DISPLIMIT;

     STRUCTFORM = (SCALAR,SUBRANGE,POINTER,POWER,ARRAYS,
		   RECORDS,FILES,TAGFLD,VARIANT);

     DECLKIND = (STANDARD,DECLARED,SPECIAL);

     STP = ^ STRUCTURE; CTP = ^ IDENTIFIER;

     STRUCTURE = RECORD
		   SIZE: ADDRRANGE;
		   CASE FORM: STRUCTFORM OF
		     SCALAR:   (CASE SCALKIND: DECLKIND OF
				  DECLARED: (FCONST: CTP));
		     SUBRANGE: (RANGETYPE: STP; MIN,MAX: VALU);
		     POINTER:  (ELTYPE: STP);
		     POWER:    (ELSET: STP);
		     ARRAYS:   (AELTYPE,INXTYPE: STP;
				CASE AISPACKD:BOOLEAN OF
				  TRUE: (ELSPERWD,ELWIDTH: BITRANGE;
					 CASE AISSTRNG: BOOLEAN OF
					  TRUE:(MAXLENG: 1..STRGLGTH)));
		     RECORDS:  (FSTFLD: CTP; RECVAR: STP);
		     FILES:    (FILTYPE: STP);
		     TAGFLD:   (TAGFIELDP: CTP; FSTVAR: STP);
		     VARIANT:  (NXTVAR,SUBVAR: STP; VARVAL: VALU)
		   END;

							    (*NAMES*)
     IDCLASS = (TYPES,KONST,VARS,FIELD,PROC,FUNC);
     SETOFIDS = SET OF IDCLASS;
     IDKIND = (ACTUAL,FORMAL);
     ALPHA = PACKED ARRAY [1..8] OF CHAR;

     IDENTIFIER = RECORD
		   NAME: ALPHA; LLINK, RLINK: CTP;
		   IDTYPE: STP; NEXT: CTP;
		   CASE KLASS: IDCLASS OF
		     KONST: (VALUES: VALU);
		     VARS:  (VKIND: IDKIND; VLEV: LEVRANGE;
			     VADDR: ADDRRANGE);
		     FIELD: (FLDADDR: ADDRRANGE;
			     CASE FISPACKD: BOOLEAN OF
			       TRUE: (FLDRBIT,FLDWIDTH: BITRANGE));
		     PROC,
		     FUNC:  (CASE PFDECKIND: DECLKIND OF
			      SPECIAL:  (KEY: 1..23);
			      STANDARD: (CSPNUM: 1..40);
			      DECLARED: (PFLEV: LEVRANGE;
					 PFNAME: PROCRANGE;
					 PFSEG: SEGRANGE;
					 CASE PFKIND: IDKIND OF
					   ACTUAL: (LOCALLC: ADDRRANGE;
						    FORWDECL,
						    INSCOPE: BOOLEAN)))
		   END;


     WHERE = (BLCK,CREC,VREC,REC);

					      (*EXPRESSIONS*)
     ATTRKIND = (CST,VARBL,EXPR);
     VACCESS = (DRCT,INDRCT,PACKD,MULTI,BYTE);

     ATTR = RECORD TYPTR: STP;
	      CASE KIND: ATTRKIND OF
		CST:   (CVAL: VALU);
		VARBL: (CASE ACCESS: VACCESS OF
			  DRCT:   (VLEVEL: LEVRANGE; DPLMT: ADDRRANGE);
			  INDRCT: (IDPLMT: ADDRRANGE))
	    END;

     TESTP = ^ TESTPOINTER;
     TESTPOINTER = RECORD
		     ELT1,ELT2 : STP;
		     LASTTESTP : TESTP
		   END;

						   (*LABELS*)
     LBP = ^ CODELABEL;
     CODELABEL = RECORD
		   CASE DEFINED: BOOLEAN OF
		     FALSE: (REFLIST: ADDRRANGE);
		     TRUE:  (OCCURIC: ADDRRANGE; JTABINX: JTABRANGE)
		 END;

     LABELP = ^ USERLABEL;
     USERLABEL = RECORD
		   LABVAL: INTEGER;
		   NEXTLAB: LABELP;
		   CODELBP: LBP
		 END;

     CODEARRAY = PACKED ARRAY [0..MAXCODE] OF CHAR;
     SYMBUFARRAY = PACKED ARRAY [CURSRANGE] OF CHAR;

(*--------------------------------------------------------------------*)

VAR

    CODEP: ^ CODEARRAY;             (*CODE BUFFER UNTIL WRITEOUT*)
    SYMBUFP: ^ SYMBUFARRAY;         (*SYMBOLIC BUFFER...ASCII OR CODED*)

    GATTR: ATTR;                    (*DESCRIBES CURRENT EXPRESSION*)
    VAL: VALU;                      (*VALUE OF LAST CONSTANT*)

    DISX,                           (*LEVEL OF LAST ID SEARCHED*)
    TOP: DISPRANGE;                 (*TOP OF DISPLAY*)
				    (*SCANNER GLOBALS...NEXT FOUR VARS*)
				    (*MUST BE IN THIS ORDER FOR IDSEARCH*)
    SYMCURSOR: CURSRANGE;           (*CURRENT SCANNING INDEX IN SYMBUFP^*)
    SY: SYMBOL;                     (*SYMBOL FOUND BY INSYMBOL*)
    OP: OPERATOR;                   (*CLASSIFICATION OF LAST SYMBOL*)
    ID: ALPHA;                      (*LAST IDENTIFIER FOUND*)

    LGTH: INTEGER;                  (*LENGTH OF LAST STRING CONSTANT*)

    LCMAX,LC,IC: ADDRRANGE;         (*LOCATION AND INSTRUCT COUNTERS*)

				    (*SWITCHES:*)

    PRTERR,GOTOOK,RANGECHECK,CODEINSEG,IOCHECK,
    LIST,TEST,SYSCOMP,DP,INCLUDING: BOOLEAN;

				    (*POINTERS:*)
    INTPTR,REALPTR,CHARPTR,BOOLPTR,
    TEXTPTR,NILPTR,STRGPTR: STP;    (*POINTERS TO STANDARD IDS*)

    UTYPPTR,UCSTPTR,UVARPTR,
    UFLDPTR,UPRCPTR,UFCTPTR,        (*POINTERS TO UNDECLARED IDS*)
    INPUTPTR,OUTPUTPTR,
    OUTERBLOCK,FWPTR: CTP;

    GLOBTESTP: TESTP;                (*LAST TESTPOINTER*)

    LEVEL: LEVRANGE;                (*CURRENT STATIC LEVEL*)

    SEG,NEXTSEG: SEGRANGE;          (*CURRENT SEGMENT #*)
    SEGINX: INTEGER;                (*CURRENT INDEX IN SEGMENT*)
    SCONST: CSP;                    (*INSYMBOL STRING RESULTS*)

    LOWTIME,LINEINFO,SCREENDOTS,STARTDOTS,SYMBLK: INTEGER;
    LINESTART: CURSRANGE;

    CURPROC,NEXTPROC: PROCRANGE;     (*PROCEDURE NUMBER ASSIGNMENT*)

    CONSTBEGSYS,SIMPTYPEBEGSYS,TYPEBEGSYS,BLOCKBEGSYS,
    SELECTSYS,FACBEGSYS,STATBEGSYS,TYPEDELS: SETOFSYS;

    DISPLAY: ARRAY [DISPRANGE] OF
		RECORD
		  FNAME: CTP;
		  CASE OCCUR: WHERE OF
		    BLCK: (FFILE: CTP; FLABEL: LABELP);
		    CREC: (CLEV: LEVRANGE; CDSPL: ADDRRANGE);
		    VREC: (VDSPL: ADDRRANGE)
		  END;

    PROCTABLE: ARRAY [PROCRANGE] OF INTEGER;

    SEGTABLE: ARRAY [SEGRANGE] OF
		RECORD
		  DISKADDR,CODELENG: INTEGER;
		  SEGNAME: ALPHA
		END (*SEGTABLE*) ;

    NEXTJTAB: JTABRANGE;
    JTAB: ARRAY [JTABRANGE] OF INTEGER;

    OLDSYMBLK: INTEGER;
    OLDSYMCURSOR: CURSRANGE;
    INCLFILE: FILE;

    CURBYTE, CURBLK: INTEGER;
    DISKBUF: PACKED ARRAY [0..511] OF CHAR;

(*--------------------------------------------------------------------*)

PROCEDURE INSYMBOL;
  FORWARD;

PROCEDURE ERROR(ERRORNUM: INTEGER);
  FORWARD;

PROCEDURE ENTERID(FCP: CTP);
  FORWARD;

PROCEDURE GETNEXTPAGE;
  FORWARD;

PROGRAM PROCEDURE COMPINIT;

  PROCEDURE ENTSTDTYPES;
    VAR SP: STP;
  BEGIN
    NEW(INTPTR,SCALAR,STANDARD);
    WITH INTPTR^ DO
      BEGIN SIZE := INTSIZE; FORM := SCALAR; SCALKIND := STANDARD END;
    NEW(REALPTR,SCALAR,STANDARD);
    WITH REALPTR^ DO
      BEGIN SIZE := REALSIZE; FORM := SCALAR; SCALKIND := STANDARD END;
    NEW(CHARPTR,SCALAR,STANDARD);
    WITH CHARPTR^ DO
      BEGIN SIZE := CHARSIZE; FORM := SCALAR; SCALKIND := STANDARD END;
    NEW(BOOLPTR,SCALAR,DECLARED);
    WITH BOOLPTR^ DO
      BEGIN SIZE := BOOLSIZE; FORM := SCALAR; SCALKIND := DECLARED END;
    NEW(NILPTR,POINTER);
    WITH NILPTR^ DO
      BEGIN SIZE := PTRSIZE; FORM := POINTER; ELTYPE := NIL END;
    NEW(TEXTPTR,FILES);
    WITH TEXTPTR^ DO
      BEGIN SIZE := FILESIZE+CHARSIZE; FORM := FILES; FILTYPE := CHARPTR END;
    NEW(STRGPTR,ARRAYS,TRUE,TRUE);
    WITH STRGPTR^ DO
      BEGIN FORM := ARRAYS; SIZE := (DEFSTRGLGTH + CHRSPERWD) DIV CHRSPERWD;
	AISPACKD := TRUE; AISSTRNG := TRUE; INXTYPE := INTPTR;
	ELWIDTH := BITSPERCHR; ELSPERWD := CHRSPERWD;
	AELTYPE := CHARPTR; MAXLENG := DEFSTRGLGTH;
      END
  END (*ENTSTDTYPES*) ;

  PROCEDURE ENTSTDNAMES;
    VAR CP,CP1: CTP; I: INTEGER;
  BEGIN
    NEW(CP,TYPES);
    WITH CP^ DO
      BEGIN NAME := 'INTEGER '; IDTYPE := INTPTR; KLASS := TYPES END;
    ENTERID(CP);
    NEW(CP,TYPES);
    WITH CP^ DO
      BEGIN NAME := 'REAL    '; IDTYPE := REALPTR; KLASS := TYPES END;
    ENTERID(CP);
    NEW(CP,TYPES);
    WITH CP^ DO
      BEGIN NAME := 'CHAR    '; IDTYPE := CHARPTR; KLASS := TYPES END;
    ENTERID(CP);
    NEW(CP,TYPES);
    WITH CP^ DO
      BEGIN NAME := 'BOOLEAN '; IDTYPE := BOOLPTR; KLASS := TYPES END;
    ENTERID(CP);
    NEW(CP,TYPES);
    WITH CP^ DO
      BEGIN NAME := 'STRING  '; IDTYPE := STRGPTR; KLASS := TYPES END;
    ENTERID(CP);
    NEW(CP,TYPES);
    WITH CP^ DO
      BEGIN NAME := 'TEXT    '; IDTYPE := TEXTPTR; KLASS := TYPES END;
    ENTERID(CP);
    NEW(INPUTPTR,VARS);
    WITH INPUTPTR^ DO
      BEGIN NAME := 'INPUT   '; IDTYPE := TEXTPTR; KLASS := VARS;
	VKIND := FORMAL; VLEV := 0; VADDR := 2
      END;
    ENTERID(INPUTPTR);
    NEW(OUTPUTPTR,VARS);
    WITH OUTPUTPTR^ DO
      BEGIN NAME := 'OUTPUT  '; IDTYPE := TEXTPTR; KLASS := VARS;
	VKIND := FORMAL; VLEV := 0; VADDR := 3
      END;
    ENTERID(OUTPUTPTR);
    NEW(CP,VARS);
    WITH CP^ DO
      BEGIN NAME := 'KEYBOARD'; IDTYPE := TEXTPTR; KLASS := VARS;
	VKIND := FORMAL; VLEV := 0; VADDR := 4
      END;
    ENTERID(CP);
    CP1 := NIL;
    FOR I := 0 TO 1 DO
      BEGIN NEW(CP,KONST);
	WITH CP^ DO
	  BEGIN IDTYPE := BOOLPTR;
	    IF I = 0 THEN NAME := 'FALSE   '
	    ELSE NAME := 'TRUE    ';
	    NEXT := CP1; VALUES.IVAL := I; KLASS := KONST
	  END;
	ENTERID(CP); CP1 := CP
      END;
    BOOLPTR^.FCONST := CP;
    NEW(CP,KONST);
    WITH CP^ DO
      BEGIN NAME := 'NIL     '; IDTYPE := NILPTR;
	NEXT := NIL; VALUES.IVAL := 0; KLASS := KONST
      END;
    ENTERID(CP);
  END (*ENTSTDNAMES*) ;

  PROCEDURE ENTUNDECL;
  BEGIN
    NEW(UTYPPTR,TYPES);
    WITH UTYPPTR^ DO
      BEGIN NAME := '        '; IDTYPE := NIL; KLASS := TYPES END;
    NEW(UCSTPTR,KONST);
    WITH UCSTPTR^ DO
      BEGIN NAME := '        '; IDTYPE := NIL; NEXT := NIL;
	VALUES.IVAL := 0; KLASS := KONST
      END;
    NEW(UVARPTR,VARS);
    WITH UVARPTR^ DO
      BEGIN NAME := '        '; IDTYPE := NIL; VKIND := ACTUAL;
	NEXT := NIL; VLEV := 0; VADDR := 0; KLASS := VARS
      END;
    NEW(UFLDPTR,FIELD);
    WITH UFLDPTR^ DO
      BEGIN NAME := '        '; IDTYPE := NIL; NEXT := NIL;
	FLDADDR := 0; KLASS := FIELD
      END;
    NEW(UPRCPTR,PROC,DECLARED,ACTUAL);
    WITH UPRCPTR^ DO
      BEGIN NAME := '        '; IDTYPE := NIL; FORWDECL := FALSE;
	NEXT := NIL; INSCOPE := FALSE; LOCALLC := 0;
	PFLEV := 0; PFNAME := 0; PFSEG := 0;
	KLASS := PROC; PFDECKIND := DECLARED; PFKIND := ACTUAL
      END;
    NEW(UFCTPTR,FUNC,DECLARED,ACTUAL);
    WITH UFCTPTR^ DO
      BEGIN NAME := '        '; IDTYPE := NIL; NEXT := NIL;
	FORWDECL := FALSE; INSCOPE := FALSE; LOCALLC := 0;
	PFLEV := 0; PFNAME := 0; PFSEG := 0;
	KLASS := FUNC; PFDECKIND := DECLARED; PFKIND := ACTUAL
      END
  END (*ENTUNDECL*) ;

  PROCEDURE ENTSPCPROCS;
    VAR LCP: CTP; I: INTEGER; ISFUNC: BOOLEAN;
	NA: ARRAY [1..42] OF ALPHA;
  BEGIN
    NA[ 1] := 'READ    '; NA[ 2] := 'READLN  '; NA[ 3] := 'WRITE   ';
    NA[ 4] := 'WRITELN '; NA[ 5] := 'EOF     '; NA[ 6] := 'EOLN    ';
    NA[ 7] := 'PRED    '; NA[ 8] := 'SUCC    '; NA[ 9] := 'ORD     ';
    NA[10] := 'SQR     '; NA[11] := 'ABS     '; NA[12] := 'NEW     ';
    NA[13] := 'UNITREAD'; NA[14] := 'UNITWRIT'; NA[15] := 'CONCAT  ';
    NA[16] := 'LENGTH  '; NA[17] := 'INSERT  '; NA[18] := 'DELETE  ';
    NA[19] := 'COPY    '; NA[20] := 'POS     '; NA[21] := 'MOVELEFT';
    NA[22] := 'MOVERIGH'; NA[23] := 'EXIT    '; NA[24] := 'IDSEARCH';
    NA[25] := 'TREESEAR'; NA[26] := 'TIME    '; NA[27] := 'FILLCHAR';
    NA[28] := 'OPENNEW '; NA[29] := 'OPENOLD '; NA[30] := 'OPENIO  ';
    NA[31] := 'CLOSE   '; NA[32] := 'SEEK    '; NA[33] := 'RESET   ';
    NA[34] := 'GET     '; NA[35] := 'PUT     '; NA[36] := 'SCAN    ';
    NA[37] := 'BLOCKREA'; NA[38] := 'BLOCKWRI'; NA[39] := 'DRAWLINE';
    NA[40] := 'PAGE    '; NA[41] := 'SIZEOF  '; NA[42] := 'DRAWBLOC';
    FOR I := 1 TO 42 DO
      BEGIN ISFUNC := I IN [5,6,7,8,9,10,11,15,16,19,20,25,36,37,38,41];
	IF ISFUNC THEN NEW(LCP,FUNC,SPECIAL)
	ELSE NEW(LCP,PROC,SPECIAL);
	WITH LCP^ DO
	  BEGIN NAME := NA[I]; NEXT := NIL; IDTYPE := NIL;
	    IF ISFUNC THEN KLASS := FUNC ELSE KLASS := PROC;
	    PFDECKIND := SPECIAL; KEY := I
	  END;
	ENTERID(LCP)
      END
    END (*ENTSPCPROCS*) ;

  PROCEDURE ENTSTDPROCS;
    VAR LCP,PARAM: CTP; LSP,FTYPE: STP; I: INTEGER; ISPROC: BOOLEAN;
	NA: ARRAY [1..19] OF ALPHA;
  BEGIN
    NA[ 1] := 'ODD     '; NA[ 2] := 'CHR     '; NA[ 3] := 'TRUNC   ';
    NA[ 4] := 'ROUND   '; NA[ 5] := 'SIN     '; NA[ 6] := 'COS     ';
    NA[ 7] := 'LOG     '; NA[ 8] := 'ATAN    '; NA[ 9] := 'LN      ';
    NA[10] := 'EXP     '; NA[11] := 'SQRT    '; NA[12] := 'MARK    ';
    NA[13] := 'RELEASE '; NA[14] := 'IORESULT'; NA[15] := 'UNITBUSY';
    NA[16] := 'PWROFTEN'; NA[17] := 'UNITWAIT'; NA[18] := 'UNITCLEA';
    NA[19] := 'HALT    ';
    FOR I := 1 TO 19 DO
      BEGIN ISPROC := I IN [12,13,17,18,19];
	CASE I OF
	  1:  BEGIN FTYPE := BOOLPTR; NEW(PARAM,VARS);
	      WITH PARAM^ DO
		BEGIN IDTYPE := INTPTR; VKIND := ACTUAL END;
	      END;
	  2:  FTYPE := CHARPTR;
	  3:  BEGIN FTYPE := INTPTR; NEW(PARAM,VARS);
	      WITH PARAM^ DO
		BEGIN IDTYPE := REALPTR; VKIND := ACTUAL END;
	      END;
	  5:  FTYPE := REALPTR;
	 12:  BEGIN FTYPE := NIL; NEW(PARAM,VARS); NEW(LSP,POINTER);
	      WITH LSP^ DO
		BEGIN SIZE := PTRSIZE; FORM := POINTER; ELTYPE := NIL END;
	      WITH PARAM^ DO
		BEGIN IDTYPE := LSP; VKIND := FORMAL END;
	      END;
	 14:  BEGIN FTYPE := INTPTR; PARAM := NIL END;
	 15:  BEGIN FTYPE := BOOLPTR; NEW(PARAM,VARS);
	      WITH PARAM^ DO
		BEGIN IDTYPE := INTPTR; VKIND := ACTUAL END;
	      END;
	 16:  FTYPE := REALPTR;
	 17:  FTYPE := NIL;
	 19:  BEGIN FTYPE := NIL; PARAM := NIL END
	END (*PARAM AND TYPE CASES*) ;
	IF ISPROC THEN NEW(LCP,PROC,STANDARD)
	ELSE NEW(LCP,FUNC,STANDARD);
	WITH LCP^ DO
	  BEGIN NAME := NA[I]; PFDECKIND := STANDARD; CSPNUM := I + 20;
	    IF ISPROC THEN KLASS := PROC ELSE KLASS := FUNC;
	    IF PARAM <> NIL THEN
	      WITH PARAM^ DO
		BEGIN KLASS := VARS; NEXT := NIL END;
	    IDTYPE := FTYPE; NEXT := PARAM
	  END;
	ENTERID(LCP)
      END
    END (*ENTSTDPROCS*) ;

  PROCEDURE INITSCALARS;
  BEGIN FWPTR := NIL; GLOBTESTP := NIL;
    LINESTART := 0; LINEINFO := LCAFTERMARKSTACK; LIST := FALSE;
    SYMBLK := 2; SCREENDOTS := 0; STARTDOTS := 0;
    FOR SEG := 0 TO MAXSEG DO
      WITH SEGTABLE[SEG] DO
	BEGIN DISKADDR := 0; CODELENG := 0; SEGNAME := '        ' END;
    LC := LCAFTERMARKSTACK; IOCHECK := TRUE; DP := TRUE;
    SEGINX := 0; NEXTJTAB := 1; NEXTPROC := 2; CURPROC := 1;
    NEW(SCONST); NEW(SYMBUFP); NEW(CODEP);
    SEG := 1; NEXTSEG := 10; CURBLK := 1; CURBYTE := 0;
    GOTOOK := FALSE; RANGECHECK := TRUE; SYSCOMP := FALSE;
    CODEINSEG := FALSE; PRTERR := TRUE; INCLUDING := FALSE
  END (*INITSCALARS*) ;

  PROCEDURE INITSETS;
  BEGIN
    CONSTBEGSYS := [ADDOP,INTCONST,REALCONST,STRINGCONST,IDENT];
    SIMPTYPEBEGSYS := [LPARENT] + CONSTBEGSYS;
    TYPEBEGSYS := [ARROW,PACKEDSY,ARRAYSY,RECORDSY,SETSY,FILESY]
		  + SIMPTYPEBEGSYS;
    TYPEDELS := [ARRAYSY,RECORDSY,SETSY,FILESY];
    BLOCKBEGSYS := [LABELSY,CONSTSY,TYPESY,VARSY,PROCSY,FUNCSY,PROGSY,BEGINSY];
    SELECTSYS := [ARROW,PERIOD,LBRACK];
    FACBEGSYS := [INTCONST,REALCONST,STRINGCONST,IDENT,LPARENT,LBRACK,NOTSY];
    STATBEGSYS := [BEGINSY,GOTOSY,IFSY,WHILESY,REPEATSY,FORSY,WITHSY,CASESY]
  END (*INITSETS*) ;

BEGIN (*COMPINIT*)
  INITSCALARS; INITSETS;
  LEVEL := 0; TOP := 0;
  WITH DISPLAY[0] DO
    BEGIN FNAME := NIL; FFILE := NIL; FLABEL := NIL; OCCUR := BLCK END;
  ENTSTDTYPES;   ENTSTDNAMES;   ENTUNDECL;
  ENTSPCPROCS;   ENTSTDPROCS;
  GETNEXTPAGE;
  UNITWRITE(3,PROCTABLE[-1200],35);
  FOR IC := 1 TO 7 DO WRITELN(OUTPUT);
  WRITELN(OUTPUT,'PASCAL compilation');
  WRITE(OUTPUT,'<   0>');
  INSYMBOL;
  IF SYSCOMP THEN
    BEGIN OUTERBLOCK := NIL; SEG := 0; NEXTSEG := 1 END
  ELSE
    BEGIN TOP := 1; LEVEL := 1;
      WITH DISPLAY[1] DO
	BEGIN FNAME := NIL; FFILE := NIL;
	  FLABEL := NIL; OCCUR := BLCK
	END;
      LC := LC+2; (*KEEP STACK STRAIGHT FOR NOW*)
      NEW(OUTERBLOCK,PROC,DECLARED,ACTUAL);
      WITH OUTERBLOCK^ DO
	BEGIN NEXT := NIL; LOCALLC := LC;
	  NAME := 'PROGRAM '; IDTYPE := NIL; KLASS := PROC;
	  PFDECKIND := DECLARED; PFLEV := 0; PFNAME := 1; PFSEG := SEG;
	  PFKIND := ACTUAL; FORWDECL := FALSE; INSCOPE := TRUE
	END
    END;
  IF SY = PROGSY THEN
    BEGIN INSYMBOL;
      IF SY = IDENT THEN
	BEGIN SEGTABLE[SEG].SEGNAME := ID;
	  IF OUTERBLOCK <> NIL THEN OUTERBLOCK^.NAME := ID
	END
      ELSE ERROR(2); INSYMBOL;
      IF SY = SEMICOLON THEN INSYMBOL ELSE ERROR(14)
    END
END (*COMPINIT*) ;

========================================================================================
DOCUMENT :usus Folder:VOL17:comp.b.text
========================================================================================


PROCEDURE ERROR(*ERRORNUM: INTEGER*);
  VAR CH: CHAR;
BEGIN
  WITH USERINFO DO
    IF (ERRSYM <> SYMCURSOR) OR (ERRBLK <> SYMBLK) THEN
      BEGIN
	ERRSYM := SYMCURSOR; ERRBLK := SYMBLK;
	ERRNUM := ERRORNUM;
	IF STUPID THEN EXIT(COMPILER);
	WRITELN(OUTPUT); CH := ' ';
	WRITE(OUTPUT,SYMBUFP^:SYMCURSOR);
	WRITELN(OUTPUT,' <<<< Error # ',ERRORNUM:0);
	WRITE(OUTPUT,'Hit <SPACE> to continue');
	REPEAT UNITREAD(2,CH,1);
	UNTIL (CH = ' ') OR (CH = CHR(27));
	IF (ERRORNUM > 400) OR (CH = CHR(27)) THEN EXIT(COMPILER);
	WRITELN(OUTPUT);
	WRITE(OUTPUT,'<',SCREENDOTS:4,'>')
      END
END (*ERROR*) ;

PROCEDURE GETNEXTPAGE;
BEGIN SYMCURSOR := 0;
  IF INCLUDING THEN
    IF BLOCKREAD(INCLFILE,SYMBUFP^,2,SYMBLK) = 0 THEN
      BEGIN CLOSE(INCLFILE); INCLUDING := FALSE;
	SYMBLK := OLDSYMBLK; SYMCURSOR := OLDSYMCURSOR;
	LINESTART := SYMCURSOR   (*AT CR...WILL PRINT EXTRA LINE*)
      END;
  IF NOT INCLUDING THEN
    IF BLOCKREAD(USERINFO.WORKSYM^,SYMBUFP^,2,SYMBLK) <> 2 THEN
      ERROR(401);
  SYMBLK := SYMBLK+2
END (*GETNEXTPAGE*) ;

PROCEDURE PRINTLINE;
  VAR LPUNIT: INTEGER;
      A: PACKED ARRAY [0..1] OF CHAR;

  PROCEDURE WRITEINT(IVAL: INTEGER);
    VAR I,IPOT: INTEGER; CH: CHAR; ZAP: BOOLEAN;
	A: PACKED ARRAY [0..5] OF CHAR;
  BEGIN ZAP := TRUE; IPOT := 10000; A[0] := ' ';
    FOR I := 1 TO 5 DO
      BEGIN
	CH := CHR(IVAL DIV IPOT + ORD('0'));
	IF I <> 5 THEN
	  IF ZAP THEN
	    IF CH = '0' THEN CH := ' '
	    ELSE ZAP := FALSE;
	A[I] := CH;
	IVAL := IVAL MOD IPOT;
	IPOT := IPOT DIV 10
      END;
    UNITWRITE(LPUNIT,A,6)
  END (*WRITEINT*) ;

BEGIN LPUNIT := 6; (*PRINTLINE*)
  WRITEINT(SCREENDOTS); WRITEINT(CURPROC);
  A[0] := ':';
  IF DP THEN A[1] := 'D' ELSE A[1] := 'C';
  UNITWRITE(LPUNIT,A,2); WRITEINT(LINEINFO);
  A := '  '; UNITWRITE(LPUNIT,A,2); UNITWRITE(LPUNIT,A,2);
  UNITWRITE(LPUNIT,SYMBUFP^[LINESTART],SYMCURSOR-LINESTART,,TRUE)
END (*PRINTLINE*) ;

PROCEDURE STARTINCL;
(*I APOLOGIZE FOR SUCH KLOODGE AS THIS BUT IT HAS TO
  BE IN RIGHT NOW...*)
VAR TSTART,TLENG: INTEGER; TITLE: STRING[40];
BEGIN
  TSTART := SYMCURSOR+2;
  SYMCURSOR := SCAN(80,=CHR(EOL),SYMBUFP^[TSTART])+TSTART+1;
  TLENG := SYMCURSOR-TSTART-3;
  TITLE[0] := CHR(TLENG);
  MOVELEFT(SYMBUFP^[TSTART],TITLE[1],TLENG);
  OPENOLD(INCLFILE,TITLE);
  IF IORESULT <> 0 THEN
    BEGIN
      OPENOLD(INCLFILE,CONCAT(TITLE,'.TEXT'));
      IF IORESULT <> 0 THEN ERROR(403)
    END;
  SCREENDOTS := SCREENDOTS+1;
  IF LIST THEN PRINTLINE;
  INCLUDING := TRUE;
  OLDSYMCURSOR := SYMCURSOR-1; (*POINT AT CR...PREVENT END PAGE BLOWUP*)
  OLDSYMBLK := SYMBLK-2; (*SYMBLK IS NEXT TO READ...SAVE CUR PAGE#*)
  SYMBLK := 2; GETNEXTPAGE; LINESTART := SYMCURSOR;
  INSYMBOL; EXIT(INSYMBOL)  (*WEIRD, ISNT IT...*)
END (*STARTINCL*) ;

PROCEDURE INSYMBOL; (* COMPILER VERSION 3.4 06-NOV-76 *)
  LABEL 1;
  VAR LVP: CSP; X: INTEGER;

PROCEDURE CHECKEND;
BEGIN (* CHECKS FOR THE END OF THE PAGE *)
  WRITE(OUTPUT,'.');
  SCREENDOTS := SCREENDOTS+1;
  SYMCURSOR := SYMCURSOR + 1;
  IF (SCREENDOTS-STARTDOTS) MOD 50 = 0 THEN
    BEGIN WRITELN(OUTPUT);
      WRITE(OUTPUT,'<',SCREENDOTS:4,'>')
    END;
  IF LIST THEN PRINTLINE;
  IF SYMBUFP^[SYMCURSOR]=CHR(0) THEN GETNEXTPAGE;
  LINESTART := SYMCURSOR;
  IF SYMBUFP^[SYMCURSOR] = CHR(16) (*DLE*) THEN
    SYMCURSOR := SYMCURSOR+2
  ELSE
    BEGIN
      SYMCURSOR := SYMCURSOR+SCAN(80,<>CHR(9),SYMBUFP^[SYMCURSOR]);
      SYMCURSOR := SYMCURSOR+SCAN(80,<>' ',SYMBUFP^[SYMCURSOR])
    END;
  IF DP THEN LINEINFO := LC ELSE LINEINFO := IC
END;

PROCEDURE COMMENTER;
  VAR CH,SW,DEL: CHAR;
BEGIN
  SYMCURSOR := SYMCURSOR+2; (* POINT TO THE FIRST CH PAST "(*" *)
  IF SYMBUFP^[SYMCURSOR]='$'
    THEN
      BEGIN
	IF SYMBUFP^[SYMCURSOR+1] <> '*' THEN
	REPEAT
	  CH := SYMBUFP^[SYMCURSOR+1];
	  SW := SYMBUFP^[SYMCURSOR+2];
	  DEL := SYMBUFP^[SYMCURSOR+3];
	  CASE CH OF
	  'G': GOTOOK := (SW='+');
	  'I': IF (SW='+') OR (SW='-') THEN IOCHECK := (SW='+')
	       ELSE STARTINCL;
	  'L': LIST := (SW='+');
	  'R': RANGECHECK := (SW='+');
	  'U': BEGIN SYSCOMP := (SW = '-');
		 RANGECHECK := NOT SYSCOMP;
		 IOCHECK := RANGECHECK;
		 GOTOOK := SYSCOMP
	       END
	  END (*CASES*);
	  SYMCURSOR := SYMCURSOR+3;
	UNTIL DEL <> ',';
      END;
  SYMCURSOR := SYMCURSOR-1; (* ADJUST *)
  REPEAT
    REPEAT
      SYMCURSOR := SYMCURSOR+1;
      WHILE SYMBUFP^[SYMCURSOR] = CHR(EOL) DO CHECKEND
    UNTIL SYMBUFP^[SYMCURSOR]='*';
  UNTIL SYMBUFP^[SYMCURSOR+1]=')';
  SYMCURSOR := SYMCURSOR+2;
END (*COMMENTER*);

PROCEDURE STRING;
VAR
  T: PACKED ARRAY [1..80] OF CHAR;
  TP,NBLANKS,L: INTEGER;
  DUPLE: BOOLEAN;

BEGIN
  DUPLE := FALSE; (* INDICATES WHEN '' IS PRESENT *)
  TP := 0; (* INDEX INTO TEMPORARY STRING *)
  REPEAT
    IF DUPLE THEN SYMCURSOR := SYMCURSOR+1;
    REPEAT
      SYMCURSOR := SYMCURSOR+1;
      TP := TP+1;
      IF SYMBUFP^[SYMCURSOR] = CHR(EOL) THEN
	BEGIN ERROR(202); CHECKEND END;
      T[TP] := SYMBUFP^[SYMCURSOR];
    UNTIL SYMBUFP^[SYMCURSOR]='''';
    DUPLE := TRUE;
  UNTIL SYMBUFP^[SYMCURSOR+1]<>'''';
  TP := TP-1; (* ADJUST *)
  SY := STRINGCONST; OP := NOOP;
  LGTH := TP; (* GROSS *)
  IF TP=1 (* SINGLE CHARACTER CONSTANT *)
    THEN
      VAL.IVAL := ORD(T[1])
    ELSE
      WITH SCONST@ DO
	BEGIN
	  CCLASS := STRG;
	  SLGTH := TP;
	  MOVELEFT(T[1],SVAL[1],TP);
	  VAL.VALP := SCONST
	END
END(*STRING*);

PROCEDURE NUMBER;
VAR
  EXPONENT,ENDI,ENDF,ENDE,SIGN,IPART,FPART,EPART,
  ISUM:  INTEGER;
  TIPE: (REALTIPE,INTEGERTIPE);
  RSUM: REAL;
  J: INTEGER;
BEGIN
  (* TAKES A NUMBER AND DECIDES WHETHER IT'S REAL
     OR INTEGER AND CONVERTS IT TO THE INTERNAL
     FORM. *)
  TIPE := INTEGERTIPE;
  ENDI := 0;
  ENDF := 0;
  ENDE := 0;
  SIGN := 1;
  EPART := 9999; (* OUT OF REACH *)
  IPART := SYMCURSOR; (* INTEGER PART STARTS HERE *)
  REPEAT
    SYMCURSOR := SYMCURSOR+1
  UNTIL (SYMBUFP^[SYMCURSOR]<'0') OR (SYMBUFP^[SYMCURSOR]>'9');
  (* SYMCURSOR NOW POINTS AT FIRST CHARACTER PAST INTEGER PART *)
  ENDI := SYMCURSOR-1; (* MARK THE END OF IPART *)
  IF SYMBUFP^[SYMCURSOR]='.'
    THEN
      IF SYMBUFP^[SYMCURSOR+1]<>'.'  (* WATCH OUT FOR '..' *)
	THEN
	  BEGIN
	    TIPE := REALTIPE;
	    SYMCURSOR := SYMCURSOR+1;
	    FPART := SYMCURSOR; (* BEGINNING OF FPART *)
	    REPEAT
	      SYMCURSOR := SYMCURSOR+1
	    UNTIL (SYMBUFP^[SYMCURSOR]<'0') OR (SYMBUFP^[SYMCURSOR]>'9');
	    ENDF := SYMCURSOR-1;
	  END;
  IF SYMBUFP^[SYMCURSOR]='E'
    THEN
      BEGIN
	TIPE := REALTIPE;
	SYMCURSOR := SYMCURSOR+1;
	IF SYMBUFP^[SYMCURSOR]='-'
	  THEN
	    BEGIN
	      SYMCURSOR := SYMCURSOR+1;
	      SIGN := -1;
	    END
	  ELSE
	    IF SYMBUFP^[SYMCURSOR]='+'
	      THEN
		SYMCURSOR := SYMCURSOR+1;
	EPART := SYMCURSOR; (* BEGINNING OF EXPONENT *)
	WHILE (SYMBUFP^[SYMCURSOR]>='0') AND (SYMBUFP^[SYMCURSOR]<='9') DO
	  SYMCURSOR := SYMCURSOR+1;
  	ENDE := SYMCURSOR-1;
	IF ENDE<EPART THEN ERROR(201); (* ERROR IN REAL CONSTANT *)
      END;
  (* NOW CONVERT TO INTERNAL FORM *)
  IF TIPE=INTEGERTIPE
    THEN
      BEGIN
	ISUM := 0;
	FOR J := IPART TO ENDI DO
	  BEGIN
	    IF (ISUM>3276) OR ((ISUM=3276) AND (SYMBUFP^[J]>'7')) THEN
		BEGIN ERROR(203); J := ENDI END
	    ELSE ISUM := ISUM*10+ORD(SYMBUFP^[J])-ORD('0');
	  END;
	  SY := INTCONST;  OP := NOOP;
	  VAL.IVAL := ISUM;
	END
      ELSE
       BEGIN (* REAL NUMBER HERE *)
	 RSUM := 0;
	 FOR J := IPART TO ENDI DO
	   BEGIN
	     RSUM := RSUM*10+(ORD(SYMBUFP^[J])-ORD('0'));
	   END;
	 FOR J := ENDF DOWNTO FPART DO
	   RSUM := RSUM+(ORD(SYMBUFP^[J])-ORD('0'))/PWROFTEN(J-FPART+1);
	 EXPONENT := 0;
	 FOR J := EPART TO ENDE DO
	   EXPONENT := EXPONENT*10+ORD(SYMBUFP^[J])-ORD('0');
	 IF SIGN=-1
	   THEN
	     RSUM := RSUM/PWROFTEN(EXPONENT)
	   ELSE
	     RSUM := RSUM*PWROFTEN(EXPONENT);
	 SY := REALCONST;  OP := NOOP;
	 NEW(LVP,REEL);
	 LVP^.CCLASS := REEL;
	 LVP^.RVAL := RSUM;
	 VAL.VALP := LVP;
       END;
  SYMCURSOR := SYMCURSOR-1; (* ADJUST FOR POSTERITY *)
END;

BEGIN (* INSYMBOL *)
  OP := NOOP;
1:  SY := OTHERSY; (* IF NO CASES EXERCISED BLOW UP *)
  CASE SYMBUFP^[SYMCURSOR] OF
  '''':STRING;
  '0','1','2','3','4','5','6','7','8','9':
       NUMBER;
  'A','B','C','D','E','F','G','H','I','J','K','L',
  'M','N','O','P','Q','R','S','T','U','V','W','X',
  'Y','Z':
       IDSEARCH(SYMCURSOR,SYMBUFP^); (* MAGIC PROC *)
  '(': BEGIN
	 IF SYMBUFP^[SYMCURSOR+1]='*'
	   THEN
	     BEGIN
	       COMMENTER;
	       GOTO 1; (* GET ANOTHER TOKEN *)
	     END
	   ELSE
	     SY := LPARENT;
       END;
  ')': SY := RPARENT;
  ',': SY := COMMA;
  ' ','	': BEGIN SYMCURSOR := SYMCURSOR+1; GOTO 1; END;
  '.': BEGIN
	 IF SYMBUFP^[SYMCURSOR+1]='.'
	   THEN
	     BEGIN
	       SYMCURSOR := SYMCURSOR+1;
	       SY := COLON
	     END
	   ELSE
	     SY := PERIOD;
       END;
  ':': IF SYMBUFP^[SYMCURSOR+1]='='
	 THEN
	   BEGIN
	     SYMCURSOR := SYMCURSOR+1;
	     SY := BECOMES;
	  END
	ELSE
	   SY := COLON;
  ';': SY := SEMICOLON;
  '@','^':
       SY := ARROW;
  '[': SY := LBRACK;
  ']': SY := RBRACK;
  '*': BEGIN SY := MULOP; OP := MUL END;
  '+': BEGIN SY := ADDOP; OP := PLUS END;
  '-': BEGIN SY := ADDOP; OP := MINUS END;
  '/': BEGIN SY := MULOP; OP := RDIV END;
  '<': BEGIN
	 SY := RELOP;
	 OP := LTOP;
	 CASE SYMBUFP^[SYMCURSOR+1] OF
	   '>': BEGIN
		  OP := NEOP;
		  SYMCURSOR := SYMCURSOR+1
		END;
	   '=': BEGIN
		  OP := LEOP;
		  SYMCURSOR := SYMCURSOR+1
		END
	 END;
       END;
  '=': BEGIN SY := RELOP; OP := EQOP END;
  '>': BEGIN
	 SY := RELOP;
	 IF SYMBUFP^[SYMCURSOR+1]='='
	   THEN
	     BEGIN
	       OP := GEOP;
	       SYMCURSOR := SYMCURSOR+1;
	     END
	   ELSE
	     OP := GTOP;
       END
END (* CASE SYMBUFP^[SYMCURSOR] OF *);
  IF SY=OTHERSY THEN
    IF SYMBUFP^[SYMCURSOR] = CHR(EOL) THEN
      BEGIN CHECKEND; GOTO 1 END
    ELSE ERROR(400);
  SYMCURSOR := SYMCURSOR+1; (* NEXT CALL TALKS ABOUT NEXT TOKEN *)
END (*INSYMBOL*) ;

  PROCEDURE ENTERID(*FCP: CTP*);
    VAR LCP,LCP1: CTP; I: INTEGER;
  BEGIN LCP := DISPLAY[TOP].FNAME;
    IF LCP = NIL THEN DISPLAY[TOP].FNAME := FCP
    ELSE
      BEGIN I := TREESEARCH(LCP,LCP1,FCP^.NAME);
	WHILE I = 0 DO
	  BEGIN ERROR(101);
	    IF LCP1^.RLINK = NIL THEN I := 1
	    ELSE I := TREESEARCH(LCP1^.RLINK,LCP1,FCP^.NAME)
	  END;
	IF I = 1 THEN LCP1^.RLINK := FCP ELSE LCP1^.LLINK := FCP
      END;
    FCP^.LLINK := NIL; FCP^.RLINK := NIL
  END (*ENTERID*) ;

  PROCEDURE SEARCHSECTION(FCP: CTP; VAR FCP1: CTP);
  BEGIN
    IF FCP <> NIL THEN
      IF TREESEARCH(FCP,FCP1,ID) = 0 THEN (*NADA*)
      ELSE FCP1 := NIL
    ELSE FCP1 := NIL
  END (*SEARCHSECTION*) ;

  PROCEDURE SEARCHID(FIDCLS: SETOFIDS; VAR FCP: CTP);
    LABEL 1; VAR LCP: CTP;
  BEGIN
    FOR DISX := TOP DOWNTO 0 DO
      BEGIN LCP := DISPLAY[DISX].FNAME;
	IF LCP <> NIL THEN
	  IF TREESEARCH(LCP,LCP,ID) = 0 THEN
	    IF LCP^.KLASS IN FIDCLS THEN GOTO 1
	    ELSE
	      IF PRTERR THEN ERROR(103)
	      ELSE LCP := NIL
	  ELSE LCP := NIL
      END;
    IF PRTERR THEN
      BEGIN ERROR(104);
	IF TYPES IN FIDCLS THEN LCP := UTYPPTR
	ELSE
	  IF VARS IN FIDCLS THEN LCP := UVARPTR
	  ELSE
	    IF FIELD IN FIDCLS THEN LCP := UFLDPTR
	    ELSE
	      IF KONST IN FIDCLS THEN LCP := UCSTPTR
	      ELSE
		IF PROC IN FIDCLS THEN LCP := UPRCPTR
		ELSE LCP := UFCTPTR
      END;
1:  FCP := LCP
  END (*SEARCHID*) ;

  PROCEDURE GETBOUNDS(FSP: STP; VAR FMIN,FMAX: INTEGER);
  BEGIN
    WITH FSP^ DO
      IF FORM = SUBRANGE THEN
	BEGIN FMIN := MIN.IVAL; FMAX := MAX.IVAL END
      ELSE
	BEGIN FMIN := 0;
	  IF FSP = CHARPTR THEN FMAX := 255
	  ELSE
	    IF FSP^.FCONST <> NIL THEN
	      FMAX := FSP^.FCONST^.VALUES.IVAL
	    ELSE FMAX := 0
	END
  END (*GETBOUNDS*) ;

  PROCEDURE SKIP(FSYS: SETOFSYS);
  BEGIN WHILE NOT(SY IN FSYS) DO INSYMBOL
  END (*SKIP*) ;

  FUNCTION PAOFCHAR(FSP: STP): BOOLEAN;
  BEGIN PAOFCHAR := FALSE;
    IF FSP <> NIL THEN
      IF FSP^.FORM = ARRAYS THEN
	PAOFCHAR := FSP^.AISPACKD AND (FSP^.AELTYPE = CHARPTR)
  END (*PAOFCHAR*) ;

  FUNCTION STRGTYPE(FSP: STP) : BOOLEAN;
  BEGIN STRGTYPE := FALSE;
    IF PAOFCHAR(FSP) THEN STRGTYPE := FSP^.AISSTRNG
  END (*STRGTYPE*) ;

  PROCEDURE CONSTANT(FSYS: SETOFSYS; VAR FSP: STP; VAR FVALU: VALU);
    VAR LSP: STP; LCP: CTP; SIGN: (NONE,POS,NEG);
	LVP: CSP;
  BEGIN LSP := NIL; FVALU.IVAL := 0;
    IF NOT(SY IN CONSTBEGSYS) THEN
      BEGIN ERROR(50); SKIP(FSYS+CONSTBEGSYS) END;
    IF SY IN CONSTBEGSYS THEN
      BEGIN
	IF SY = STRINGCONSTSY THEN
	  BEGIN
	    IF LGTH = 1 THEN LSP := CHARPTR
	    ELSE
	      BEGIN
		NEW(LSP,ARRAYS,TRUE,TRUE);
		LSP^ := STRGPTR^;
		LSP^.MAXLENG := LGTH;
		LSP^.INXTYPE := NIL;
		NEW(LVP);
		LVP^ := VAL.VALP^;
		VAL.VALP := LVP
	      END;
	    FVALU := VAL; INSYMBOL
	  END
	ELSE
	  BEGIN
	    SIGN := NONE;
	    IF (SY = ADDOP) AND (OP IN [PLUS,MINUS]) THEN
	      BEGIN IF OP = PLUS THEN SIGN := POS ELSE SIGN := NEG;
		INSYMBOL
	      END;
	    IF SY = IDENT THEN
	      BEGIN SEARCHID([KONST],LCP);
		WITH LCP^ DO
		  BEGIN LSP := IDTYPE; FVALU := VALUES END;
		IF SIGN <> NONE THEN
		  IF LSP = INTPTR THEN
		    BEGIN IF SIGN = NEG THEN
		      FVALU.IVAL := -FVALU.IVAL END
		  ELSE
		    IF LSP = REALPTR THEN
		      BEGIN
			IF SIGN = NEG THEN
			  BEGIN NEW(LVP,REEL);
			    LVP^.CCLASS := REEL;
			    LVP^.RVAL := -FVALU.VALP^.RVAL;
			    FVALU.VALP := LVP;
			  END
			END
		      ELSE ERROR(105);
		INSYMBOL;
	      END
	    ELSE
	      IF SY = INTCONST THEN
		BEGIN IF SIGN = NEG THEN VAL.IVAL := -VAL.IVAL;
		  LSP := INTPTR; FVALU := VAL; INSYMBOL
		END
	      ELSE
		IF SY = REALCONST THEN
		  BEGIN IF SIGN = NEG THEN
			  VAL.VALP^.RVAL := -VAL.VALP^.RVAL;
		    LSP := REALPTR; FVALU := VAL; INSYMBOL
		  END
		ELSE
		  BEGIN ERROR(106); SKIP(FSYS) END
	  END;
	IF NOT (SY IN FSYS) THEN
	  BEGIN ERROR(6); SKIP(FSYS) END
	END;
    FSP := LSP
  END (*CONSTANT*) ;

  FUNCTION COMPTYPES(FSP1,FSP2: STP) : BOOLEAN;
    VAR NXT1,NXT2: CTP; COMP: BOOLEAN;
      LTESTP1,LTESTP2 : TESTP;
  BEGIN
    IF FSP1 = FSP2 THEN COMPTYPES := TRUE
    ELSE
      IF (FSP1 = NIL) OR (FSP2 = NIL) THEN COMPTYPES := TRUE
      ELSE
	IF FSP1^.FORM = FSP2^.FORM THEN
	  CASE FSP1^.FORM OF
	    SCALAR:
	      COMPTYPES := FALSE;
	    SUBRANGE:
	      COMPTYPES := COMPTYPES(FSP1^.RANGETYPE,
				       FSP2^.RANGETYPE);
	    POINTER:
		BEGIN
		  COMP := FALSE; LTESTP1 := GLOBTESTP;
		  LTESTP2 := GLOBTESTP;
		  WHILE LTESTP1 <> NIL DO
		    WITH LTESTP1^ DO
		      BEGIN
			IF (ELT1 = FSP1^.ELTYPE) AND
			  (ELT2 = FSP2^.ELTYPE) THEN COMP := TRUE;
			LTESTP1 := LASTTESTP
		      END;
		  IF NOT COMP THEN
		    BEGIN NEW(LTESTP1);
		      WITH LTESTP1^ DO
			BEGIN ELT1 := FSP1^.ELTYPE;
			  ELT2 := FSP2^.ELTYPE;
			  LASTTESTP := GLOBTESTP
			END;
		      GLOBTESTP := LTESTP1;
		      COMP := COMPTYPES(FSP1^.ELTYPE,FSP2^.ELTYPE)
		    END;
		  COMPTYPES := COMP; GLOBTESTP := LTESTP2
		END;
	    POWER:
	      COMPTYPES := COMPTYPES(FSP1^.ELSET,FSP2^.ELSET);
	    ARRAYS:
	      BEGIN
		COMP := COMPTYPES(FSP1^.AELTYPE,FSP2^.AELTYPE)
			AND (FSP1^.AISPACKD = FSP2^.AISPACKD);
		IF COMP AND FSP1^.AISPACKD THEN
		    COMP := (FSP1^.ELSPERWD = FSP2^.ELSPERWD)
			    AND (FSP1^.ELWIDTH = FSP2^.ELWIDTH)
			    AND (FSP1^.AISSTRNG = FSP2^.AISSTRNG);
		IF COMP AND NOT STRGTYPE(FSP1) THEN
		  COMP := (FSP1^.SIZE = FSP2^.SIZE);
		COMPTYPES := COMP;
	      END;
	    RECORDS:
	      BEGIN NXT1 := FSP1^.FSTFLD; NXT2 := FSP2^.FSTFLD;
		COMP := TRUE;
		WHILE (NXT1 <> NIL) AND (NXT2 <> NIL) AND COMP DO
		  BEGIN COMP:=COMPTYPES(NXT1^.IDTYPE,NXT2^.IDTYPE);
		    NXT1 := NXT1^.NEXT; NXT2 := NXT2^.NEXT
		  END;
		COMPTYPES := COMP AND (NXT1 = NIL) AND (NXT2 = NIL)
			    AND (FSP1^.RECVAR = NIL)
			    AND (FSP2^.RECVAR = NIL)
	      END;
	    FILES:
	      COMPTYPES := COMPTYPES(FSP1^.FILTYPE,FSP2^.FILTYPE)
	  END (*CASE*)
	ELSE (*FSP1^.FORM <> FSP2^.FORM*)
	  IF FSP1^.FORM = SUBRANGE THEN
	    COMPTYPES := COMPTYPES(FSP1^.RANGETYPE,FSP2)
	  ELSE
	    IF FSP2^.FORM = SUBRANGE THEN
	      COMPTYPES := COMPTYPES(FSP1,FSP2^.RANGETYPE)
	    ELSE COMPTYPES := FALSE
  END (*COMPTYPES*) ;

========================================================================================
DOCUMENT :usus Folder:VOL17:comp.c.text
========================================================================================


  PROCEDURE TYP(FSYS: SETOFSYS; VAR FSP: STP; VAR FSIZE: ADDRRANGE);
    VAR LSP,LSP1,LSP2: STP; OLDTOP: DISPRANGE; LCP: CTP;
	LSIZE,DISPL: ADDRRANGE; LMIN,LMAX: INTEGER;
	PACKING: BOOLEAN; NEXTBIT,NUMBITS: BITRANGE;

    PROCEDURE SIMPLETYPE(FSYS:SETOFSYS; VAR FSP:STP; VAR FSIZE:ADDRRANGE);
      VAR LSP,LSP1: STP; LCP,LCP1: CTP; TTOP: DISPRANGE;
	  LCNT: INTEGER; LVALU: VALU;
    BEGIN FSIZE := 1;
      IF NOT (SY IN SIMPTYPEBEGSYS) THEN
	BEGIN ERROR(1); SKIP(FSYS + SIMPTYPEBEGSYS) END;
      IF SY IN SIMPTYPEBEGSYS THEN
	BEGIN
	  IF SY = LPARENT THEN
	    BEGIN TTOP := TOP;
	      WHILE DISPLAY[TOP].OCCUR <> BLCK DO TOP := TOP - 1;
	      NEW(LSP,SCALAR,DECLARED);
	      WITH LSP^ DO
		BEGIN SIZE := INTSIZE; FORM := SCALAR;
		  SCALKIND := DECLARED
		END;
	      LCP1 := NIL; LCNT := 0;
	      REPEAT INSYMBOL;
		IF SY = IDENT THEN
		  BEGIN NEW(LCP,KONST);
		    WITH LCP^ DO
		      BEGIN NAME := ID; IDTYPE := LSP; NEXT := LCP1;
			VALUES.IVAL := LCNT; KLASS := KONST
		      END;
		    ENTERID(LCP);
		    LCNT := LCNT + 1;
		    LCP1 := LCP; INSYMBOL
		  END
		ELSE ERROR(2);
		IF NOT (SY IN FSYS + [COMMA,RPARENT]) THEN
		  BEGIN ERROR(6); SKIP(FSYS + [COMMA,RPARENT]) END
	      UNTIL SY <> COMMA;
	      LSP^.FCONST := LCP1; TOP := TTOP;
	      IF SY = RPARENT THEN INSYMBOL ELSE ERROR(4)
	    END
	  ELSE
	    BEGIN
	      IF SY = IDENT THEN
		BEGIN SEARCHID([TYPES,KONST],LCP);
		  INSYMBOL;
		  IF LCP^.KLASS = KONST THEN
		    BEGIN NEW(LSP,SUBRANGE);
		      WITH LSP^, LCP^ DO
			BEGIN RANGETYPE := IDTYPE; FORM := SUBRANGE;
			  IF STRGTYPE(RANGETYPE) THEN
			    BEGIN ERROR(148); RANGETYPE := NIL END;
			  MIN := VALUES; SIZE := INTSIZE
			END;
		      IF SY = COLON THEN INSYMBOL ELSE ERROR(5);
		      CONSTANT(FSYS,LSP1,LVALU);
		      LSP^.MAX := LVALU;
		      IF LSP^.RANGETYPE <> LSP1 THEN ERROR(107)
		    END
		  ELSE
		    BEGIN LSP := LCP^.IDTYPE;
		      IF (LSP = STRGPTR) AND (SY = LBRACK) THEN
			BEGIN INSYMBOL;
			  CONSTANT(FSYS + [RBRACK],LSP1,LVALU);
			  IF LSP1 = INTPTR THEN
			    BEGIN
			      IF (LVALU.IVAL <= 0) OR
				 (LVALU.IVAL > STRGLGTH) THEN
				BEGIN ERROR(203);
				  LVALU.IVAL := DEFSTRGLGTH
				END;
			      IF LVALU.IVAL <> DEFSTRGLGTH THEN
				BEGIN NEW(LSP,ARRAYS,TRUE,TRUE);
				  LSP^ := STRGPTR^;
				  WITH LSP^,LVALU DO
				    BEGIN MAXLENG := IVAL;
				      SIZE := (IVAL+CHRSPERWD) DIV CHRSPERWD
				    END
				END
			    END
			  ELSE ERROR(15);
			  IF SY = RBRACK THEN INSYMBOL ELSE ERROR(12)
			END;
		      IF LSP <> NIL THEN FSIZE := LSP^.SIZE
		    END
		END (*SY = IDENT*)
	      ELSE
		BEGIN NEW(LSP,SUBRANGE); LSP^.FORM := SUBRANGE;
		  CONSTANT(FSYS + [COLON],LSP1,LVALU);
		  IF STRGTYPE(LSP1) THEN
		    BEGIN ERROR(148); LSP1 := NIL END;
		  WITH LSP^ DO
		    BEGIN RANGETYPE:=LSP1; MIN:=LVALU; SIZE:=INTSIZE END;
		  IF SY = COLON THEN INSYMBOL ELSE ERROR(5);
		  CONSTANT(FSYS,LSP1,LVALU);
		  LSP^.MAX := LVALU;
		  IF LSP^.RANGETYPE <> LSP1 THEN ERROR(107)
		END;
	      IF LSP <> NIL THEN
		WITH LSP^ DO
		  IF FORM = SUBRANGE THEN
		    IF RANGETYPE <> NIL THEN
		      IF RANGETYPE = REALPTR THEN ERROR(399)
		      ELSE
			IF MIN.IVAL > MAX.IVAL THEN
			  BEGIN ERROR(102); MAX.IVAL := MIN.IVAL END
	    END;
	  FSP := LSP;
	  IF NOT (SY IN FSYS) THEN
	    BEGIN ERROR(6); SKIP(FSYS) END
	END
	  ELSE FSP := NIL
    END (*SIMPLETYPE*) ;

    FUNCTION PACKABLE(FSP: STP): BOOLEAN;
      VAR LMIN,LMAX: INTEGER;
    BEGIN PACKABLE := FALSE;
      IF (FSP <> NIL) AND PACKING THEN
	WITH FSP^ DO
	  CASE FORM OF
	    SUBRANGE,
	    SCALAR:  IF (FSP <> INTPTR) AND (FSP <> REALPTR) THEN
		       BEGIN GETBOUNDS(FSP,LMIN,LMAX);
			 IF LMIN >= 0 THEN
			   BEGIN PACKABLE := TRUE;
			     NUMBITS := 1; LMIN := 1;
			     WHILE LMIN < LMAX DO
			       BEGIN LMIN := LMIN + 1;
				 LMIN := LMIN + LMIN - 1;
				 NUMBITS := NUMBITS + 1
			       END
			   END
		       END;
	    POWER:   IF PACKABLE(ELSET) THEN
		       BEGIN GETBOUNDS(ELSET,LMIN,LMAX);
			 LMAX := LMAX + 1;
			 IF LMAX < BITSPERWD THEN
			   BEGIN PACKABLE := TRUE;
			     NUMBITS := LMAX
			   END
		       END
	  END (* CASES *);
    END (*PACKABLE*) ;

    PROCEDURE FIELDLIST(FSYS: SETOFSYS; VAR FRECVAR: STP);
      VAR LCP,LCP1,NXT,NXT1,LAST: CTP; LSP,LSP1,LSP2,LSP3,LSP4: STP;
	  MINSIZE,MAXSIZE,LSIZE: ADDRRANGE; LVALU: VALU;
	  MAXBIT,MINBIT: BITRANGE;

      PROCEDURE ALLOCATE(FCP: CTP);
	VAR ONBOUND: BOOLEAN;
      BEGIN ONBOUND := FALSE;
	WITH FCP^ DO
	  IF PACKABLE(IDTYPE) THEN
	    BEGIN
	      IF (NUMBITS + NEXTBIT) > BITSPERWD THEN
		BEGIN DISPL := DISPL + 1; NEXTBIT := 0; ONBOUND := TRUE END;
	      FLDADDR := DISPL; FISPACKD := TRUE;
	      FLDWIDTH := NUMBITS; FLDRBIT := NEXTBIT;
	      NEXTBIT := NEXTBIT + NUMBITS
	    END
	  ELSE
	    BEGIN DISPL := DISPL + ORD(NEXTBIT > 0);
	      NEXTBIT := 0; ONBOUND := TRUE;
	      FISPACKD := FALSE; FLDADDR := DISPL;
	      IF IDTYPE <> NIL THEN
		DISPL := DISPL + IDTYPE^.SIZE
	    END;
	IF ONBOUND AND (LAST <> NIL) THEN
	  WITH LAST^ DO
	    IF FISPACKD THEN
	      IF FLDRBIT = 0 THEN FISPACKD := FALSE
	      ELSE
		IF (FLDWIDTH <= 8) AND (FLDRBIT <= 8) THEN
		  BEGIN FLDWIDTH := 8; FLDRBIT := 8 END
      END (*ALLOCATE*) ;

      PROCEDURE VARIANTLIST;
	VAR GOTTAGNAME: BOOLEAN;
      BEGIN NEW(LSP,TAGFLD);
	WITH LSP^ DO
	  BEGIN TAGFIELDP := NIL; FSTVAR := NIL; FORM := TAGFLD END;
	FRECVAR := LSP;
	INSYMBOL;
	IF SY = IDENT THEN
	  BEGIN
	    IF PACKING THEN NEW(LCP,FIELD,TRUE)
	    ELSE NEW(LCP,FIELD,FALSE);
	    WITH LCP^ DO
	      BEGIN IDTYPE := NIL; KLASS:=FIELD;
		NEXT := NIL; FISPACKD := FALSE
	      END;
	    GOTTAGNAME := FALSE; PRTERR := FALSE;
	    SEARCHID([TYPES],LCP1); PRTERR := TRUE;
	    IF LCP1 = NIL THEN
	      BEGIN GOTTAGNAME := TRUE;
		LCP^.NAME := ID; ENTERID(LCP); INSYMBOL;
		IF SY = COLON THEN INSYMBOL ELSE ERROR(5)
	      END;
	    IF SY = IDENT THEN
	      BEGIN SEARCHID([TYPES],LCP1);
		LSP1 := LCP1^.IDTYPE;
		IF LSP1 <> NIL THEN
		  BEGIN
		    IF LSP1^.FORM <= SUBRANGE THEN
		      BEGIN
			IF COMPTYPES(REALPTR,LSP1) THEN ERROR(109);
			LCP^.IDTYPE := LSP1; LSP^.TAGFIELDP := LCP;
			IF GOTTAGNAME THEN ALLOCATE(LCP)
		      END
		    ELSE ERROR(110)
		  END;
		INSYMBOL
	      END
	    ELSE BEGIN ERROR(2); SKIP(FSYS + [OFSY,LPARENT]) END
	  END
	ELSE BEGIN ERROR(2); SKIP(FSYS + [OFSY,LPARENT]) END;
	LSP^.SIZE := DISPL + ORD(NEXTBIT > 0);
	IF SY = OFSY THEN INSYMBOL ELSE ERROR(8);
	LSP1 := NIL; MINSIZE := DISPL; MAXSIZE := DISPL;
	MINBIT := NEXTBIT; MAXBIT := NEXTBIT;
	REPEAT LSP2 := NIL;
	  REPEAT CONSTANT(FSYS + [COMMA,COLON,LPARENT],LSP3,LVALU);
	    IF LSP^.TAGFIELDP <> NIL THEN
	      IF NOT COMPTYPES(LSP^.TAGFIELDP^.IDTYPE,LSP3) THEN
		ERROR(111);
	    NEW(LSP3,VARIANT);
	    WITH LSP3^ DO
	      BEGIN NXTVAR := LSP1; SUBVAR := LSP2;
		VARVAL := LVALU; FORM := VARIANT
	      END;
	    LSP1 := LSP3; LSP2 := LSP3;
	    TEST := SY <> COMMA;
	    IF NOT TEST THEN INSYMBOL
	  UNTIL TEST;
	  IF SY = COLON THEN INSYMBOL ELSE ERROR(5);
	  IF SY = LPARENT THEN INSYMBOL ELSE ERROR(9);
	  IF SY = RPARENT THEN LSP2 := NIL
	  ELSE
	    FIELDLIST(FSYS + [RPARENT,SEMICOLON],LSP2);
	  IF DISPL > MAXSIZE THEN
	    BEGIN MAXSIZE := DISPL; MAXBIT := NEXTBIT END
	  ELSE
	    IF (DISPL = MAXSIZE) AND (NEXTBIT > MAXBIT) THEN
	      MAXBIT := NEXTBIT;
	  WHILE LSP3 <> NIL DO
	    BEGIN LSP4 := LSP3^.SUBVAR; LSP3^.SUBVAR := LSP2;
	      LSP3^.SIZE := DISPL + ORD(NEXTBIT > 0);
	      LSP3 := LSP4
	    END;
	  IF SY = RPARENT THEN
	    BEGIN INSYMBOL;
	      IF NOT (SY IN FSYS + [SEMICOLON]) THEN
		BEGIN ERROR(6); SKIP(FSYS + [SEMICOLON]) END
	    END
	  ELSE ERROR(4);
	  TEST := SY <> SEMICOLON;
	  IF NOT TEST THEN
	    BEGIN INSYMBOL;
	      DISPL := MINSIZE; NEXTBIT := MINBIT
	    END
	UNTIL TEST;
	DISPL := MAXSIZE; NEXTBIT := MAXBIT;
	LSP^.FSTVAR := LSP1
      END (*VARIANTLIST*) ;

    BEGIN (*FIELDLIST*)
      NXT1 := NIL; LSP := NIL; LAST := NIL;
      IF NOT (SY IN [IDENT,CASESY]) THEN
	BEGIN ERROR(19); SKIP(FSYS + [IDENT,CASESY]) END;
      WHILE SY = IDENT DO
	BEGIN NXT := NXT1;
	  REPEAT
	    IF SY = IDENT THEN
	      BEGIN
		IF PACKING THEN NEW(LCP,FIELD,TRUE)
		ELSE NEW(LCP,FIELD,FALSE);
		WITH LCP^ DO
		  BEGIN NAME := ID; IDTYPE := NIL; NEXT := NXT;
		    KLASS := FIELD; FISPACKD := FALSE
		  END;
		NXT := LCP;
		ENTERID(LCP);
		INSYMBOL
	      END
	    ELSE ERROR(2);
	    IF NOT (SY IN [COMMA,COLON]) THEN
	      BEGIN ERROR(6); SKIP(FSYS + [COMMA,COLON,SEMICOLON,CASESY]) END;
	    TEST := SY <> COMMA;
	    IF NOT TEST  THEN INSYMBOL
	  UNTIL TEST;
	  IF SY = COLON THEN INSYMBOL ELSE ERROR(5);
	  TYP(FSYS + [CASESY,SEMICOLON],LSP,LSIZE);
	  IF LSP <> NIL THEN
	    IF LSP^.FORM = FILES THEN ERROR(108);
	  WHILE NXT <> NXT1 DO
	    WITH NXT^ DO
	      BEGIN IDTYPE := LSP; ALLOCATE(NXT);
		IF NEXT = NXT1 THEN LAST := NXT;
		NXT := NEXT
	      END;
	  NXT1 := LCP;
	  IF SY = SEMICOLON THEN
	    BEGIN INSYMBOL;
	      IF NOT (SY IN [IDENT,CASESY]) THEN
		BEGIN ERROR(19); SKIP(FSYS + [IDENT,CASESY]) END
	    END
	END (*WHILE*);
      NXT := NIL;
      WHILE NXT1 <> NIL DO
	WITH NXT1^ DO
	  BEGIN LCP := NEXT; NEXT := NXT; NXT := NXT1; NXT1 := LCP END;
      IF SY = CASESY THEN VARIANTLIST
      ELSE FRECVAR := NIL
    END (*FIELDLIST*) ;

    PROCEDURE POINTERTYPE;
    BEGIN NEW(LSP,POINTER); FSP := LSP;
      WITH LSP^ DO
	BEGIN ELTYPE := NIL; SIZE := PTRSIZE; FORM := POINTER END;
      INSYMBOL;
      IF SY = IDENT THEN
	BEGIN PRTERR := FALSE;
	  SEARCHID([TYPES],LCP); PRTERR := TRUE;
	  IF LCP = NIL THEN   (*FORWARD REFERENCED TYPE ID*)
	    BEGIN NEW(LCP,TYPES);
	      WITH LCP^ DO
		BEGIN NAME := ID; IDTYPE := LSP;
		  NEXT := FWPTR; KLASS := TYPES
		END;
	      FWPTR := LCP
	    END
	  ELSE
	    BEGIN
	      IF LCP^.IDTYPE <> NIL THEN
		IF (LCP^.IDTYPE^.FORM <> FILES) OR SYSCOMP THEN
		  LSP^.ELTYPE := LCP^.IDTYPE
		ELSE ERROR(108)
	    END;
	  INSYMBOL;
	END
      ELSE ERROR(2)
    END (*POINTERTYPE*) ;

  BEGIN (*TYP*)
    PACKING := FALSE;
    IF NOT (SY IN TYPEBEGSYS) THEN
       BEGIN ERROR(10); SKIP(FSYS + TYPEBEGSYS) END;
    IF SY IN TYPEBEGSYS THEN
      BEGIN
	IF SY IN SIMPTYPEBEGSYS THEN SIMPLETYPE(FSYS,FSP,FSIZE)
	ELSE
  (*^*)   IF SY = ARROW THEN POINTERTYPE
	  ELSE
	    BEGIN
	      IF SY = PACKEDSY THEN
		BEGIN INSYMBOL; PACKING := TRUE;
		  IF NOT (SY IN TYPEDELS) THEN
		    BEGIN ERROR(10); SKIP(FSYS + TYPEDELS) END
		END;
  (*ARRAY*)   IF SY = ARRAYSY THEN
		BEGIN INSYMBOL;
		  IF SY = LBRACK THEN INSYMBOL ELSE ERROR(11);
		  LSP1 := NIL;
		  REPEAT
		    IF PACKING THEN NEW(LSP,ARRAYS,TRUE,FALSE)
		    ELSE NEW(LSP,ARRAYS,FALSE);
		    WITH LSP^ DO
		      BEGIN AELTYPE := LSP1; INXTYPE := NIL;
			IF PACKING THEN AISSTRNG := FALSE;
			AISPACKD := FALSE;  FORM := ARRAYS
		      END;
		    LSP1 := LSP;
		    SIMPLETYPE(FSYS + [COMMA,RBRACK,OFSY],LSP2,LSIZE);
		    LSP1^.SIZE := LSIZE;
		    IF LSP2 <> NIL THEN
		      IF LSP2^.FORM <= SUBRANGE THEN
			BEGIN
			  IF LSP2 = REALPTR THEN
			    BEGIN ERROR(109); LSP2 := NIL END
			  ELSE
			    IF LSP2 = INTPTR THEN
			      BEGIN ERROR(149); LSP2 := NIL END;
			  LSP^.INXTYPE := LSP2
			END
		      ELSE BEGIN ERROR(113); LSP2 := NIL END;
		    TEST := SY <> COMMA;
		    IF NOT TEST THEN INSYMBOL
		  UNTIL TEST;
		  IF SY = RBRACK THEN INSYMBOL ELSE ERROR(12);
		  IF SY = OFSY THEN INSYMBOL ELSE ERROR(8);
		  TYP(FSYS,LSP,LSIZE);
		  IF LSP <> NIL THEN
		    IF LSP^.FORM = FILES THEN ERROR(108);
		  IF PACKABLE(LSP) THEN
		    IF NUMBITS + NUMBITS <= BITSPERWD THEN
		      WITH LSP1^ DO
			BEGIN AISPACKD := TRUE;
			  ELSPERWD := BITSPERWD DIV NUMBITS;
			  ELWIDTH := NUMBITS
			END;
		  REPEAT
		    WITH LSP1^ DO
		      BEGIN LSP2 := AELTYPE; AELTYPE := LSP;
			IF INXTYPE <> NIL THEN
			  BEGIN GETBOUNDS(INXTYPE,LMIN,LMAX);
			    IF AISPACKD THEN
			      LSIZE := (LMAX-LMIN+ELSPERWD)
						 DIV ELSPERWD
			    ELSE
			      LSIZE := LSIZE*(LMAX - LMIN + 1);
			    IF LSIZE <= 0 THEN
			      BEGIN ERROR(398); LSIZE := 1 END;
			    SIZE := LSIZE
			  END
		      END;
		    LSP := LSP1; LSP1 := LSP2
		  UNTIL LSP1 = NIL
		END
	      ELSE
  (*RECORD*)    IF SY = RECORDSY THEN
		  BEGIN INSYMBOL;
		    OLDTOP := TOP;
		    IF TOP < DISPLIMIT THEN
		      BEGIN TOP := TOP + 1;
			WITH DISPLAY[TOP] DO
			  BEGIN FNAME := NIL; OCCUR := REC END
		      END
		    ELSE ERROR(250);
		    DISPL := 0; NEXTBIT := 0;
		    FIELDLIST(FSYS-[SEMICOLON]+[ENDSY],LSP1);
		    DISPL := DISPL + ORD(NEXTBIT > 0);
		    NEW(LSP,RECORDS);
		    WITH LSP^ DO
		      BEGIN FSTFLD := DISPLAY[TOP].FNAME;
			RECVAR := LSP1; SIZE := DISPL;
			FORM := RECORDS
		      END;
		    TOP := OLDTOP;
		    IF SY = ENDSY THEN INSYMBOL ELSE ERROR(13)
		  END
		ELSE
  (*SET*)         IF SY = SETSY THEN
		    BEGIN INSYMBOL;
		      IF SY = OFSY THEN INSYMBOL ELSE ERROR(8);
		      SIMPLETYPE(FSYS,LSP1,LSIZE);
		      IF LSP1 <> NIL THEN
			IF LSP1^.FORM > SUBRANGE THEN
			  BEGIN ERROR(115); LSP1 := NIL END
			ELSE
			  IF LSP1 = REALPTR THEN
			    BEGIN ERROR(114); LSP1 := NIL END;
		      NEW(LSP,POWER);
		      WITH LSP^ DO
			BEGIN ELSET := LSP1; FORM := POWER;
			  IF LSP1 <> NIL THEN
			    BEGIN GETBOUNDS(LSP1,LMIN,LMAX);
			      SIZE := (LMAX + BITSPERWD) DIV BITSPERWD
			    END
			  ELSE SIZE := 0
			END
		    END
		  ELSE
  (*FILE*)          IF SY = FILESY THEN
		      BEGIN INSYMBOL; NEW(LSP,FILES);
			WITH LSP^ DO
			  BEGIN FORM := FILES; FILTYPE := NIL END;
			IF SY = OFSY THEN
			  BEGIN INSYMBOL; TYP(FSYS,LSP1,LSIZE) END
			ELSE LSP1 := NIL;
			LSP^.FILTYPE := LSP1;
			IF LSP1 <> NIL THEN
			  LSP^.SIZE := FILESIZE + LSP1^.SIZE
			ELSE LSP^.SIZE := NILFILESIZE
		      END;
	      FSP := LSP
	    END;
	IF NOT (SY IN FSYS) THEN
	  BEGIN ERROR(6); SKIP(FSYS) END
      END
    ELSE FSP := NIL;
    IF FSP = NIL THEN FSIZE := 1 ELSE FSIZE := FSP^.SIZE
  END (*TYP*) ;

  PROCEDURE GENLDC(IVAL: INTEGER); FORWARD;

  PROCEDURE GENBYTE(FBYTE: INTEGER);
  BEGIN
    CODEP^[IC] := CHR(FBYTE); IC := IC+1
  END (*GENBYTE*) ;

  PROCEDURE GENWORD(FWORD: INTEGER);
  BEGIN
    IF ODD(IC) THEN IC := IC + 1;
    MOVELEFT(FWORD,CODEP^[IC],2);
    IC := IC + 2
  END (*GENWORD*) ;

  PROCEDURE GENBIG(IVAL: INTEGER);
    VAR LOWORDER: CHAR;
  BEGIN
    IF IVAL <= 127 THEN GENBYTE(IVAL)
    ELSE
      BEGIN MOVELEFT(IVAL,CODEP^[IC],2); LOWORDER := CODEP^[IC];
	CODEP^[IC] := CHR(ORD(CODEP^[IC+1])+128);
	CODEP^[IC+1] := LOWORDER; IC := IC+2
      END
  END (*GENBIG*) ;

  PROCEDURE GEN0(FOP: OPRANGE);
    VAR I: INTEGER;
  BEGIN
    GENBYTE(FOP+128);
    IF FOP = 38(*LCA*) THEN
      WITH GATTR.CVAL.VALP^ DO
	BEGIN GENBYTE(SLGTH);
	  FOR I := 1 TO SLGTH DO GENBYTE(ORD(SVAL[I]))
	END
  END (*GEN0*) ;

  PROCEDURE GEN1(FOP: OPRANGE; FP2: INTEGER);
    LABEL 1;
    VAR I,J: INTEGER;
  BEGIN
    GENBYTE(FOP+128);
    IF FOP = 51(*LDC*) THEN
      BEGIN
	IF FP2 = 2 THEN I := REALSIZE
	ELSE
	  BEGIN I := 8;
	    WHILE I > 0 DO
	      IF GATTR.CVAL.VALP^.CSTVAL[I] <> 0 THEN GOTO 1
	      ELSE I := I - 1;
      1:  END;
	GATTR.TYPTR^.SIZE := I;
	IF I > 1 THEN
	  BEGIN GENBYTE(I);
	    FOR J := I DOWNTO 1 DO GENWORD(GATTR.CVAL.VALP^.CSTVAL[J])
	  END
	ELSE
	  BEGIN IC := IC - 1;
	    IF I = 1 THEN GENLDC(GATTR.CVAL.VALP^.CSTVAL[1])
	  END
      END
    ELSE
      IF FOP IN [30(*CSP*),32(*ADJ*),45(*RNP*),
		 46(*CIP*),60(*LDM*),61(*STM*),
		 65(*RBP*),66(*CBP*),78(*CLP*),
		 42(*SAS*),79(*CGP*)] THEN GENBYTE(FP2)
      ELSE
	IF ((FOP = 74(*LDL*)) OR (FOP = 39(*LDO*)))
	    AND (FP2 <= 16) THEN
	  BEGIN IC := IC-1;
	    IF FOP = 39(*LDO*) THEN GENBYTE(231+FP2)
	    ELSE GENBYTE(215+FP2)
	  END
	ELSE
	  IF (FOP = 35(*IND*)) AND (FP2 <= 7) THEN
	    BEGIN IC := IC-1; GENBYTE(248+FP2) END
	  ELSE GENBIG(FP2)
  END (*GEN1*) ;

  PROCEDURE GEN2(FOP: OPRANGE; FP1,FP2: INTEGER);
  BEGIN
    IF (FOP = 64(*IXP*)) OR (FOP = 77(*CXP*)) THEN
      BEGIN GENBYTE(FOP+128); GENBYTE(FP1); GENBYTE(FP2);
      END
    ELSE
      IF FOP IN [47(*EQU*),48(*GEQ*),49(*GRT*),
		 52(*LEQ*),53(*LES*),55(*NEQ*)] THEN
	IF FP1 = 0 THEN GEN0(FOP+20)
	ELSE
	  BEGIN GEN1(FOP,FP1+FP1);
	    IF FP1 > 4 THEN GENBIG(FP2)
	  END
      ELSE
	BEGIN (*LDA,LOD,STR*)
	  IF FP1 = 0 THEN GEN1(FOP+20,FP2)
	  ELSE
	    BEGIN
	      GENBYTE(FOP+128); GENBYTE(FP1); GENBIG(FP2)
	    END
	END;
  END (*GEN2*) ;

  PROCEDURE GENLDC;
  BEGIN
    IF (IVAL >= 0) AND (IVAL <= 127) THEN GENBYTE(IVAL)
    ELSE
      BEGIN GENBYTE(51(*LDC*)+148);
	MOVELEFT(IVAL,CODEP^[IC],2);
	IC := IC+2
      END
  END (*GENLDC*) ;

  PROCEDURE GENJMP(FOP: OPRANGE; FLBP: LBP);
    VAR DISP: INTEGER;
  BEGIN
    WITH FLBP^ DO
      IF DEFINED THEN
	BEGIN
	  GENBYTE(FOP+128);
	  DISP := OCCURIC-IC-1;
	  IF (DISP >= 0) AND (DISP <= 127) THEN GENBYTE(DISP)
	  ELSE
	    BEGIN
	      IF JTABINX = 0 THEN
		BEGIN JTABINX := NEXTJTAB;
		  IF NEXTJTAB = MAXJTAB THEN ERROR(253)
		  ELSE NEXTJTAB := NEXTJTAB + 1;
		  JTAB[JTABINX] := OCCURIC
		END;
	      DISP := -JTABINX;
	      GENBYTE(248-JTABINX-JTABINX)
	    END;
	END
      ELSE
	BEGIN MOVELEFT(REFLIST,CODEP^[IC],2);
	  IF FOP = 57(*UJP*) THEN DISP := IC + 4096
	  ELSE DISP := IC;
	  REFLIST := DISP; IC := IC+2
	END;
  END (*GENJMP*) ;

  PROCEDURE LOAD; FORWARD;

  PROCEDURE GENFJP(FLBP: LBP);
  BEGIN LOAD;
    IF GATTR.TYPTR <> BOOLPTR THEN ERROR(135);
    GENJMP(33(*FJP*),FLBP)
  END (*GENFJP*) ;

  PROCEDURE GENLABEL(VAR FLBP: LBP);
  BEGIN NEW(FLBP);
    WITH FLBP^ DO
      BEGIN DEFINED := FALSE; REFLIST := MAXADDR END
  END (*GENLABEL*) ;

  PROCEDURE PUTLABEL(FLBP: LBP);
    VAR LREF: INTEGER; LOP: OPRANGE;
  BEGIN
    WITH FLBP^ DO
      BEGIN LREF := REFLIST;
	DEFINED := TRUE; OCCURIC := IC; JTABINX := 0;
	WHILE LREF < MAXADDR DO
	  BEGIN
	    IF LREF >= 4096 THEN
	      BEGIN LREF := LREF - 4096; LOP := 57(*UJP*) END
	    ELSE LOP := 33(*FJP*);
	    IC := LREF;
	    MOVELEFT(CODEP^[IC],LREF,2);
	    GENJMP(LOP,FLBP)
	  END;
	IC := OCCURIC
      END
  END (*PUTLABEL*) ;

  PROCEDURE LOAD;
  BEGIN
    WITH GATTR DO
      IF TYPTR <> NIL THEN
	BEGIN
	  CASE KIND OF
	    CST:   IF (TYPTR^.FORM = SCALAR) AND (TYPTR <> REALPTR) THEN
		     GENLDC(CVAL.IVAL)
		   ELSE
		     IF TYPTR = NILPTR THEN GEN0(31(*LDCN*))
		     ELSE
		       IF TYPTR = REALPTR THEN GEN1(51(*LDC*),2)
		       ELSE GEN1(51(*LDC*),5);
	    VARBL: CASE ACCESS OF
		     DRCT:   IF VLEVEL = 1 THEN GEN1(39(*LDO*),DPLMT)
			     ELSE GEN2(54(*LOD*),LEVEL-VLEVEL,DPLMT);
		     INDRCT: GEN1(35(*IND*),IDPLMT);
		     PACKD:  GEN0(58(*LDP*));
		     MULTI:  GEN1(60(*LDM*),TYPTR^.SIZE);
		     BYTE:   GEN0(62(*LDB*))
		   END;
	    EXPR:
	  END;
	  IF (TYPTR^.FORM = POWER) AND (KIND <> EXPR) THEN
	    GENLDC(TYPTR^.SIZE);
	  KIND := EXPR
	END
  END (*LOAD*) ;

  PROCEDURE STORE(VAR FATTR: ATTR);
  BEGIN
    WITH FATTR DO
      IF TYPTR <> NIL THEN
	CASE ACCESS OF
	  DRCT:   IF VLEVEL = 1 THEN GEN1(43(*SRO*),DPLMT)
		  ELSE GEN2(56(*STR*),LEVEL-VLEVEL,DPLMT);
	  INDRCT: IF IDPLMT <> 0 THEN ERROR(400)
		  ELSE GEN0(26(*STO*));
	  PACKD:  GEN0(59(*STP*));
	  MULTI:  GEN1(61(*STM*),TYPTR^.SIZE);
	  BYTE:   GEN0(63(*STB*))
	END
  END (*STORE*) ;

  PROCEDURE LOADADDRESS;
  BEGIN
    WITH GATTR DO
      IF TYPTR <> NIL THEN
	BEGIN
	  CASE KIND OF
	    CST:   IF STRGTYPE(TYPTR) THEN GEN0(38(*LCA*))
		   ELSE ERROR(400);
	    VARBL: CASE ACCESS OF
		     DRCT:   IF VLEVEL = 1 THEN GEN1(37(*LAO*),DPLMT)
			     ELSE GEN2(50(*LDA*),LEVEL-VLEVEL,DPLMT);
		     INDRCT: IF IDPLMT <> 0 THEN GEN1(34(*INC*),IDPLMT+IDPLMT);
		     PACKD:  ERROR(103)
		   END
	  END;
	  KIND := VARBL; ACCESS := INDRCT; IDPLMT := 0
	END
  END (*LOADADDRESS*) ;

  PROCEDURE WRITECODE(FORCEBUF: BOOLEAN);
    VAR CODEINX,LIC,I: INTEGER;
  BEGIN CODEINX := 0; LIC := IC;
    REPEAT
      I := 512-CURBYTE;
      IF I > LIC THEN I := LIC;
      MOVELEFT(CODEP^[CODEINX],DISKBUF[CURBYTE],I);
      CODEINX := CODEINX+I;
      CURBYTE := CURBYTE+I;
      IF (CURBYTE = 512) OR FORCEBUF THEN
	BEGIN
	  IF BLOCKWRITE(USERINFO.WORKCODE^,DISKBUF,1,CURBLK) <> 1 THEN
	    ERROR(402);
	  CURBLK := CURBLK+1; CURBYTE := 0
	END;
      LIC := LIC-I
    UNTIL LIC = 0;
  END (*WRITECODE*) ;

  PROCEDURE FINISHSEG;
    VAR I: INTEGER;
  BEGIN IC := 0;
    FOR I := NEXTPROC-1 DOWNTO 1 DO GENWORD(SEGINX+IC-PROCTABLE[I]);
    GENBYTE(SEG); GENBYTE(NEXTPROC-1);
    SEGTABLE[SEG].CODELENG := SEGINX+IC;
    WRITECODE(TRUE); SEGINX := 0; CODEINSEG := FALSE
  END (*FINISHSEG*) ;

========================================================================================
DOCUMENT :usus Folder:VOL17:comp.d.text
========================================================================================


  PROCEDURE EXPRESSION(FSYS: SETOFSYS); FORWARD;

  PROCEDURE SELECTOR(FSYS: SETOFSYS; FCP: CTP);
    VAR LATTR: ATTR; LCP: CTP; LMIN,LMAX: INTEGER;
  BEGIN
    WITH FCP^, GATTR DO
      BEGIN TYPTR := IDTYPE; KIND := VARBL;
	CASE KLASS OF
	  VARS:
	    IF VKIND = ACTUAL THEN
	      BEGIN ACCESS := DRCT; VLEVEL := VLEV;
		DPLMT := VADDR
	      END
	    ELSE
	      BEGIN
		IF VLEV = 1 THEN GEN1(39(*LDO*),VADDR)
		ELSE GEN2(54(*LOD*),LEVEL-VLEV,VADDR);
		ACCESS := INDRCT; IDPLMT := 0
	      END;
	  FIELD:
	    WITH DISPLAY[DISX] DO
	     BEGIN
	      IF OCCUR = CREC THEN
		BEGIN ACCESS := DRCT; VLEVEL := CLEV;
		  DPLMT := CDSPL + FLDADDR
		END
	      ELSE
		BEGIN
		  IF LEVEL = 1 THEN GEN1(39(*LDO*),VDSPL)
		  ELSE GEN2(54(*LOD*),0,VDSPL);
		  ACCESS := INDRCT; IDPLMT := FLDADDR
		END;
	      IF FISPACKD THEN
		BEGIN LOADADDRESS;
		  IF ((FLDRBIT = 0) OR (FLDRBIT = 8))
		        AND (FLDWIDTH = 8) THEN
		    BEGIN ACCESS := BYTE;
		      IF FLDRBIT = 8 THEN GEN1(34(*INC*),1)
		    END
		  ELSE
		    BEGIN ACCESS := PACKD;
		      GENLDC(FLDWIDTH); GENLDC(FLDRBIT)
		    END
		END
	     END;
	  FUNC:
	    IF PFDECKIND <> DECLARED THEN ERROR(150)
	    ELSE
	      IF NOT INSCOPE THEN ERROR(103)
	      ELSE
		  BEGIN ACCESS := DRCT; VLEVEL := PFLEV + 1;
		    DPLMT := LCAFTERMARKSTACK
		  END
	END (*CASE*);
	IF TYPTR <> NIL THEN
	  IF (TYPTR^.FORM <= POWER) AND
	     (TYPTR^.SIZE > PTRSIZE) THEN
	    BEGIN LOADADDRESS; ACCESS := MULTI END
      END (*WITH*);
    IF NOT (SY IN SELECTSYS + FSYS) THEN
      BEGIN ERROR(59); SKIP(SELECTSYS + FSYS) END;
    WHILE SY IN SELECTSYS DO
      BEGIN
  (*[*) IF SY = LBRACK THEN
	  BEGIN
	    REPEAT LATTR := GATTR;
	      WITH LATTR DO
		IF TYPTR <> NIL THEN
		  IF TYPTR^.FORM <> ARRAYS THEN
		    BEGIN ERROR(138); TYPTR := NIL END;
	      LOADADDRESS;
	      INSYMBOL; EXPRESSION(FSYS + [COMMA,RBRACK]);
	      LOAD;
	      IF GATTR.TYPTR <> NIL THEN
		IF GATTR.TYPTR^.FORM <> SCALAR THEN ERROR(113);
	      IF LATTR.TYPTR <> NIL THEN
		WITH LATTR.TYPTR^ DO
		  BEGIN
		    IF COMPTYPES(INXTYPE,GATTR.TYPTR) THEN
		      BEGIN
			IF (INXTYPE <> NIL) AND
			    NOT STRGTYPE(LATTR.TYPTR) THEN
			  BEGIN GETBOUNDS(INXTYPE,LMIN,LMAX);
			    IF RANGECHECK THEN
			      BEGIN GENLDC(LMIN); GENLDC(LMAX);
				GEN0(8(*CHK*))
			      END;
			    IF LMIN <> 0 THEN
			      BEGIN GENLDC(ABS(LMIN));
				IF LMIN > 0 THEN GEN0(21(*SBI*))
				ELSE GEN0(2(*ADI*))
			      END
			  END
		      END
		    ELSE ERROR(139);
		    WITH GATTR DO
		      BEGIN TYPTR := AELTYPE; KIND := VARBL;
			ACCESS := INDRCT; IDPLMT := 0;
			IF TYPTR <> NIL THEN
			  IF AISPACKD THEN
			    IF ELWIDTH = 8 THEN
			      BEGIN ACCESS := BYTE;
				IF STRGTYPE(LATTR.TYPTR) AND RANGECHECK THEN
				  GEN0(27(*IXS*))
				ELSE GEN0(2(*ADI*))
			      END
			    ELSE
			      BEGIN ACCESS := PACKD;
				GEN2(64(*IXP*),ELSPERWD,ELWIDTH)
			      END
			  ELSE
			    BEGIN GEN1(36(*IXA*),TYPTR^.SIZE);
			      IF (TYPTR^.FORM <= POWER) AND
				 (TYPTR^.SIZE > PTRSIZE) THEN
				ACCESS := MULTI
			    END
		      END
		  END
	    UNTIL SY <> COMMA;
	    IF SY = RBRACK THEN INSYMBOL ELSE ERROR(12)
	  END (*IF SY = LBRACK*)
	ELSE
  (*.*)   IF SY = PERIOD THEN
	    BEGIN
	      WITH GATTR DO
		BEGIN
		  IF TYPTR <> NIL THEN
		    IF TYPTR^.FORM <> RECORDS THEN
		      BEGIN ERROR(140); TYPTR := NIL END;
		  INSYMBOL;
		  IF SY = IDENT THEN
		    BEGIN
		      IF TYPTR <> NIL THEN
			BEGIN SEARCHSECTION(TYPTR^.FSTFLD,LCP);
			  IF LCP = NIL THEN
			    BEGIN ERROR(152); TYPTR := NIL END
			  ELSE
			    WITH LCP^ DO
			      BEGIN TYPTR := IDTYPE;
				CASE ACCESS OF
				  DRCT:   DPLMT := DPLMT + FLDADDR;
				  INDRCT: IDPLMT := IDPLMT + FLDADDR;
				  MULTI,BYTE,
				  PACKD:  ERROR(400)
				END (*CASE ACCESS*);
				IF FISPACKD THEN
				  BEGIN LOADADDRESS;
				    IF ((FLDRBIT = 0) OR (FLDRBIT = 8))
					AND (FLDWIDTH = 8) THEN
				      BEGIN ACCESS := BYTE;
					IF FLDRBIT = 8 THEN GEN1(34(*INC*),1)
				      END
				    ELSE
				      BEGIN ACCESS := PACKD;
					GENLDC(FLDWIDTH); GENLDC(FLDRBIT)
				      END
				  END;
				IF TYPTR <> NIL THEN
				  IF (TYPTR^.FORM <= POWER) AND
				     (TYPTR^.SIZE > PTRSIZE) THEN
				    BEGIN LOADADDRESS; ACCESS := MULTI END
			      END
			END;
		      INSYMBOL
		    END (*SY = IDENT*)
		  ELSE ERROR(2)
		END (*WITH GATTR*)
	    END (*IF SY = PERIOD*)
	  ELSE
  (*^*)     BEGIN
	      IF GATTR.TYPTR <> NIL THEN
		WITH GATTR,TYPTR^ DO
		  IF (FORM = POINTER) OR (FORM = FILES) THEN
		    BEGIN LOAD; KIND := VARBL;
		      ACCESS := INDRCT; IDPLMT := 0;
		      IF FORM = POINTER THEN TYPTR := ELTYPE
		      ELSE
			BEGIN TYPTR := FILTYPE;
			  IF TYPTR = NIL THEN ERROR(399)
			END;
		      IF TYPTR <> NIL THEN
			IF (TYPTR^.FORM <= POWER) AND
			   (TYPTR^.SIZE > PTRSIZE) THEN
				ACCESS := MULTI
		    END
		  ELSE ERROR(141);
	      INSYMBOL
	    END;
	IF NOT (SY IN FSYS + SELECTSYS) THEN
	  BEGIN ERROR(6); SKIP(FSYS + SELECTSYS) END
      END (*WHILE*)
  END (*SELECTOR*) ;

  PROCEDURE CALL(FSYS: SETOFSYS; FCP: CTP);
    VAR LKEY: 1..40; WASLPARENT: BOOLEAN;

    PROCEDURE VARIABLE(FSYS: SETOFSYS);
      VAR LCP: CTP;
    BEGIN
      IF SY = IDENT THEN
	BEGIN SEARCHID([FIELD,VARS],LCP); INSYMBOL END
      ELSE BEGIN ERROR(2); LCP := UVARPTR END;
      SELECTOR(FSYS,LCP)
    END (*VARIABLE*) ;

    PROCEDURE STRGVAR(FSYS: SETOFSYS; MUSTBEVAR: BOOLEAN);
    BEGIN EXPRESSION(FSYS);
      WITH GATTR DO
	IF ((KIND = CST) AND (TYPTR = CHARPTR))
	    OR STRGTYPE(TYPTR) THEN
	  IF KIND = VARBL THEN LOADADDRESS
	  ELSE
	    BEGIN
	      IF MUSTBEVAR THEN ERROR(154);
	      IF KIND = CST THEN
		BEGIN
		  IF TYPTR = CHARPTR THEN
		    BEGIN
		      WITH SCONST^ DO
			BEGIN CCLASS := STRG; SLGTH := 1;
			  SVAL[1] := CHR(CVAL.IVAL)
			END;
		      CVAL.VALP := SCONST;
		      NEW(TYPTR,ARRAYS,TRUE,TRUE);
		      TYPTR^ := STRGPTR^;
		      TYPTR^.MAXLENG := 1
		    END;
		  LOADADDRESS
		END
	    END
	ELSE
	  BEGIN
	    IF GATTR.TYPTR <> NIL THEN ERROR(125);
	    GATTR.TYPTR := STRGPTR
	  END
    END (*STRGVAR*) ;

    PROCEDURE NEWSTMT;
      LABEL 1;
      VAR LSP,LSP1: STP; VARTS,LMIN,LMAX: INTEGER;
	  LSIZE,LSZ: ADDRRANGE; LVAL: VALU;
    BEGIN VARIABLE(FSYS + [COMMA,RPARENT]); LOADADDRESS;
      LSP := NIL; VARTS := 0; LSIZE := 0;
      IF GATTR.TYPTR <> NIL THEN
	WITH GATTR.TYPTR^ DO
	  IF FORM = POINTER THEN
	    BEGIN
	      IF ELTYPE <> NIL THEN
		WITH ELTYPE^ DO
		  BEGIN LSIZE := SIZE;
		    IF FORM = RECORDS THEN LSP := RECVAR
		  END
	    END
	  ELSE ERROR(116);
      WHILE SY = COMMA DO
	BEGIN INSYMBOL;
	  CONSTANT(FSYS + [COMMA,RPARENT],LSP1,LVAL);
	  VARTS := VARTS + 1;
	  IF LSP = NIL THEN ERROR(158)
	  ELSE
	    IF LSP^.FORM <> TAGFLD THEN ERROR(162)
	    ELSE
	      IF LSP^.TAGFIELDP <> NIL THEN
		IF STRGTYPE(LSP1) OR (LSP1 = REALPTR) THEN ERROR(159)
		ELSE
		  IF COMPTYPES(LSP^.TAGFIELDP^.IDTYPE,LSP1) THEN
		    BEGIN
		      LSP1 := LSP^.FSTVAR;
		      WHILE LSP1 <> NIL DO
			WITH LSP1^ DO
			  IF VARVAL.IVAL = LVAL.IVAL THEN
			    BEGIN LSIZE := SIZE; LSP := SUBVAR;
			      GOTO 1
			    END
			  ELSE LSP1 := NXTVAR;
		      LSIZE := LSP^.SIZE; LSP := NIL;
		    END
		  ELSE ERROR(116);
    1:  END (*WHILE*) ;
      GENLDC(LSIZE);
      GEN1(30(*CSP*),1(*NEW*))
    END (*NEWSTMT*) ;

    PROCEDURE MOVE;
    BEGIN VARIABLE(FSYS + [COMMA]); LOADADDRESS;
      IF SY = COMMA THEN INSYMBOL ELSE ERROR(20);
      IF LKEY = 27 THEN
	BEGIN EXPRESSION(FSYS + [COMMA]); LOAD END
      ELSE
	BEGIN VARIABLE(FSYS + [COMMA]); LOADADDRESS END;
      IF SY = COMMA THEN INSYMBOL ELSE ERROR(20);
      EXPRESSION(FSYS + [RPARENT]); LOAD;
      IF LKEY = 27 THEN GEN1(30(*CSP*),10(*FLC*))
      ELSE
	IF LKEY = 21 THEN GEN1(30(*CSP*),2(*MVL*))
	ELSE GEN1(30(*CSP*),3(*MVR*))
    END (*MOVE*) ;

    PROCEDURE EXIT;
      VAR LCP: CTP;
    BEGIN
      IF SY = IDENT THEN
	BEGIN SEARCHID([PROC,FUNC],LCP); INSYMBOL END
      ELSE
	IF (SY = PROGSY) THEN
	  BEGIN LCP := OUTERBLOCK; INSYMBOL END
	ELSE LCP := NIL;
      IF LCP <> NIL THEN
	IF LCP^.PFDECKIND = DECLARED THEN
	  BEGIN GENLDC(LCP^.PFSEG); GENLDC(LCP^.PFNAME) END
	ELSE ERROR(125)
      ELSE ERROR(125);
      GEN1(30(*CSP*),4(*XIT*))
    END (*EXIT*) ;

    PROCEDURE UNITIO;
    BEGIN
      IF GATTR.TYPTR <> INTPTR THEN ERROR(125);
      IF SY = COMMA THEN INSYMBOL ELSE ERROR(20);
      VARIABLE(FSYS + [COMMA]); LOADADDRESS;
      IF SY = COMMA THEN INSYMBOL ELSE ERROR(20);
      EXPRESSION(FSYS + [COMMA,RPARENT]); LOAD;
      IF GATTR.TYPTR <> INTPTR THEN ERROR(125);
      IF SY = COMMA THEN
	BEGIN INSYMBOL;
	  IF SY = COMMA THEN GENLDC(0)
	  ELSE
	    BEGIN
	      EXPRESSION(FSYS + [COMMA,RPARENT]); LOAD;
	      IF GATTR.TYPTR <> INTPTR THEN ERROR(125)
	    END
	END
      ELSE GENLDC(0);
      IF SY = COMMA THEN
	BEGIN INSYMBOL;
	  EXPRESSION(FSYS + [RPARENT]); LOAD;
	  IF GATTR.TYPTR <> BOOLPTR THEN ERROR(135)
	END
      ELSE GENLDC(0);
      IF LKEY = 13 THEN GEN1(30(*CSP*),5(*URD*))
      ELSE GEN1(30(*CSP*),6(*UWT*))
    END (*UNITIO*);

    PROCEDURE CONCAT;
      VAR LLC: ADDRRANGE; TEMPLGTH: INTEGER;
    BEGIN TEMPLGTH := 0;
      LLC := LC; LC := LC + (STRGLGTH DIV CHRSPERWD) + 1;
      GENLDC(0); GEN2(56(*STR*),0,LLC);
      GEN2(50(*LDA*),0,LLC);
      REPEAT
	STRGVAR(FSYS + [COMMA,RPARENT],FALSE);
	TEMPLGTH := TEMPLGTH + GATTR.TYPTR^.MAXLENG;
	IF TEMPLGTH < STRGLGTH THEN GENLDC(TEMPLGTH)
	ELSE GENLDC(STRGLGTH);
	GEN2(77(*CXP*),0(*SYS*),23(*SCONCAT*));
	GEN2(50(*LDA*),0,LLC);
	TEST := SY <> COMMA;
	IF NOT TEST THEN INSYMBOL
      UNTIL TEST;
      IF TEMPLGTH < STRGLGTH THEN
	LC := LLC + (TEMPLGTH DIV CHRSPERWD) + 1
      ELSE TEMPLGTH := STRGLGTH;
      IF LC > LCMAX THEN LCMAX := LC;
      LC := LLC;
      WITH GATTR DO
	BEGIN NEW(TYPTR,ARRAYS,TRUE,TRUE);
	  TYPTR^ := STRGPTR^;
	  TYPTR^.MAXLENG := TEMPLGTH
	END
    END (*CONCAT*) ;

    PROCEDURE COPYDELETE;
      VAR LLC: ADDRRANGE; LSP: STP;
    BEGIN
      IF LKEY = 19 THEN
	BEGIN LLC := LC;
	  LC := LC + (STRGLGTH DIV CHRSPERWD) + 1;
	END;
      STRGVAR(FSYS + [COMMA], LKEY = 18);
      IF LKEY = 19 THEN
	BEGIN LSP := GATTR.TYPTR;
	  GEN2(50(*LDA*),0,LLC)
	END;
      IF SY = COMMA THEN INSYMBOL ELSE ERROR(20);
      EXPRESSION(FSYS + [COMMA]); LOAD;
      IF GATTR.TYPTR <> NIL THEN
	IF GATTR.TYPTR <> INTPTR THEN ERROR(125);
      IF SY = COMMA THEN INSYMBOL ELSE ERROR(20);
      EXPRESSION(FSYS + [RPARENT]); LOAD;
      IF GATTR.TYPTR <> NIL THEN
	IF GATTR.TYPTR <> INTPTR THEN ERROR(125);
      IF LKEY = 19 THEN
	BEGIN
	  GEN2(77(*CXP*),0(*SYS*),25(*SCOPY*));
	  GEN2(50(*LDA*),0,LLC);
	  IF LSP^.MAXLENG < STRGLGTH THEN
	    LC := LLC + (LSP^.MAXLENG DIV CHRSPERWD) + 1;
	  IF LC > LCMAX THEN LCMAX := LC;
	  LC := LLC; GATTR.TYPTR := LSP
	END
      ELSE GEN2(77(*CXP*),0(*SYS*),26(*SDELETE*))
    END (*COPYDELETE*) ;

    PROCEDURE CLOSE;
    BEGIN
      VARIABLE(FSYS + [COMMA,RPARENT]); LOADADDRESS;
      IF GATTR.TYPTR <> NIL THEN
	IF GATTR.TYPTR^.FORM <> FILES THEN ERROR(125);
      IF SY = COMMA THEN
	BEGIN INSYMBOL;
	  IF SY = IDENT THEN
	   BEGIN
	    IF ID = 'NORMAL  ' THEN GENLDC(0)
	    ELSE
	      IF ID = 'LOCK    ' THEN GENLDC(1)
	      ELSE
		IF ID = 'PURGE   ' THEN GENLDC(2)
		ELSE
		  IF ID = 'CRUNCH  ' THEN GENLDC(3)
		  ELSE ERROR(2);
	    INSYMBOL
	   END
	  ELSE ERROR(2)
	END
      ELSE GENLDC(0);
      GEN2(77(*CXP*),0(*SYS*),6(*FCLOSE*));
      IF IOCHECK THEN GEN1(30(*CSP*),0(*IOC*))
    END (*CLOSE*) ;

    PROCEDURE GETPUTETC;
    BEGIN
      VARIABLE(FSYS + [COMMA,RPARENT]); LOADADDRESS;
      IF GATTR.TYPTR <> NIL THEN
	IF GATTR.TYPTR^.FORM <> FILES THEN ERROR(125);
      CASE LKEY OF
	32:  BEGIN
		IF SY = COMMA THEN
		  BEGIN
		    INSYMBOL; EXPRESSION(FSYS + [RPARENT]); LOAD;
		    IF GATTR.TYPTR <> INTPTR THEN ERROR(125)
		  END
		ELSE ERROR(125);
		GEN2(77(*CXP*),0(*SYS*),9(*FSEEK*))
	     END;
	33:  GEN2(77(*CXP*),0(*SYS*),4(*FRESET*));
	34:  GEN2(77(*CXP*),0(*SYS*),7(*FGET*));
	35:  GEN2(77(*CXP*),0(*SYS*),8(*FPUT*));
	40:  BEGIN
		IF GATTR.TYPTR <> NIL THEN
		  IF GATTR.TYPTR^.FILTYPE <> CHARPTR THEN ERROR(399);
		GENLDC(12); GENLDC(0);
		GEN2(77(*CXP*),0(*SYS*),17(*WRC*))
	     END
      END (*CASE*) ;
      IF IOCHECK THEN GEN1(30(*CSP*),0(*IOC*))
    END (*GETPUTETC*) ;

    PROCEDURE SCAN;
    BEGIN
      IF GATTR.TYPTR <> NIL THEN
	IF GATTR.TYPTR <> INTPTR THEN ERROR(125);
      IF SY = COMMA THEN INSYMBOL ELSE ERROR(20);
      IF SY = RELOP THEN
	BEGIN
	  IF OP = EQOP THEN GENLDC(0)
	  ELSE
	    IF OP = NEOP THEN GENLDC(1)
	    ELSE ERROR(125);
	  INSYMBOL
	END
      ELSE ERROR(125);
      EXPRESSION(FSYS + [COMMA]); LOAD;
      IF GATTR.TYPTR <> NIL THEN
	IF GATTR.TYPTR <> CHARPTR THEN ERROR(125);
      IF SY = COMMA THEN INSYMBOL ELSE ERROR(20);
      VARIABLE(FSYS + [COMMA,RPARENT]); LOADADDRESS;
      IF SY = COMMA THEN
	BEGIN INSYMBOL;
	  EXPRESSION(FSYS + [RPARENT]); LOAD
	END
      ELSE GENLDC(0);
      GEN1(30(*CSP*),11(*SCN*));
      GATTR.TYPTR := INTPTR
    END (*SCAN*) ;

    PROCEDURE BLOCKIO;
    BEGIN
      VARIABLE(FSYS + [COMMA]); LOADADDRESS;
      IF GATTR.TYPTR <> NIL THEN
	IF GATTR.TYPTR^.FORM <> FILES THEN ERROR(125)
	ELSE
	  IF GATTR.TYPTR^.FILTYPE <> NIL THEN ERROR(399);
      IF SY = COMMA THEN INSYMBOL ELSE ERROR(20);
      VARIABLE(FSYS + [COMMA]); LOADADDRESS;
      IF SY = COMMA THEN INSYMBOL ELSE ERROR(20);
      EXPRESSION(FSYS + [COMMA,RPARENT]); LOAD;
      IF GATTR.TYPTR <> INTPTR THEN ERROR(125);
      IF SY = COMMA THEN
	BEGIN INSYMBOL;
	  EXPRESSION(FSYS + [RPARENT]); LOAD;
	  IF GATTR.TYPTR <> INTPTR THEN ERROR(125)
	END
      ELSE GENLDC(-1);
      IF LKEY = 37 THEN GENLDC(1) ELSE GENLDC(0);
      GENLDC(0); GENLDC(0);
      GEN2(77(*CXP*),0(*SYS*),28(*BLOCKIO*));
      IF IOCHECK THEN GEN1(30(*CSP*),0(*IOC*));
      GATTR.TYPTR := INTPTR
    END (*BLOCKIO*) ;

    PROCEDURE DRAWSTUFF;
      VAR I,N: INTEGER;
    BEGIN
      VARIABLE(FSYS + [COMMA]); LOADADDRESS;
      IF SY = COMMA THEN INSYMBOL ELSE ERROR(20);
      VARIABLE(FSYS + [COMMA]); LOADADDRESS;
      IF LKEY = 42 THEN N := 6
      ELSE N := 5;
      FOR I := 0 TO N DO
	BEGIN
	  IF SY = COMMA THEN INSYMBOL ELSE ERROR(20);
	  EXPRESSION(FSYS + [COMMA,RPARENT]); LOAD;
	  IF GATTR.TYPTR <> NIL THEN
	    IF GATTR.TYPTR <> INTPTR THEN ERROR(125)
	END;
      IF LKEY = 42 THEN N := 13
      ELSE N := 12;
      GEN1(30(*CSP*),N)
    END (*DRAWSTUFF*) ;

    PROCEDURE SIZEOF;
      VAR LCP: CTP;
    BEGIN
      IF SY = IDENT THEN
	BEGIN SEARCHID([TYPES,VARS,FIELD],LCP); INSYMBOL;
	  IF LCP^.IDTYPE <> NIL THEN
	    GENLDC(LCP^.IDTYPE^.SIZE*CHRSPERWD)
	END;
      GATTR.TYPTR := INTPTR
    END (*SIZEOF*) ;


    PROCEDURE LOADIDADDR(FCP: CTP);
    BEGIN
	WITH FCP^ DO
	  IF VKIND = ACTUAL THEN
	    IF VLEV = 1 THEN GEN1(37(*LAO*),VADDR)
	    ELSE GEN2(50(*LDA*),LEVEL-VLEV,VADDR)
	  ELSE
	    IF VLEV = 1 THEN GEN1(39(*LDO*),VADDR)
	    ELSE GEN2(54(*LOD*),LEVEL-VLEV,VADDR)
    END (*LOADIDADDR*) ;

    PROCEDURE READ;
      VAR FILEPTR,LCP: CTP;
    BEGIN FILEPTR := INPUTPTR;
      IF (SY = IDENT) AND WASLPARENT THEN
	BEGIN SEARCHID([FIELD,VARS],LCP);
	  IF LCP^.IDTYPE <> NIL THEN
	    IF LCP^.IDTYPE^.FORM = FILES THEN
	      IF LCP^.IDTYPE^.FILTYPE = CHARPTR THEN
		BEGIN INSYMBOL; FILEPTR := LCP;
		  IF NOT (SY IN [COMMA,RPARENT]) THEN ERROR(20);
		  IF SY = COMMA THEN INSYMBOL
		END
	END
      ELSE
	IF WASLPARENT THEN ERROR(2);
      IF (SY = IDENT) AND WASLPARENT THEN
	BEGIN
	  REPEAT LOADIDADDR(FILEPTR);
	    VARIABLE(FSYS + [COMMA,RPARENT]); LOADADDRESS;
	    IF GATTR.TYPTR <> NIL THEN
	      IF COMPTYPES(INTPTR,GATTR.TYPTR) THEN
		GEN2(77(*CXP*),0(*SYS*),12(*FRDI*))
	      ELSE
		IF COMPTYPES(REALPTR,GATTR.TYPTR) THEN
		  GEN2(77(*CXP*),0(*SYS*),14(*FRDR*))
		ELSE
		  IF COMPTYPES(CHARPTR,GATTR.TYPTR) THEN
		    GEN2(77(*CXP*),0(*SYS*),16(*FRDC*))
		  ELSE
		    IF STRGTYPE(GATTR.TYPTR) THEN
		      BEGIN GENLDC(GATTR.TYPTR^.MAXLENG);
			GEN2(77(*CXP*),0(*SYS*),18(*FRDS*))
		      END
		    ELSE ERROR(125);
	    IF IOCHECK THEN GEN1(30(*CSP*),0(*IOC*));
	    TEST := SY <> COMMA;
	    IF NOT TEST THEN INSYMBOL
	  UNTIL TEST
	END;
      IF LKEY = 2 THEN
	BEGIN LOADIDADDR(FILEPTR);
	  GEN2(77(*CXP*),0(*SYS*),21(*FRLN*));
	  IF IOCHECK THEN GEN1(30(*CSP*),0(*IOC*))
	END
    END (*READ*) ;

    PROCEDURE WRITE;
      VAR LSP: STP; DEFAULT: BOOLEAN;
	  FILEPTR,LCP: CTP; LEN,LMIN,LMAX: INTEGER;
    BEGIN FILEPTR := OUTPUTPTR;
      IF (SY = IDENT) AND WASLPARENT THEN
	BEGIN SEARCHID([FIELD,VARS,KONST,FUNC],LCP);
	  IF LCP^.IDTYPE <> NIL THEN
	    IF LCP^.IDTYPE^.FORM = FILES THEN
	      IF LCP^.IDTYPE^.FILTYPE = CHARPTR THEN
		BEGIN INSYMBOL; FILEPTR := LCP;
		  IF NOT (SY IN [COMMA,RPARENT]) THEN ERROR(20);
		  IF SY = COMMA THEN INSYMBOL
		END
	END;
      IF (SY IN FACBEGSYS) AND WASLPARENT THEN
	BEGIN
	  REPEAT LOADIDADDR(FILEPTR);
	    EXPRESSION(FSYS + [COMMA,COLON,RPARENT]);
	    LSP := GATTR.TYPTR;
	    IF LSP <> NIL THEN
	      IF LSP^.FORM <= SUBRANGE THEN LOAD
	      ELSE LOADADDRESS;
	    IF SY = COLON THEN
	      BEGIN INSYMBOL;
		EXPRESSION(FSYS + [COMMA,COLON,RPARENT]);
		IF GATTR.TYPTR <> NIL THEN
		  IF GATTR.TYPTR <> INTPTR THEN ERROR(20);
		LOAD; DEFAULT := FALSE
	      END
	    ELSE DEFAULT := TRUE;
	    IF LSP = INTPTR THEN
	      BEGIN IF DEFAULT THEN GENLDC(0);
		GEN2(77(*CXP*),0(*SYS*),13(*FWRI*))
	      END
	    ELSE
	      IF LSP = REALPTR THEN
		BEGIN IF DEFAULT THEN GENLDC(0);
		  IF SY = COLON THEN
		    BEGIN INSYMBOL;
		      EXPRESSION(FSYS + [COMMA,RPARENT]); LOAD;
		      IF GATTR.TYPTR <> NIL THEN
			IF GATTR.TYPTR <> INTPTR THEN ERROR(125)
		    END
		  ELSE GENLDC(0);
		  GEN2(77(*CXP*),0(*SYS*),15(*FWRR*))
		END
	      ELSE
		IF LSP = CHARPTR THEN
		  BEGIN IF DEFAULT THEN GENLDC(0);
		    GEN2(77(*CXP*),0(*SYS*),17(*FWRC*))
		  END
		ELSE
		  IF STRGTYPE(LSP) THEN
		    BEGIN IF DEFAULT THEN GENLDC(0);
		      GEN2(77(*CXP*),0(*SYS*),19(*FWRS*))
		    END
		  ELSE
		    IF PAOFCHAR(LSP) THEN
		      BEGIN LMAX := 0;
			IF LSP^.INXTYPE <> NIL THEN
			  BEGIN GETBOUNDS(LSP^.INXTYPE,LMIN,LMAX);
			     LMAX := LMAX - LMIN + 1
			  END;
			IF DEFAULT THEN GENLDC(LMAX);
			GENLDC(LMAX);
			GEN2(77(*CXP*),0(*SYS*),20(*FWRB*))
		      END
		    ELSE ERROR(125);
	    IF IOCHECK THEN GEN1(30(*CSP*),0(*IOC*));
	    TEST := SY <> COMMA;
	    IF NOT TEST THEN INSYMBOL
	  UNTIL TEST;
	END;
      IF LKEY = 4 THEN (*WRITELN*)
	BEGIN LOADIDADDR(FILEPTR);
	  GEN2(77(*CXP*),0(*SYS*),22(*FWLN*));
	  IF IOCHECK THEN GEN1(30(*CSP*),0(*IOC*))
	END
    END (*WRITE*) ;

    PROCEDURE CALLNONSPECIAL;
      VAR NXT,LCP: CTP; LSP: STP; LB: BOOLEAN;
	  LMIN,LMAX: INTEGER;
    BEGIN
      WITH FCP^ DO
	BEGIN NXT := NEXT;
	  IF PFDECKIND = DECLARED THEN
	    IF PFKIND <> ACTUAL THEN ERROR(400)
	END;
      IF SY = LPARENT THEN
	BEGIN
	  REPEAT
	    IF NXT = NIL THEN ERROR(126);
	    INSYMBOL;
	    EXPRESSION(FSYS + [COMMA,RPARENT]);
	    IF (GATTR.TYPTR <> NIL) AND (NXT <> NIL) THEN
	      BEGIN LSP := NXT^.IDTYPE;
		IF LSP <> NIL THEN
		  BEGIN
		    IF NXT^.VKIND = ACTUAL THEN
		      IF GATTR.TYPTR^.FORM <= POWER THEN
			BEGIN LB := (GATTR.TYPTR = CHARPTR)
				    AND (GATTR.KIND = CST);
			  LOAD;
			  IF LSP^.FORM = POWER THEN
			    GEN1(32(*ADJ*),LSP^.SIZE)
			  ELSE
			  IF (LSP^.FORM = SUBRANGE)
				AND RANGECHECK THEN
			    BEGIN GENLDC(LSP^.MIN.IVAL);
			      GENLDC(LSP^.MAX.IVAL);
			      GEN0(8(*CHK*))
			    END
			  ELSE
			  IF (GATTR.TYPTR = INTPTR) AND
				COMPTYPES(LSP,REALPTR) THEN
			    BEGIN GEN0(10(*FLT*));
			      GATTR.TYPTR := REALPTR
			    END
			  ELSE
			  IF LB AND STRGTYPE(LSP) THEN
			    GATTR.TYPTR := STRGPTR
			END
		      ELSE (*FORM > POWER*)
			BEGIN LB := STRGTYPE(GATTR.TYPTR)
				    AND (GATTR.KIND = CST);
			  LOADADDRESS;
			  IF LB AND PAOFCHAR(LSP) THEN
			    IF NOT LSP^.AISSTRNG THEN
			      BEGIN GEN0(80(*S1P*));
				IF LSP^.INXTYPE <> NIL THEN
				  BEGIN
				    GETBOUNDS(LSP^.INXTYPE,LMIN,LMAX);
				    IF LMAX-LMIN+1 <> 
					GATTR.TYPTR^.MAXLENG THEN ERROR(142);
				  END;
				GATTR.TYPTR := LSP
			      END
			END
		    ELSE (*VKIND = FORMAL*)
		      IF GATTR.KIND = VARBL THEN
			BEGIN LOADADDRESS;
			  IF (LSP^.FORM=POWER) THEN
			    IF GATTR.TYPTR^.SIZE <>
				LSP^.SIZE THEN ERROR(142)
			END
		      ELSE ERROR(154);
		    IF NOT COMPTYPES(LSP,GATTR.TYPTR) THEN ERROR(142)
		  END
	      END;
	    IF NXT <> NIL THEN NXT := NXT^.NEXT
	  UNTIL SY <> COMMA;
	  IF SY = RPARENT THEN INSYMBOL ELSE ERROR(4)
	END (*LPARENT*) ;
      IF NXT <> NIL THEN ERROR(126);
      WITH FCP^ DO
	IF PFDECKIND = DECLARED THEN
	  BEGIN
	    IF KLASS = FUNC THEN
	      BEGIN GENLDC(0); GENLDC(0) END;
	    IF PFSEG <> SEG THEN GEN2(77(*CXP*),PFSEG,PFNAME)
	    ELSE
	      IF PFLEV = 0 THEN GEN1(66(*CBP*),PFNAME)
	      ELSE
		IF PFLEV = LEVEL THEN GEN1(78(*CLP*),PFNAME)
		ELSE
	  	IF PFLEV = 1 THEN GEN1(79(*CGP*),PFNAME)
	  	ELSE GEN1(46(*CIP*),PFNAME)
	  END
	ELSE
	  IF (CSPNUM <> 21) AND (CSPNUM <> 22) THEN
	    GEN1(30(*CSP*),CSPNUM);
      GATTR.TYPTR := FCP^.IDTYPE
    END (*CALLNONSPECIAL*) ;

  BEGIN (*CALL*)
    IF FCP^.PFDECKIND = SPECIAL THEN
      BEGIN WASLPARENT := TRUE; LKEY := FCP^.KEY;
	IF SY = LPARENT THEN INSYMBOL
	ELSE
	  IF LKEY IN [2,4,5,6] THEN WASLPARENT := FALSE
	  ELSE ERROR(9);
	IF LKEY IN [7,8,9,10,11,13,14,25,36] THEN
	  BEGIN EXPRESSION(FSYS + [COMMA,RPARENT]); LOAD END;
	CASE LKEY OF
	   1,2: READ;
	   3,4: WRITE;
	   5,6: BEGIN (*EOF & EOLN*)
		  IF WASLPARENT THEN
		    BEGIN VARIABLE(FSYS + [RPARENT]); LOADADDRESS;
		      IF GATTR.TYPTR <> NIL THEN
		        IF GATTR.TYPTR^.FORM <> FILES THEN ERROR(125)
		        ELSE
		          IF (GATTR.TYPTR^.FILTYPE <> CHARPTR) AND
			      (LKEY = 6) THEN ERROR(399)
		    END
		  ELSE
		    LOADIDADDR(INPUTPTR);
		  GENLDC(0); GENLDC(0);
		  IF LKEY = 5 THEN GEN2(77(*CXP*),0(*SYS*),10(*FEOF*))
		  ELSE GEN2(77(*CXP*),0(*SYS*),11(*FEOLN*));
		  GATTR.TYPTR := BOOLPTR
		END (*EOF*) ;
	   7,8: BEGIN GENLDC(1); (*PREDSUCC*)
		  IF GATTR.TYPTR <> NIL THEN
		    IF GATTR.TYPTR^.FORM = SCALAR THEN
		      IF LKEY = 8 THEN GEN0(2(*ADI*))
		      ELSE GEN0(21(*SBI*))
		    ELSE ERROR(115)
		END (*PREDSUCC*) ;
	     9: BEGIN (*ORD*)
		  IF GATTR.TYPTR <> NIL THEN
		    IF GATTR.TYPTR^.FORM >= POWER THEN ERROR(125);
		  GATTR.TYPTR := INTPTR
		END (*ORD*) ;
	    10: BEGIN (*SQR*)
		  IF GATTR.TYPTR <> NIL THEN
		    IF GATTR.TYPTR = INTPTR THEN GEN0(24(*SQI*))
		    ELSE
		      IF GATTR.TYPTR = REALPTR THEN GEN0(25(*SQR*))
		      ELSE BEGIN ERROR(125); GATTR.TYPTR := INTPTR END
		END (*SQR*) ;
	    11: BEGIN (*ABS*)
		  IF GATTR.TYPTR <> NIL THEN
		    IF GATTR.TYPTR = INTPTR THEN GEN0(0(*ABI*))
		    ELSE
		      IF GATTR.TYPTR = REALPTR THEN GEN0(1(*ABR*))
		      ELSE BEGIN ERROR(125); GATTR.TYPTR := INTPTR END
		END (*ABS*) ;
	    12: NEWSTMT;
	 13,14: UNITIO;
	    15: CONCAT;
	    16: BEGIN (*LENGTH*)
		  STRGVAR(FSYS + [RPARENT],FALSE);
		  GEN0(62(*LDB*)); GATTR.TYPTR := INTPTR
		END (*LENGTH*) ;
	    17: BEGIN (*INSERT*)
		  STRGVAR(FSYS + [COMMA],FALSE);
		  IF SY = COMMA THEN INSYMBOL ELSE ERROR(20);
		  STRGVAR(FSYS + [COMMA],TRUE);
		  GENLDC(GATTR.TYPTR^.MAXLENG);
		  IF SY = COMMA THEN INSYMBOL ELSE ERROR(20);
		  EXPRESSION(FSYS + [RPARENT]); LOAD;
		  IF GATTR.TYPTR <> NIL THEN
		    IF GATTR.TYPTR <> INTPTR THEN ERROR(125);
		  GEN2(77(*CXP*),0(*SYS*),24(*SINSERT*))
		END (*INSERT*) ;
	 18,19: COPYDELETE;
	    20: BEGIN (*POS*)
		  STRGVAR(FSYS + [COMMA],FALSE);
		  IF SY = COMMA THEN INSYMBOL ELSE ERROR(20);
		  STRGVAR(FSYS + [RPARENT],FALSE);
		  GENLDC(0); GENLDC(0);
		  GEN2(77(*CXP*),0(*SYS*),27(*SPOS*));
		  GATTR.TYPTR := INTPTR
		END (*POS*) ;
      27,21,22: MOVE;
	    23: EXIT;
	    24: BEGIN (*IDSEARCH*)
		  VARIABLE(FSYS + [COMMA]); LOADADDRESS;
		  IF SY = COMMA THEN INSYMBOL ELSE ERROR(20);
		  VARIABLE(FSYS + [RPARENT]); LOADADDRESS;
		  GEN1(30(*CSP*),7(*IDS*))
		END (*IDSEARCH*) ;
	    25: BEGIN (*TREESEARCH*)
		  IF SY = COMMA THEN INSYMBOL ELSE ERROR(20);
		  VARIABLE(FSYS + [COMMA]); LOADADDRESS;
		  IF SY = COMMA THEN INSYMBOL ELSE ERROR(20);
		  VARIABLE(FSYS + [RPARENT]); LOADADDRESS;
		  GATTR.TYPTR := INTPTR;
		  GEN1(30(*CSP*),8(*TRS*))
		END (*TREESEARCH*) ;
	    26: BEGIN (*TIME*)
		  VARIABLE(FSYS + [COMMA]); LOADADDRESS;
		  IF GATTR.TYPTR <> NIL THEN
		    IF GATTR.TYPTR <> INTPTR THEN ERROR(125);
		  IF SY = COMMA THEN INSYMBOL ELSE ERROR(20);
		  VARIABLE(FSYS + [RPARENT]); LOADADDRESS;
		  IF GATTR.TYPTR <> NIL THEN
		    IF GATTR.TYPTR <> INTPTR THEN ERROR(125);
		  GEN1(30(*CSP*),9(*TIM*))
		END (*TIME*) ;
      28,29,30: BEGIN (*OPEN*)
		  VARIABLE(FSYS + [COMMA]); LOADADDRESS;
		  IF GATTR.TYPTR <> NIL THEN
		    IF GATTR.TYPTR^.FORM <> FILES THEN ERROR(125);
		  IF SY = COMMA THEN INSYMBOL ELSE ERROR(20);
		  STRGVAR(FSYS + [RPARENT],FALSE);
		  IF LKEY = 28 THEN GENLDC(0)
		  ELSE GENLDC(1);
		  GENLDC(0); GEN2(77(*CXP*),0(*SYS*),5(*FOPEN*));
		  IF IOCHECK THEN GEN1(30(*CSP*),0(*IOC*))
		END (*OPEN*) ;
	    31: CLOSE;
32,33,34,35,40: GETPUTETC;
	    36: SCAN;
	 37,38: BLOCKIO;
	 39,42: DRAWSTUFF;
	    41: SIZEOF
	END (*SPECIAL CASES*) ;
	IF WASLPARENT THEN
	  IF SY = RPARENT THEN INSYMBOL ELSE ERROR(4)
      END (*SPECIAL PROCEDURES AND FUNCTIONS*)
    ELSE CALLNONSPECIAL
  END (*CALL*) ;

========================================================================================
DOCUMENT :usus Folder:VOL17:comp.e.text
========================================================================================


  PROCEDURE EXPRESSION;
    VAR LATTR: ATTR; LOP: OPERATOR; TYPIND: INTEGER;
	LSIZE: ADDRRANGE; LSTRING,GSTRING: BOOLEAN;
	LMIN,LMAX: INTEGER;

    PROCEDURE FLOATIT(VAR FSP: STP);
    BEGIN
      IF GATTR.TYPTR = INTPTR THEN
	BEGIN GEN0(10(*FLT*)); GATTR.TYPTR := REALPTR END;
      IF FSP = INTPTR THEN
	BEGIN GEN0(9(*FLO*)); FSP := REALPTR END
    END (*FLOATIT*) ;

    PROCEDURE SIMPLEEXPRESSION(FSYS: SETOFSYS);
      VAR LATTR: ATTR; LOP: OPERATOR; SIGNED: BOOLEAN;

      PROCEDURE TERM(FSYS: SETOFSYS);
	VAR LATTR: ATTR; LOP: OPERATOR;

	PROCEDURE FACTOR(FSYS: SETOFSYS);
	  VAR LCP: CTP; LVP: CSP; VARPART,ALLCONST: BOOLEAN;
	      LSP: STP; HIGHVAL,LOWVAL,LIC,LOP: INTEGER;
	      CSTPART: SET OF 0..127;
	BEGIN
	  IF NOT (SY IN FACBEGSYS) THEN
	    BEGIN ERROR(58); SKIP(FSYS + FACBEGSYS);
	      GATTR.TYPTR := NIL
	    END;
	  WHILE SY IN FACBEGSYS DO
	    BEGIN
	      CASE SY OF
	(*ID*)  IDENT:
		  BEGIN SEARCHID([KONST,VARS,FIELD,FUNC],LCP); INSYMBOL;
		    IF LCP^.KLASS = FUNC THEN
		      BEGIN CALL(FSYS,LCP); GATTR.KIND := EXPR END
		    ELSE
		      IF LCP^.KLASS = KONST THEN
			WITH GATTR, LCP^ DO
			  BEGIN TYPTR := IDTYPE; KIND := CST;
			    CVAL := VALUES
			  END
		      ELSE SELECTOR(FSYS,LCP);
		    IF GATTR.TYPTR <> NIL THEN
		      WITH GATTR,TYPTR^ DO
			IF FORM = SUBRANGE THEN TYPTR := RANGETYPE
		  END;
	(*CST*) INTCONST:
		  BEGIN
		    WITH GATTR DO
		      BEGIN TYPTR := INTPTR; KIND := CST;
			CVAL := VAL
		      END;
		    INSYMBOL
		  END;
		REALCONST:
		  BEGIN
		    WITH GATTR DO
		      BEGIN TYPTR := REALPTR; KIND := CST;
			CVAL := VAL
		      END;
		    INSYMBOL
		  END;
		STRINGCONST:
		  BEGIN
		    WITH GATTR DO
		      BEGIN
			IF LGTH = 1 THEN TYPTR := CHARPTR
			ELSE
			  BEGIN NEW(LSP,ARRAYS,TRUE,TRUE);
			    LSP^ := STRGPTR^;
			    LSP^.MAXLENG := LGTH;
			    TYPTR := LSP
			  END;
			KIND := CST; CVAL := VAL
		      END;
		    INSYMBOL
		  END;
	(*(*)   LPARENT:
		  BEGIN INSYMBOL; EXPRESSION(FSYS + [RPARENT]);
		    IF SY = RPARENT THEN INSYMBOL ELSE ERROR(4)
		  END;
	(*NOT*) NOTSY:
		  BEGIN INSYMBOL; FACTOR(FSYS);
		    LOAD; GEN0(19(*NOT*));
		    IF GATTR.TYPTR <> NIL THEN
		      IF GATTR.TYPTR <> BOOLPTR THEN
			BEGIN ERROR(135); GATTR.TYPTR := NIL END;
		  END;
	(*[*)   LBRACK:
		  BEGIN INSYMBOL; CSTPART := [ ]; VARPART := FALSE;
		    NEW(LSP,POWER);
		    WITH LSP^ DO
		      BEGIN ELSET := NIL; SIZE := 0; FORM := POWER END;
		    IF SY = RBRACK THEN
		      BEGIN
			WITH GATTR DO
			  BEGIN TYPTR := LSP; KIND := CST END;
			INSYMBOL
		      END
		    ELSE
		      BEGIN
			REPEAT EXPRESSION(FSYS + [COMMA,RBRACK,COLON]);
			  IF GATTR.TYPTR <> NIL THEN
			    IF GATTR.TYPTR^.FORM <> SCALAR THEN
			      BEGIN ERROR(136); GATTR.TYPTR := NIL END
			    ELSE
			      IF COMPTYPES(LSP^.ELSET,GATTR.TYPTR) THEN
				BEGIN ALLCONST := FALSE; LOP := 23(*SGS*);
				  IF (GATTR.KIND = CST) AND
				     (GATTR.CVAL.IVAL <= 127) THEN
				    BEGIN ALLCONST := TRUE;
				      LOWVAL := GATTR.CVAL.IVAL;
				      HIGHVAL := LOWVAL
				    END;
				  LIC := IC; LOAD;
				  IF SY = COLON THEN
				    BEGIN INSYMBOL; LOP := 20(*SRS*);
				      EXPRESSION(FSYS + [COMMA,RBRACK]);
				      IF COMPTYPES(LSP^.ELSET,GATTR.TYPTR) THEN
				      ELSE
					BEGIN ERROR(137); GATTR.TYPTR:=NIL END;
				      IF ALLCONST THEN
					IF (GATTR.KIND = CST) AND
					   (GATTR.CVAL.IVAL <= 127) THEN
					    HIGHVAL := GATTR.CVAL.IVAL
					ELSE
					  BEGIN LOAD; ALLCONST := FALSE END
				      ELSE LOAD
				    END;
				  IF ALLCONST THEN
				    BEGIN IC := LIC; (*FORGET FIRST CONST*)
				      CSTPART := CSTPART + [LOWVAL..HIGHVAL]
				    END
				  ELSE
				    BEGIN GEN0(LOP);
				      IF VARPART THEN GEN0(28(*UNI*))
				      ELSE VARPART := TRUE
				    END;
				  LSP^.ELSET := GATTR.TYPTR;
				  GATTR.TYPTR := LSP
				END
			      ELSE ERROR(137);
			  TEST := SY <> COMMA;
			  IF NOT TEST THEN INSYMBOL
			UNTIL TEST;
			IF SY = RBRACK THEN INSYMBOL ELSE ERROR(12)
		      END;
		    IF VARPART THEN
		      BEGIN
			IF CSTPART <> [ ] THEN
			  BEGIN
			    SCONST^.PVAL := CSTPART;
			    SCONST^.CCLASS := PSET;
			    GATTR.CVAL.VALP := SCONST;
			    GATTR.KIND := CST;
			    LOAD; GEN0(28(*UNI*))
			  END;
			GATTR.KIND := EXPR
		      END
		    ELSE
		      BEGIN
			SCONST^.PVAL := CSTPART;
			SCONST^.CCLASS := PSET;
			GATTR.CVAL.VALP := SCONST;
			GATTR.KIND := CST
		      END
		  END
	      END (*CASE*) ;
	      IF NOT (SY IN FSYS) THEN
		BEGIN ERROR(6); SKIP(FSYS + FACBEGSYS) END
	    END (*WHILE*)
	END (*FACTOR*) ;

      BEGIN (*TERM*)
	FACTOR(FSYS + [MULOP]);
	WHILE SY = MULOP DO
	  BEGIN LOAD; LATTR := GATTR; LOP := OP;
	    INSYMBOL; FACTOR(FSYS + [MULOP]); LOAD;
	    IF (LATTR.TYPTR <> NIL) AND (GATTR.TYPTR <> NIL) THEN
	      CASE LOP OF
      (***)     MUL:  IF (LATTR.TYPTR = INTPTR) AND (GATTR.TYPTR = INTPTR)
			THEN GEN0(15(*MPI*))
		      ELSE
			BEGIN FLOATIT(LATTR.TYPTR);
			  IF (LATTR.TYPTR = REALPTR) AND
			     (GATTR.TYPTR = REALPTR) THEN GEN0(16(*MPR*))
			  ELSE
			    IF (LATTR.TYPTR^.FORM = POWER)
				AND COMPTYPES(LATTR.TYPTR,GATTR.TYPTR) THEN
			      GEN0(12(*INT*))
			    ELSE BEGIN ERROR(134); GATTR.TYPTR:=NIL END
			END;
      (*/*)     RDIV: BEGIN FLOATIT(LATTR.TYPTR);
			IF (LATTR.TYPTR = REALPTR) AND
			   (GATTR.TYPTR = REALPTR) THEN GEN0(7(*DVR*))
			ELSE BEGIN ERROR(134); GATTR.TYPTR := NIL END
		      END;
      (*DIV*)   IDIV: IF (LATTR.TYPTR = INTPTR) AND
			 (GATTR.TYPTR = INTPTR) THEN GEN0(6(*DVI*))
		      ELSE BEGIN ERROR(134); GATTR.TYPTR := NIL END;
      (*MOD*)   IMOD: IF (LATTR.TYPTR = INTPTR) AND
			 (GATTR.TYPTR = INTPTR) THEN GEN0(14(*MOD*))
		      ELSE BEGIN ERROR(134); GATTR.TYPTR := NIL END;
      (*AND*)   ANDOP:IF (LATTR.TYPTR = BOOLPTR) AND
			 (GATTR.TYPTR = BOOLPTR) THEN GEN0(4(*AND*))
		      ELSE BEGIN ERROR(134); GATTR.TYPTR := NIL END
	      END (*CASE*)
	    ELSE GATTR.TYPTR := NIL
	  END (*WHILE*)
      END (*TERM*) ;

    BEGIN (*SIMPLEEXPRESSION*)
      SIGNED := FALSE;
      IF (SY = ADDOP) AND (OP IN [PLUS,MINUS]) THEN
	BEGIN SIGNED := OP = MINUS; INSYMBOL END;
      TERM(FSYS + [ADDOP]);
      IF SIGNED THEN
	BEGIN LOAD;
	  IF GATTR.TYPTR = INTPTR THEN GEN0(17(*NGI*))
	  ELSE
	    IF GATTR.TYPTR = REALPTR THEN GEN0(18(*NGR*))
	    ELSE BEGIN ERROR(134); GATTR.TYPTR := NIL END
	END;
      WHILE SY = ADDOP DO
	BEGIN LOAD; LATTR := GATTR; LOP := OP;
	  INSYMBOL; TERM(FSYS + [ADDOP]); LOAD;
	  IF (LATTR.TYPTR <> NIL) AND (GATTR.TYPTR <> NIL) THEN
	    CASE LOP OF
    (*+*)     PLUS:
		IF (LATTR.TYPTR = INTPTR)AND(GATTR.TYPTR = INTPTR) THEN
		  GEN0(2(*ADI*))
		ELSE
		  BEGIN FLOATIT(LATTR.TYPTR);
		    IF (LATTR.TYPTR = REALPTR)AND(GATTR.TYPTR = REALPTR)
		      THEN GEN0(3(*ADR*))
		    ELSE IF (LATTR.TYPTR^.FORM = POWER)
			     AND COMPTYPES(LATTR.TYPTR,GATTR.TYPTR) THEN
			   GEN0(28(*UNI*))
			 ELSE BEGIN ERROR(134); GATTR.TYPTR := NIL END
		  END;
    (*-*)     MINUS:
		IF (LATTR.TYPTR = INTPTR) AND (GATTR.TYPTR = INTPTR) THEN
		  GEN0(21(*SBI*))
		ELSE
		  BEGIN FLOATIT(LATTR.TYPTR);
		    IF (LATTR.TYPTR = REALPTR) AND (GATTR.TYPTR = REALPTR)
		      THEN GEN0(22(*SBR*))
		    ELSE
		      IF (LATTR.TYPTR^.FORM = POWER)
			  AND COMPTYPES(LATTR.TYPTR,GATTR.TYPTR) THEN
			GEN0(5(*DIF*))
		      ELSE BEGIN ERROR(134); GATTR.TYPTR := NIL END
		  END;
    (*OR*)    OROP:
		IF (LATTR.TYPTR = BOOLPTR) AND (GATTR.TYPTR = BOOLPTR) THEN
		  GEN0(13(*IOR*))
		ELSE BEGIN ERROR(134); GATTR.TYPTR := NIL END
	    END (*CASE*)
	  ELSE GATTR.TYPTR := NIL
	END (*WHILE*)
    END (*SIMPLEEXPRESSION*) ;

    PROCEDURE MAKEPA(VAR STRGFSP: STP; PAFSP: STP);
      VAR LMIN,LMAX: INTEGER;
    BEGIN
      IF PAFSP^.INXTYPE <> NIL THEN
	BEGIN GETBOUNDS(PAFSP^.INXTYPE,LMIN,LMAX);
	  IF LMAX-LMIN+1 <> STRGFSP^.MAXLENG THEN ERROR(129)
	END;
      STRGFSP := PAFSP
    END (*MAKEPA*) ;

  BEGIN (*EXPRESSION*)
    SIMPLEEXPRESSION(FSYS + [RELOP]);
    IF SY = RELOP THEN
      BEGIN
	LSTRING := STRGTYPE(GATTR.TYPTR) AND (GATTR.KIND = CST);
	IF GATTR.TYPTR <> NIL THEN
	  IF GATTR.TYPTR^.FORM <= POWER THEN LOAD
	  ELSE LOADADDRESS;
	LATTR := GATTR; LOP := OP;
	INSYMBOL; SIMPLEEXPRESSION(FSYS);
	GSTRING := STRGTYPE(GATTR.TYPTR) AND (GATTR.KIND = CST);
	IF GATTR.TYPTR <> NIL THEN
	  IF GATTR.TYPTR^.FORM <= POWER THEN LOAD
	  ELSE LOADADDRESS;
	IF (LATTR.TYPTR <> NIL) AND (GATTR.TYPTR <> NIL) THEN
	  IF LOP = INOP THEN
	    IF GATTR.TYPTR^.FORM = POWER THEN
	      IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR^.ELSET) THEN
		GEN0(11(*INN*))
	      ELSE BEGIN ERROR(129); GATTR.TYPTR := NIL END
	    ELSE BEGIN ERROR(130); GATTR.TYPTR := NIL END
	  ELSE
	    BEGIN
	      IF LATTR.TYPTR <> GATTR.TYPTR THEN FLOATIT(LATTR.TYPTR);
	      IF LSTRING THEN
		BEGIN
		  IF PAOFCHAR(GATTR.TYPTR) THEN
		    IF NOT GATTR.TYPTR^.AISSTRNG THEN
		      BEGIN GEN0(29(*S2P*));
			MAKEPA(LATTR.TYPTR,GATTR.TYPTR)
		      END
		END
	      ELSE
		IF GSTRING THEN
		  BEGIN
		    IF PAOFCHAR(LATTR.TYPTR) THEN
		      IF NOT LATTR.TYPTR^.AISSTRNG THEN
			BEGIN GEN0(80(*S1P*));
			  MAKEPA(GATTR.TYPTR,LATTR.TYPTR)
			END;
		  END;
	      IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR) THEN
		BEGIN LSIZE := LATTR.TYPTR^.SIZE;
		  CASE LATTR.TYPTR^.FORM OF
		    SCALAR:
		      IF LATTR.TYPTR = REALPTR THEN TYPIND := 1
		      ELSE
			IF LATTR.TYPTR = BOOLPTR THEN TYPIND := 3
			ELSE TYPIND := 0;
		    POINTER:
		      BEGIN
			IF LOP IN [LTOP,LEOP,GTOP,GEOP] THEN ERROR(131);
			TYPIND := 0
		      END;
		    POWER:
		      BEGIN
			IF LOP IN [LTOP,GTOP] THEN ERROR(132);
			TYPIND := 4
		      END;
		    ARRAYS:
		      BEGIN
			TYPIND := 6;
			IF PAOFCHAR(LATTR.TYPTR) THEN
			  IF LATTR.TYPTR^.AISSTRNG THEN TYPIND := 2
			  ELSE
			    BEGIN TYPIND := 5;
			      IF LATTR.TYPTR^.INXTYPE <> NIL THEN
				BEGIN
				  GETBOUNDS(LATTR.TYPTR^.INXTYPE,LMIN,LMAX);
				  LSIZE := LMAX - LMIN + 1
				END
			    END
			ELSE
			  IF LOP IN [LTOP,LEOP,GTOP,GEOP] THEN ERROR(131)
		      END;
		    RECORDS:
		      BEGIN
			IF LOP IN [LTOP,LEOP,GTOP,GEOP] THEN ERROR(131);
			TYPIND := 6
		      END;
		    FILES:
		      BEGIN ERROR(133); TYPIND := 0 END
		  END;
		  CASE LOP OF
		    LTOP: GEN2(53(*LES*),TYPIND,LSIZE);
		    LEOP: GEN2(52(*LEQ*),TYPIND,LSIZE);
		    GTOP: GEN2(49(*GRT*),TYPIND,LSIZE);
		    GEOP: GEN2(48(*GEQ*),TYPIND,LSIZE);
		    NEOP: GEN2(55(*NEQ*),TYPIND,LSIZE);
		    EQOP: GEN2(47(*EQU*),TYPIND,LSIZE)
		  END
		END
	      ELSE ERROR(129)
	    END;
	GATTR.TYPTR := BOOLPTR; GATTR.KIND := EXPR
      END (*SY = RELOP*)
  END (*EXPRESSION*) ;

  PROCEDURE STATEMENT(FSYS: SETOFSYS);
    LABEL 1;
    VAR LCP: CTP; TTOP: DISPRANGE; LLP: LABELP; HEAP: ^INTEGER;

    PROCEDURE ASSIGNMENT(FCP: CTP);
      VAR LATTR: ATTR; CSTRING,PAONLEFT: BOOLEAN; LMIN,LMAX: INTEGER;
    BEGIN SELECTOR(FSYS + [BECOMES],FCP);
      IF SY = BECOMES THEN
	BEGIN LMAX := 0; CSTRING := FALSE;
	  IF GATTR.TYPTR <> NIL THEN
	    IF (GATTR.ACCESS = INDRCT) OR (GATTR.TYPTR^.FORM > POWER) THEN
	      LOADADDRESS;
	  PAONLEFT := PAOFCHAR(GATTR.TYPTR);
	  LATTR := GATTR;
	  INSYMBOL; EXPRESSION(FSYS);
	  IF GATTR.KIND = CST THEN
	    CSTRING := (GATTR.TYPTR = CHARPTR) OR STRGTYPE(GATTR.TYPTR);
	  IF GATTR.TYPTR <> NIL THEN
	    IF GATTR.TYPTR^.FORM <= POWER THEN LOAD
	    ELSE LOADADDRESS;
	  IF (LATTR.TYPTR <> NIL) AND (GATTR.TYPTR <> NIL) THEN
	    BEGIN
	      IF GATTR.TYPTR = INTPTR THEN
		IF COMPTYPES(REALPTR,LATTR.TYPTR) THEN
		  BEGIN GEN0(10(*FLT*)); GATTR.TYPTR := REALPTR END;
	      IF PAONLEFT THEN
		IF LATTR.TYPTR^.AISSTRNG THEN
		  IF CSTRING AND (GATTR.TYPTR = CHARPTR) THEN
		    GATTR.TYPTR := STRGPTR
		  ELSE
		ELSE
		  IF LATTR.TYPTR^.INXTYPE <> NIL THEN
		    BEGIN GETBOUNDS(LATTR.TYPTR^.INXTYPE,LMIN,LMAX);
		      LMAX := LMAX - LMIN + 1;
		      IF CSTRING AND (GATTR.TYPTR <> CHARPTR) THEN
			BEGIN GEN0(80(*S1P*));
			  IF LMAX <> GATTR.TYPTR^.MAXLENG THEN ERROR(129);
			  GATTR.TYPTR := LATTR.TYPTR
			END
		    END
		  ELSE GATTR.TYPTR := LATTR.TYPTR;
	      IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR) THEN
		CASE LATTR.TYPTR^.FORM OF
		  SUBRANGE: BEGIN
			      IF RANGECHECK THEN
				BEGIN
				  GENLDC(LATTR.TYPTR^.MIN.IVAL);
				  GENLDC(LATTR.TYPTR^.MAX.IVAL);
				  GEN0(8(*CHK*))
				END;
			      STORE(LATTR)
			    END;
		  POWER:    BEGIN
			      GEN1(32(*ADJ*),LATTR.TYPTR^.SIZE);
			      STORE(LATTR)
			    END;
		  SCALAR,
		  POINTER: STORE(LATTR);
		  ARRAYS:  IF PAONLEFT THEN
			     IF LATTR.TYPTR^.AISSTRNG THEN
			       GEN1(42(*SAS*),LATTR.TYPTR^.MAXLENG)
			     ELSE GEN1(41(*MVB*),LMAX)
			   ELSE GEN1(40(*MOV*),LATTR.TYPTR^.SIZE);
		  RECORDS: GEN1(40(*MOV*),LATTR.TYPTR^.SIZE);
		  FILES:   ERROR(146)
		END
	      ELSE ERROR(129)
	    END
	END (*SY = BECOMES*)
      ELSE ERROR(51)
    END (*ASSIGNMENT*) ;

    PROCEDURE GOTOSTATEMENT;
      VAR LLP: LABELP; FOUND: BOOLEAN; TTOP: DISPRANGE;
    BEGIN
      IF NOT GOTOOK THEN ERROR(6);
      IF SY = INTCONST THEN
	BEGIN
	  FOUND := FALSE; TTOP := TOP;
	  WHILE DISPLAY[TTOP].OCCUR <> BLCK DO TTOP := TTOP - 1;
	  LLP := DISPLAY[TTOP].FLABEL;
	  WHILE (LLP <> NIL) AND NOT FOUND DO
	    WITH LLP^ DO
	      IF LABVAL = VAL.IVAL THEN
		BEGIN FOUND := TRUE;
		  GENJMP(57(*UJP*),CODELBP)
		END
	      ELSE LLP := NEXTLAB;
	  IF NOT FOUND THEN ERROR(167);
	  INSYMBOL
	END
      ELSE ERROR(15)
    END (*GOTOSTATEMENT*) ;

    PROCEDURE COMPOUNDSTATEMENT;
    BEGIN
      REPEAT
	REPEAT STATEMENT(FSYS + [SEMICOLON,ENDSY])
	UNTIL NOT (SY IN STATBEGSYS);
	TEST := SY <> SEMICOLON;
	IF NOT TEST THEN INSYMBOL
      UNTIL TEST;
      IF SY = ENDSY THEN INSYMBOL ELSE ERROR(13)
    END (*COMPOUNDSTATEMENET*) ;

    PROCEDURE IFSTATEMENT;
      VAR LCIX1,LCIX2: LBP;
    BEGIN EXPRESSION(FSYS + [THENSY]);
      GENLABEL(LCIX1); GENFJP(LCIX1);
      IF SY = THENSY THEN INSYMBOL ELSE ERROR(52);
      STATEMENT(FSYS + [ELSESY]);
      IF SY = ELSESY THEN
	BEGIN GENLABEL(LCIX2); GENJMP(57(*UJP*),LCIX2);
	  PUTLABEL(LCIX1);
	  INSYMBOL; STATEMENT(FSYS);
	  PUTLABEL(LCIX2)
	END
      ELSE PUTLABEL(LCIX1)
    END (*IFSTATEMENT*) ;

    PROCEDURE CASESTATEMENT;
      LABEL 1;
      TYPE CIP = ^CASEINFO;
	   CASEINFO = RECORD
			NEXT: CIP;
			CSSTART: INTEGER;
			CSLAB: INTEGER
		      END;
      VAR LSP,LSP1: STP; FSTPTR,LPT1,LPT2,LPT3: CIP; LVAL: VALU;
	  LADDR, LCIX: LBP; NULSTMT, LMIN, LMAX: INTEGER;
    BEGIN EXPRESSION(FSYS + [OFSY,COMMA,COLON]);
      LOAD; GENLABEL(LCIX); GENJMP(57(*UJP*),LCIX);
      LSP := GATTR.TYPTR;
      IF LSP <> NIL THEN
	IF (LSP^.FORM <> SCALAR) OR (LSP = REALPTR) THEN
	  BEGIN ERROR(144); LSP := NIL END;
      IF SY = OFSY THEN INSYMBOL ELSE ERROR(8);
      FSTPTR := NIL; GENLABEL(LADDR);
      REPEAT
	LPT3 := NIL;
	REPEAT CONSTANT(FSYS + [COMMA,COLON],LSP1,LVAL);
	  IF LSP <> NIL THEN
	    IF COMPTYPES(LSP,LSP1) THEN
	      BEGIN LPT1 := FSTPTR; LPT2 := NIL;
		WHILE LPT1 <> NIL DO
		  WITH LPT1^ DO
		    BEGIN
		      IF CSLAB <= LVAL.IVAL THEN
			BEGIN IF CSLAB = LVAL.IVAL THEN ERROR(156);
			  GOTO 1
			END;
		      LPT2 := LPT1; LPT1 := NEXT
		    END;
    1:          NEW(LPT3);
		WITH LPT3^ DO
		  BEGIN NEXT := LPT1; CSLAB := LVAL.IVAL;
		    CSSTART := IC
		  END;
		IF LPT2 = NIL THEN FSTPTR := LPT3
		ELSE LPT2^.NEXT := LPT3
	      END
	    ELSE ERROR(147);
	  TEST := SY <> COMMA;
	  IF NOT TEST THEN INSYMBOL
	UNTIL TEST;
	IF SY = COLON THEN INSYMBOL ELSE ERROR(5);
	REPEAT STATEMENT(FSYS + [SEMICOLON])
	UNTIL NOT (SY IN STATBEGSYS);
	IF LPT3 <> NIL THEN
	  GENJMP(57(*UJP*),LADDR);
	TEST := SY <> SEMICOLON;
	IF NOT TEST THEN INSYMBOL
      UNTIL TEST;
      PUTLABEL(LCIX);
      IF FSTPTR <> NIL THEN
	BEGIN LMAX := FSTPTR^.CSLAB;
	  LPT1 := FSTPTR; FSTPTR := NIL;
	  REPEAT LPT2 := LPT1^.NEXT; LPT1^.NEXT := FSTPTR;
	    FSTPTR := LPT1; LPT1 := LPT2
	  UNTIL LPT1 = NIL;
	  LMIN := FSTPTR^.CSLAB;
	      GEN0(44(*XJP*));
	      GENWORD(LMIN); GENWORD(LMAX);
	      NULSTMT := IC;
	      GENJMP(57(*UJP*),LADDR);
	      REPEAT
		WITH FSTPTR^ DO
		  BEGIN
		    WHILE CSLAB > LMIN DO
		      BEGIN GENWORD(IC-NULSTMT); LMIN := LMIN + 1 END;
		    GENWORD(IC-CSSTART);
		    FSTPTR := NEXT; LMIN := LMIN + 1
		  END
	      UNTIL FSTPTR = NIL;
	      PUTLABEL(LADDR)
	END;
	IF SY = ENDSY THEN INSYMBOL ELSE ERROR(13)
    END (*CASESTATEMENT*) ;

    PROCEDURE REPEATSTATEMENT;
      VAR LADDR: LBP;
    BEGIN GENLABEL(LADDR); PUTLABEL(LADDR);
      REPEAT
	REPEAT STATEMENT(FSYS + [SEMICOLON,UNTILSY])
	UNTIL NOT (SY IN STATBEGSYS);
	TEST := SY <> SEMICOLON;
	IF NOT TEST THEN INSYMBOL
      UNTIL TEST;
      IF SY = UNTILSY THEN
	BEGIN INSYMBOL; EXPRESSION(FSYS); GENFJP(LADDR)
	END
      ELSE ERROR(53)
    END (*REPEATSTATEMENT*) ;

    PROCEDURE WHILESTATEMENT;
      VAR LADDR, LCIX: LBP;
    BEGIN GENLABEL(LADDR); PUTLABEL(LADDR);
      EXPRESSION(FSYS + [DOSY]); GENLABEL(LCIX); GENFJP(LCIX);
      IF SY = DOSY THEN INSYMBOL ELSE ERROR(54);
      STATEMENT(FSYS); GENJMP(57(*UJP*),LADDR); PUTLABEL(LCIX)
    END (*WHILESTATEMENT*) ;

    PROCEDURE FORSTATEMENT;
      VAR LATTR: ATTR; LSP: STP;  LSY: SYMBOL;
	  LCIX, LADDR: LBP;
    BEGIN
      IF SY = IDENT THEN
	BEGIN SEARCHID([VARS],LCP);
	  WITH LCP^, LATTR DO
	    BEGIN TYPTR := IDTYPE; KIND := VARBL;
	      IF VKIND = ACTUAL THEN
		BEGIN ACCESS := DRCT; VLEVEL := VLEV;
		  DPLMT := VADDR
		END
	      ELSE BEGIN ERROR(155); TYPTR := NIL END
	    END;
	  IF LATTR.TYPTR <> NIL THEN
	    IF (LATTR.TYPTR^.FORM > SUBRANGE)
	       OR COMPTYPES(REALPTR,LATTR.TYPTR) THEN
	      BEGIN ERROR(143); LATTR.TYPTR := NIL END;
	  INSYMBOL
	END
      ELSE
	BEGIN ERROR(2); SKIP(FSYS + [BECOMES,TOSY,DOWNTOSY,DOSY])
	END;
      IF SY = BECOMES THEN
	BEGIN INSYMBOL; EXPRESSION(FSYS + [TOSY,DOWNTOSY,DOSY]);
	  IF GATTR.TYPTR <> NIL THEN
	    IF GATTR.TYPTR^.FORM <> SCALAR THEN ERROR(144)
	      ELSE
		IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR) THEN
		  BEGIN LOAD;
		    IF LATTR.TYPTR <> NIL THEN
		      IF (LATTR.TYPTR^.FORM = SUBRANGE) AND RANGECHECK THEN
			BEGIN
			  GENLDC(LATTR.TYPTR^.MIN.IVAL);
			  GENLDC(LATTR.TYPTR^.MAX.IVAL);
			  GEN0(8(*CHK*))
			END;
		    STORE(LATTR)
		  END
		ELSE ERROR(145)
	END
      ELSE
	BEGIN ERROR(51); SKIP(FSYS + [TOSY,DOWNTOSY,DOSY]) END;
      GENLABEL(LADDR);
      IF SY IN [TOSY,DOWNTOSY] THEN
	BEGIN LSY := SY; INSYMBOL; EXPRESSION(FSYS + [DOSY]);
	  IF GATTR.TYPTR <> NIL THEN
	    IF GATTR.TYPTR^.FORM <> SCALAR THEN ERROR(144)
	    ELSE
	      IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR) THEN
		BEGIN LOAD;
		  IF LATTR.TYPTR <> NIL THEN
		    IF (LATTR.TYPTR^.FORM = SUBRANGE) AND RANGECHECK THEN
		      BEGIN
			GENLDC(LATTR.TYPTR^.MIN.IVAL);
			GENLDC(LATTR.TYPTR^.MAX.IVAL);
			GEN0(8(*CHK*))
		      END;
		  GEN2(56(*STR*),0,LC); PUTLABEL(LADDR);
		  GATTR := LATTR; LOAD; GEN2(54(*LOD*),0,LC);
		  LC := LC + INTSIZE;
		  IF LC > LCMAX THEN LCMAX := LC;
		  IF LSY = TOSY THEN GEN2(52(*LEQ*),0,INTSIZE)
		  ELSE GEN2(48(*GEQ*),0,INTSIZE);
		END
	      ELSE ERROR(145)
	END
      ELSE BEGIN ERROR(55); SKIP(FSYS + [DOSY]) END;
      GENLABEL(LCIX); GENJMP(33(*FJP*),LCIX);
      IF SY = DOSY THEN INSYMBOL ELSE ERROR(54);
      STATEMENT(FSYS);
      GATTR := LATTR; LOAD; GENLDC(1);
      IF LSY = TOSY THEN GEN0(2(*ADI*)) ELSE GEN0(21(*SBI*));
      STORE(LATTR); GENJMP(57(*UJP*),LADDR); PUTLABEL(LCIX);
      LC := LC - INTSIZE
    END (*FORSTATEMENT*) ;


    PROCEDURE WITHSTATEMENT;
      VAR LCP: CTP; LCNT1,LCNT2: DISPRANGE;
    BEGIN LCNT1 := 0; LCNT2 := 0;
      REPEAT
	IF SY = IDENT THEN
	  BEGIN SEARCHID([VARS,FIELD],LCP); INSYMBOL END
	ELSE BEGIN ERROR(2); LCP := UVARPTR END;
	SELECTOR(FSYS + [COMMA,DOSY],LCP);
	IF GATTR.TYPTR <> NIL THEN
	  IF GATTR.TYPTR^.FORM = RECORDS THEN
	    IF TOP < DISPLIMIT THEN
	      BEGIN TOP := TOP + 1; LCNT1 := LCNT1 + 1;
		WITH DISPLAY[TOP] DO
		  BEGIN FNAME := GATTR.TYPTR^.FSTFLD END;
		IF GATTR.ACCESS = DRCT THEN
		  WITH DISPLAY[TOP] DO
		    BEGIN OCCUR := CREC; CLEV := GATTR.VLEVEL;
		      CDSPL := GATTR.DPLMT
		    END
		ELSE
		  BEGIN LOADADDRESS; GEN2(56(*STR*),0,LC);
		    WITH DISPLAY[TOP] DO
		      BEGIN OCCUR := VREC; VDSPL := LC END;
		    LC := LC + PTRSIZE; LCNT2 := LCNT2 + PTRSIZE;
		    IF LC > LCMAX THEN LCMAX := LC
		  END
	      END
	    ELSE ERROR(250)
	  ELSE ERROR(140);
	TEST := SY <> COMMA;
	IF NOT TEST THEN INSYMBOL
      UNTIL TEST;
      IF SY = DOSY THEN INSYMBOL ELSE ERROR(54);
      STATEMENT(FSYS);
      TOP := TOP - LCNT1; LC := LC - LCNT2;
    END (*WITHSTATEMENT*) ;

  BEGIN (*STATEMENT*)
    IF SY = INTCONST THEN (*LABEL*)
      BEGIN TTOP := TOP;
	WHILE DISPLAY[TTOP].OCCUR <> BLCK DO TTOP := TTOP-1;
	LLP := DISPLAY[TTOP].FLABEL;
	WHILE LLP <> NIL DO
	  WITH LLP^ DO
	    IF LABVAL = VAL.IVAL THEN
	      BEGIN
		IF CODELBP^.DEFINED THEN ERROR(165);
		PUTLABEL(CODELBP); GOTO 1
	      END
	    ELSE LLP := NEXTLAB;
	ERROR(167);
  1:    INSYMBOL;
	IF SY = COLON THEN INSYMBOL ELSE ERROR(5)
      END;
    IF NOT (SY IN FSYS + [IDENT]) THEN
      BEGIN ERROR(6); SKIP(FSYS) END;
    IF SY IN STATBEGSYS + [IDENT] THEN
      BEGIN MARK(HEAP); (*FOR LABEL CLEANUP*)
	CASE SY OF
	  IDENT:    BEGIN SEARCHID([VARS,FIELD,FUNC,PROC],LCP);
		      INSYMBOL;
		      IF LCP^.KLASS = PROC THEN CALL(FSYS,LCP)
		      ELSE ASSIGNMENT(LCP)
		    END;
	  BEGINSY:  BEGIN INSYMBOL; COMPOUNDSTATEMENT END;
	  GOTOSY:   BEGIN INSYMBOL; GOTOSTATEMENT END;
	  IFSY:     BEGIN INSYMBOL; IFSTATEMENT END;
	  CASESY:   BEGIN INSYMBOL; CASESTATEMENT END;
	  WHILESY:  BEGIN INSYMBOL; WHILESTATEMENT END;
	  REPEATSY: BEGIN INSYMBOL; REPEATSTATEMENT END;
	  FORSY:    BEGIN INSYMBOL; FORSTATEMENT END;
	  WITHSY:   BEGIN INSYMBOL; WITHSTATEMENT END
	END;
	RELEASE(HEAP);
	IF IC + 100 > MAXCODE THEN
	  BEGIN ERROR(253); IC := 0 END;
	IF NOT (SY IN [SEMICOLON,ENDSY,ELSESY,UNTILSY]) THEN
	  BEGIN ERROR(6); SKIP(FSYS) END
      END
  END (*STATEMENT*) ;

========================================================================================
DOCUMENT :usus Folder:VOL17:comp.f.text
========================================================================================


  PROCEDURE BLOCK(FSYS: SETOFSYS; FSY: SYMBOL; FPROCP: CTP);
    VAR LSY: SYMBOL;

    PROCEDURE LABELDECLARATION;
      VAR LLP: LABELP; REDEF: BOOLEAN;
    BEGIN
      REPEAT
	IF SY = INTCONST THEN
	  WITH DISPLAY[TOP] DO
	    BEGIN LLP := FLABEL; REDEF := FALSE;
	      WHILE (LLP <> NIL) AND NOT REDEF DO
		IF LLP^.LABVAL <> VAL.IVAL THEN
		  LLP := LLP^.NEXTLAB
		ELSE BEGIN REDEF := TRUE; ERROR(166) END;
	      IF NOT REDEF THEN
		BEGIN NEW(LLP);
		  WITH LLP^ DO
		    BEGIN LABVAL := VAL.IVAL;
		      CODELBP := NIL; NEXTLAB := FLABEL
		    END;
		  FLABEL := LLP
		END;
	      INSYMBOL
	    END
	ELSE ERROR(15);
	IF NOT ( SY IN FSYS + [COMMA, SEMICOLON] ) THEN
	  BEGIN ERROR(6); SKIP(FSYS+[COMMA,SEMICOLON]) END;
	TEST := SY <> COMMA;
	IF NOT TEST THEN INSYMBOL
      UNTIL TEST;
      IF SY = SEMICOLON THEN INSYMBOL ELSE ERROR(14)
    END (* LABELDECLARATION *) ;
  
    PROCEDURE CONSTDECLARATION;
      VAR LCP: CTP; LSP: STP; LVALU: VALU;
    BEGIN
      IF SY <> IDENT THEN
	BEGIN ERROR(2); SKIP(FSYS + [IDENT]) END;
      WHILE SY = IDENT DO
	BEGIN NEW(LCP,KONST);
	  WITH LCP^ DO
	    BEGIN NAME := ID; IDTYPE := NIL;
	      NEXT := NIL; KLASS := KONST
	    END;
	  INSYMBOL;
	  IF (SY = RELOP) AND (OP = EQOP) THEN INSYMBOL ELSE ERROR(16);
	  CONSTANT(FSYS + [SEMICOLON],LSP,LVALU);
	  ENTERID(LCP);
	  LCP^.IDTYPE := LSP; LCP^.VALUES := LVALU;
	  IF SY = SEMICOLON THEN
	    BEGIN INSYMBOL;
	      IF NOT (SY IN FSYS + [IDENT]) THEN
		BEGIN ERROR(6); SKIP(FSYS + [IDENT]) END
	    END
	  ELSE ERROR(14)
	END
    END (*CONSTDECLARATION*) ;
  
    PROCEDURE TYPEDECLARATION;
      VAR LCP,LCP1,LCP2: CTP; LSP: STP; LSIZE: ADDRRANGE;
    BEGIN
      IF SY <> IDENT THEN
	BEGIN ERROR(2); SKIP(FSYS + [IDENT]) END;
      WHILE SY = IDENT DO
	BEGIN NEW(LCP,TYPES);
	  WITH LCP^ DO
	    BEGIN NAME := ID; IDTYPE := NIL; KLASS := TYPES END;
	  INSYMBOL;
	  IF (SY = RELOP) AND (OP = EQOP) THEN INSYMBOL ELSE ERROR(16);
	  TYP(FSYS + [SEMICOLON],LSP,LSIZE);
	  ENTERID(LCP);
	  LCP^.IDTYPE := LSP;
	  LCP1 := FWPTR;
	  WHILE LCP1 <> NIL DO
	    BEGIN
	      IF LCP1^.NAME = LCP^.NAME THEN
		BEGIN
		  LCP1^.IDTYPE^.ELTYPE := LCP^.IDTYPE;
		  IF LCP1 <> FWPTR THEN
		    LCP2^.NEXT := LCP1^.NEXT
		  ELSE FWPTR := LCP1^.NEXT;
		END;
	      LCP2 := LCP1; LCP1 := LCP1^.NEXT
	    END;
	  IF SY = SEMICOLON THEN
	    BEGIN INSYMBOL;
	      IF NOT (SY IN FSYS + [IDENT]) THEN
		BEGIN ERROR(6); SKIP(FSYS + [IDENT]) END
	    END
	  ELSE ERROR(14)
	END;
      IF FWPTR <> NIL THEN
	BEGIN ERROR(117); FWPTR := NIL END
    END (*TYPEDECLARATION*) ;
  
    PROCEDURE VARDECLARATION;
      VAR LCP,NXT,IDLIST: CTP; LSP: STP; LSIZE: ADDRRANGE;
    BEGIN NXT := NIL;
      REPEAT
	REPEAT
	  IF SY = IDENT THEN
	    BEGIN NEW(LCP,VARS);
	      WITH LCP^ DO
	       BEGIN NAME := ID; NEXT := NXT; KLASS := VARS;
		  IDTYPE := NIL; VKIND := ACTUAL; VLEV := LEVEL
		END;
	      ENTERID(LCP);
	      NXT := LCP;
	      INSYMBOL;
	    END
	  ELSE ERROR(2);
	  IF NOT (SY IN FSYS + [COMMA,COLON] + TYPEDELS) THEN
	    BEGIN ERROR(6); SKIP(FSYS+[COMMA,COLON,SEMICOLON]+TYPEDELS) END;
	  TEST := SY <> COMMA;
	  IF NOT TEST THEN INSYMBOL
	UNTIL TEST;
	IF SY = COLON THEN INSYMBOL ELSE ERROR(5);
	IDLIST := NXT;
	TYP(FSYS + [SEMICOLON] + TYPEDELS,LSP,LSIZE);
	WHILE NXT <> NIL DO
	  WITH  NXT^ DO
	    BEGIN IDTYPE := LSP; VADDR := LC;
	      LC := LC + LSIZE; NXT := NEXT;
	      IF NEXT = NIL THEN
		IF LSP <> NIL THEN
		  IF LSP^.FORM = FILES THEN
		      BEGIN (*PUT IDLIST INTO LOCAL FILE LIST*)
			NEXT := DISPLAY[TOP].FFILE;
			DISPLAY[TOP].FFILE := IDLIST
		      END
	    END;
	IF SY = SEMICOLON THEN
	  BEGIN INSYMBOL;
	    IF NOT (SY IN FSYS + [IDENT]) THEN
	      BEGIN ERROR(6); SKIP(FSYS + [IDENT]) END
	  END
	ELSE ERROR(14)
      UNTIL (SY <> IDENT) AND NOT (SY IN TYPEDELS);
    IF FWPTR <> NIL THEN
	BEGIN ERROR(117); FWPTR := NIL END
    END (*VARDECLARATION*) ;
  
    PROCEDURE PROCDECLARATION(FSY: SYMBOL);
      VAR OLDLEV: 0..MAXLEVEL; LSY: SYMBOL; LCP,LCP1: CTP; LSP: STP;
	  FORW: BOOLEAN; OLDTOP: DISPRANGE; OLDPROC: PROCRANGE;
	  LLC,LCM: ADDRRANGE;  MARKP: ^INTEGER;
  
      PROCEDURE PARAMETERLIST(FSY: SETOFSYS; VAR FPAR: CTP; FCP: CTP);
	VAR LCP,LCP1,LCP2,LCP3: CTP; LSP: STP; LKIND: IDKIND;
	  LLC,LEN : ADDRRANGE; COUNT : INTEGER;
      BEGIN LCP1 := NIL; LLC := LC;
	IF NOT (SY IN FSY + [LPARENT]) THEN
	  BEGIN ERROR(7); SKIP(FSYS + FSY + [LPARENT]) END;
	IF SY = LPARENT THEN
	  BEGIN IF FORW THEN ERROR(119);
	    INSYMBOL;
	    IF NOT (SY IN [IDENT,VARSY]) THEN
	      BEGIN ERROR(7); SKIP(FSYS + [IDENT,RPARENT]) END;
	    WHILE SY IN [IDENT,VARSY] DO
	      BEGIN
		IF SY = VARSY THEN
		  BEGIN LKIND := FORMAL; INSYMBOL END
		ELSE LKIND := ACTUAL;
		LCP2 := NIL;
		COUNT := 0;
		REPEAT
		  IF SY = IDENT THEN
		    BEGIN NEW(LCP,VARS);
		      WITH LCP^ DO
			BEGIN NAME := ID; IDTYPE := NIL;
			  VKIND := LKIND; NEXT := LCP2;
			  KLASS := VARS; VLEV := LEVEL
			END;
		      ENTERID(LCP);
		      LCP2 := LCP; COUNT := COUNT + 1;
		      INSYMBOL
		    END;
		  IF NOT (SY IN FSYS + [COMMA,COLON]) THEN
		    BEGIN ERROR(7);
		      SKIP(FSYS + [COMMA,SEMICOLON,RPARENT,COLON])
		    END;
		  TEST := SY <> COMMA;
		  IF NOT TEST THEN INSYMBOL
		UNTIL TEST;
		IF SY = COLON THEN
		  BEGIN INSYMBOL;
		    IF SY = IDENT THEN
		      BEGIN
			SEARCHID([TYPES],LCP);
			LSP := LCP^.IDTYPE;
			LCP3 := LCP2;
			LEN := PTRSIZE;
			IF LSP <> NIL THEN
			  IF LKIND = ACTUAL THEN
			    IF LSP^.FORM = FILES THEN ERROR(121)
			    ELSE
			      IF LSP^.FORM <= POWER THEN LEN := LSP^.SIZE;
			LC := LC + COUNT * LEN;
			WHILE LCP2 <> NIL DO
			  BEGIN LCP := LCP2;
			    WITH LCP2^ DO
			      BEGIN IDTYPE := LSP;
				LCP2 := NEXT
			      END
			  END;
			LCP^.NEXT := LCP1; LCP1 := LCP3;
			INSYMBOL
		      END
		    ELSE ERROR(2);
		    IF NOT (SY IN FSYS + [SEMICOLON,RPARENT]) THEN
		      BEGIN ERROR(7); SKIP(FSYS + [SEMICOLON,RPARENT]) END;
		  END
		ELSE ERROR(5);
		IF SY = SEMICOLON THEN
		  BEGIN INSYMBOL;
		    IF NOT (SY IN FSYS + [IDENT,VARSY]) THEN
		      BEGIN ERROR(7); SKIP(FSYS + [IDENT,RPARENT]) END
		  END
	      END (*WHILE*) ;
	    IF SY = RPARENT THEN
	      BEGIN INSYMBOL;
		IF NOT (SY IN FSY + FSYS) THEN
		  BEGIN ERROR(6); SKIP(FSY + FSYS) END
	      END
	    ELSE ERROR(4);
	    FCP^.LOCALLC := LC; LCP3 := NIL;
	    WHILE LCP1 <> NIL DO
	      WITH LCP1^ DO
		BEGIN LCP2 := NEXT; NEXT := LCP3;
		  IF (KLASS = VARS) AND (IDTYPE <> NIL) THEN
		    IF (IDTYPE^.FORM <= POWER) OR (VKIND = FORMAL) THEN
		      BEGIN VADDR := LLC;
			IF VKIND = FORMAL THEN LLC := LLC + PTRSIZE
			ELSE LLC := LLC + IDTYPE^.SIZE
		      END
		    ELSE
		      BEGIN VADDR := LC;
			LC := LC + IDTYPE^.SIZE;
			LLC := LLC + PTRSIZE
		      END;
		  LCP3 := LCP1; LCP1 := LCP2
		END;
	    FPAR := LCP3
	  END
	    ELSE FPAR := NIL
    END (*PARAMETERLIST*) ;
  
    BEGIN (*PROCDECLARATION*)
      LLC := LC; LC := LCAFTERMARKSTACK;
      IF FSY = FUNCSY THEN LC := LC + REALSIZE;
      LINEINFO := LC; DP := TRUE;
      IF SY = IDENT THEN
	BEGIN SEARCHSECTION(DISPLAY[TOP].FNAME,LCP);
	  IF LCP <> NIL THEN
	   BEGIN
	    IF LCP^.KLASS = PROC THEN
	      FORW := LCP^.FORWDECL AND (FSY = PROCSY)
		      AND (LCP^.PFKIND = ACTUAL)
	    ELSE
	      IF LCP^.KLASS = FUNC THEN
		FORW := LCP^.FORWDECL AND (FSY = FUNCSY)
			AND (LCP^.PFKIND = ACTUAL)
	      ELSE FORW := FALSE;
	    IF NOT FORW THEN ERROR(160)
	   END
	  ELSE FORW := FALSE;
	  IF NOT FORW THEN
	    BEGIN
	      IF FSY = PROCSY THEN NEW(LCP,PROC,DECLARED,ACTUAL)
	      ELSE NEW(LCP,FUNC,DECLARED,ACTUAL);
	      WITH LCP^ DO
		BEGIN NAME := ID; IDTYPE := NIL; LOCALLC := LC;
		  PFDECKIND := DECLARED; PFKIND := ACTUAL;
		  INSCOPE := FALSE; PFLEV := LEVEL;
		  PFNAME := NEXTPROC; PFSEG := SEG;
		  IF NEXTPROC = MAXPROCNUM THEN ERROR(251)
		  ELSE NEXTPROC := NEXTPROC + 1;
		  IF FSY = PROCSY THEN KLASS := PROC
		  ELSE KLASS := FUNC
		END;
	      ENTERID(LCP)
	    END
	  ELSE
	    BEGIN LCP1 := LCP^.NEXT;
	      WHILE LCP1 <> NIL DO
		BEGIN
		  WITH LCP1^ DO
		    IF KLASS = VARS THEN
		      IF IDTYPE <> NIL THEN
			BEGIN
			  IF VKIND = FORMAL THEN LCM := VADDR + PTRSIZE
			  ELSE LCM := VADDR + IDTYPE^.SIZE;
			  IF LCM > LC THEN LC := LCM
			END;
		  LCP1 := LCP1^.NEXT
		END
	      END;
	  INSYMBOL
	END
      ELSE
	BEGIN ERROR(2); LCP := UPRCPTR END;
      OLDLEV := LEVEL; OLDTOP := TOP; OLDPROC := CURPROC;
      CURPROC := LCP^.PFNAME;
      IF LEVEL < MAXLEVEL THEN LEVEL := LEVEL + 1 ELSE ERROR(251);
      IF TOP < DISPLIMIT THEN
	BEGIN TOP := TOP + 1;
	  WITH DISPLAY[TOP] DO
	    BEGIN
	      IF FORW THEN FNAME := LCP^.NEXT
	      ELSE FNAME := NIL;
	      FLABEL := NIL; FFILE := NIL; OCCUR := BLCK
	    END
	END
      ELSE ERROR(250);
      IF FSY = PROCSY THEN
	BEGIN PARAMETERLIST([SEMICOLON],LCP1,LCP);
	  IF NOT FORW THEN LCP^.NEXT := LCP1
	END
      ELSE
	BEGIN PARAMETERLIST([SEMICOLON,COLON],LCP1,LCP);
	  IF NOT FORW THEN LCP^.NEXT := LCP1;
	  IF SY = COLON THEN
	    BEGIN INSYMBOL;
	      IF SY = IDENT THEN
		BEGIN IF FORW THEN ERROR(122);
		  SEARCHID([TYPES],LCP1);
		  LSP := LCP1^.IDTYPE;
		  LCP^.IDTYPE := LSP;
		  IF LSP <> NIL THEN
		    IF NOT (LSP^.FORM IN [SCALAR,SUBRANGE,POINTER]) THEN
		      BEGIN ERROR(120); LCP^.IDTYPE := NIL END;
		  INSYMBOL
		END
	      ELSE BEGIN ERROR(2); SKIP(FSYS + [SEMICOLON]) END
	    END
	  ELSE
	    IF NOT FORW THEN ERROR(123)
	END;
      IF SY = SEMICOLON THEN INSYMBOL ELSE ERROR(14);
      IF SY = FORWARDSY THEN
	BEGIN
	  IF FORW THEN ERROR(161)
	  ELSE LCP^.FORWDECL := TRUE;
	  INSYMBOL;
	  IF SY = SEMICOLON THEN INSYMBOL ELSE ERROR(14);
	  IF NOT (SY IN FSYS) THEN
	    BEGIN ERROR(6); SKIP(FSYS) END
	END
      ELSE
	BEGIN MARK(MARKP);
	  WITH LCP^ DO
	    BEGIN FORWDECL := FALSE; INSCOPE := TRUE END;
	  REPEAT BLOCK(FSYS,SEMICOLON,LCP);
	    RELEASE(MARKP);
	    IF SY = SEMICOLON THEN
	      BEGIN INSYMBOL;
		IF NOT (SY IN [BEGINSY,PROCSY,FUNCSY,PROGSY]) THEN
		  BEGIN ERROR(6); SKIP(FSYS) END
	      END
	    ELSE ERROR(14)
    	  UNTIL SY IN [BEGINSY,PROCSY,FUNCSY,PROGSY];
	  LCP^.INSCOPE := FALSE
	END;
      LEVEL := OLDLEV; TOP := OLDTOP; LC := LLC; CURPROC := OLDPROC
    END (*PROCDECLARATION*) ;
  
    PROCEDURE SEGDECLARATION;
      VAR LSY: SYMBOL; OLDPROC: PROCRANGE; OLDSEG: SEGRANGE;
    BEGIN
      IF CODEINSEG THEN
	BEGIN ERROR(399); SEGINX := 0; CURBYTE := 0 END;
      OLDSEG := SEG; SEG := NEXTSEG; OLDPROC := NEXTPROC;
      IF NEXTSEG > MAXSEG THEN ERROR(250)
      ELSE NEXTSEG := NEXTSEG + 1;
      NEXTPROC := 1; LSY := SY;
      IF SY IN [PROCSY,FUNCSY] THEN INSYMBOL
      ELSE
	BEGIN ERROR(399); LSY := PROCSY END;
      IF SY = IDENT THEN SEGTABLE[SEG].SEGNAME := ID;
      PROCDECLARATION(LSY);
      IF CODEINSEG THEN FINISHSEG;
      NEXTPROC := OLDPROC; SEG := OLDSEG
    END (*SEGDECLARATION*) ;

    PROCEDURE BODY(FSYS: SETOFSYS);
      VAR LLC1,EXITIC: ADDRRANGE; LCP,LLCP: CTP; LOP: OPRANGE;
	  LLP: LABELP; LMIN,LMAX: INTEGER; JTINX: JTABRANGE;

    BEGIN NEXTJTAB := 1; WRITELN(OUTPUT);
      IF FPROCP = NIL THEN WRITELN(OUTPUT,'SYSTEM')
      ELSE
	BEGIN WRITELN(OUTPUT,FPROCP^.NAME);
	  LLC1 := FPROCP^.LOCALLC; LCP := FPROCP^.NEXT;
	  WHILE LCP <> NIL DO
	    WITH LCP^ DO
	      BEGIN
		IF KLASS = VARS THEN
		  IF IDTYPE <> NIL THEN
		    IF (VKIND = ACTUAL) AND (IDTYPE^.FORM > POWER) THEN
		      BEGIN LLC1 := LLC1 - PTRSIZE;
			GEN2(50(*LDA*),0,VADDR);
			GEN2(54(*LOD*),0,LLC1);
			IF PAOFCHAR(IDTYPE) THEN
			  WITH IDTYPE^ DO
			    IF AISSTRNG THEN GEN1(42(*SAS*),MAXLENG)
			    ELSE
			      IF INXTYPE <> NIL THEN
				BEGIN GETBOUNDS(INXTYPE,LMIN,LMAX);
				  GEN1(41(*MVB*),LMAX - LMIN + 1)
				END
			      ELSE
			ELSE GEN1(40(*MOV*),IDTYPE^.SIZE)
		      END
		    ELSE
		      IF VKIND = FORMAL THEN LLC1 := LLC1 - PTRSIZE
		      ELSE LLC1 := LLC1 - IDTYPE^.SIZE;
		LCP := NEXT
	      END;
	END;
      WRITE(OUTPUT,'<',SCREENDOTS:4,'>');
      STARTDOTS := SCREENDOTS;
      LCMAX := LC;
      LLP := DISPLAY[TOP].FLABEL;
      WHILE LLP <> NIL DO
	BEGIN GENLABEL(LLP^.CODELBP);
	  LLP := LLP^.NEXTLAB
	END;
      LCP := DISPLAY[TOP].FFILE;
      WHILE LCP <> NIL DO
	WITH LCP^,IDTYPE^ DO
	  BEGIN
	    GEN2(50(*LDA*),0,VADDR);
	    GEN2(50(*LDA*),0,VADDR+FILESIZE);
	    IF FILTYPE = NIL THEN GENLDC(-1)
	    ELSE
	      IF FILTYPE = CHARPTR THEN GENLDC(0)
	      ELSE GENLDC(FILTYPE^.SIZE);
	    GEN2(77(*CXP*),0(*SYS*),3(*FINIT*));
	    LCP := NEXT
	  END;
      REPEAT
	REPEAT STATEMENT(FSYS + [SEMICOLON,ENDSY])
	UNTIL NOT (SY IN STATBEGSYS);
	TEST := SY <> SEMICOLON;
	IF NOT TEST THEN INSYMBOL
      UNTIL TEST;
      IF SY = ENDSY THEN INSYMBOL ELSE ERROR(13);
      EXITIC := IC;
      LCP := DISPLAY[TOP].FFILE;
      WHILE LCP <> NIL DO
	WITH LCP^ DO
	  BEGIN
	    GEN2(50(*LDA*),0,VADDR);
	    GENLDC(0); GEN2(77(*CXP*),0(*SYS*),6(*FCLOSE*));
	    LCP := NEXT
	  END;
      IF FPROCP = NIL THEN GEN0(86(*XIT*))
      ELSE
	BEGIN
	  IF FPROCP^.PFLEV = 0 THEN LOP := 65(*RBP*)
	  ELSE LOP := 45(*RNP*);
	  IF FPROCP^.IDTYPE = NIL THEN GEN1(LOP,0)
	  ELSE GEN1(LOP,FPROCP^.IDTYPE^.SIZE)
	END;
      LLP := DISPLAY[TOP].FLABEL;  (* CHECK UNDEFINED LABELS *)
      WHILE LLP <> NIL DO
	WITH LLP^,CODELBP^ DO
	  BEGIN
	    IF NOT DEFINED THEN
	      IF REFLIST <> MAXADDR THEN ERROR(168);
	    LLP := NEXTLAB
	  END;
      JTINX := NEXTJTAB - 1;
      IF ODD(IC) THEN IC := IC + 1;
      WHILE JTINX > 0 DO
	BEGIN GENWORD(IC-JTAB[JTINX]); JTINX := JTINX-1 END;
      IF FPROCP = NIL THEN
	BEGIN GENWORD((LCMAX-LCAFTERMARKSTACK)*2); GENWORD(0) END
      ELSE
	WITH FPROCP^ DO
	  BEGIN GENWORD((LCMAX-LOCALLC)*2);
	    GENWORD((LOCALLC-LCAFTERMARKSTACK)*2)
	  END;
      GENWORD(IC-EXITIC); GENWORD(IC);
      GENBYTE(CURPROC); GENBYTE(LEVEL-1);
      IF NOT CODEINSEG THEN
	BEGIN CODEINSEG := TRUE;
	  SEGTABLE[SEG].DISKADDR := CURBLK
	END;
      WRITECODE(FALSE);
      SEGINX := SEGINX + IC;
      PROCTABLE[CURPROC] := SEGINX - 2
    END (*BODY*) ;

  PROCEDURE FINDFORW(FCP: CTP);
  BEGIN
    IF FCP <> NIL THEN
      WITH FCP^ DO
	BEGIN
	  IF KLASS IN [PROC,FUNC] THEN
	    IF PFDECKIND = DECLARED THEN
	      IF PFKIND = ACTUAL THEN
		IF FORWDECL THEN
		  BEGIN
		    USERINFO.ERRNUM := 117; WRITELN(OUTPUT);
		    WRITE(OUTPUT,NAME,' undefined')
		  END;
	  FINDFORW(RLINK); FINDFORW(LLINK)
	END
  END (*FINDFORW*) ;

  BEGIN (*BLOCK*)
    REPEAT
      IF SY = LABELSY THEN
	BEGIN INSYMBOL; LABELDECLARATION END;
      IF SY = CONSTSY THEN
	BEGIN INSYMBOL; CONSTDECLARATION END;
      IF SY = TYPESY THEN
	BEGIN INSYMBOL; TYPEDECLARATION END;
      IF SY = VARSY THEN
	BEGIN INSYMBOL; VARDECLARATION END;
      WHILE SY IN [PROCSY,FUNCSY,PROGSY] DO
	BEGIN LSY := SY; INSYMBOL;
	  IF LSY = PROGSY THEN SEGDECLARATION
	  ELSE PROCDECLARATION(LSY)
	END;
      IF SY <> BEGINSY THEN
	IF NOT (INCLUDING AND
	    (SY IN [LABELSY,CONSTSY,TYPESY,VARSY,PROCSY,FUNCSY,PROGSY])) THEN
	  BEGIN ERROR(18); SKIP(FSYS) END
    UNTIL SY IN STATBEGSYS;
    DP := FALSE; IC := 0; LINEINFO := 0;
    IF SY = BEGINSY THEN INSYMBOL ELSE ERROR(17);
    IF NOT SYSCOMP THEN FINDFORW(DISPLAY[TOP].FNAME);
    REPEAT BODY(FSYS + [CASESY]);
      IF SY <> FSY THEN
	BEGIN ERROR(6); SKIP(FSYS + [FSY]) END
    UNTIL (SY = FSY) OR (SY IN BLOCKBEGSYS);
  END (*BLOCK*) ;

BEGIN (*COMPILER*)
  COMPINIT; TIME(LGTH,LOWTIME);
  BLOCK(BLOCKBEGSYS+STATBEGSYS-[CASESY],PERIOD,OUTERBLOCK);
  IF SY <> PERIOD THEN ERROR(21);
  IF LIST THEN
    BEGIN SCREENDOTS := SCREENDOTS+1;
      SYMBUFP^[SYMCURSOR] := CHR(EOL);
      SYMCURSOR := SYMCURSOR+1; PRINTLINE
    END;
  FINISHSEG;
  TIME(LGTH,STARTDOTS); LOWTIME := STARTDOTS-LOWTIME;
  UNITWRITE(3,IC,7); WRITELN(OUTPUT);
  WRITE(OUTPUT,SCREENDOTS,' lines');
  IF LOWTIME > 0 THEN
    WRITE(OUTPUT,', ',(LOWTIME+30) DIV 60,' secs, ',
	ROUND((3600/LOWTIME)*SCREENDOTS),' lines/min');
  IC := 0;
  FOR SEG := 0 TO MAXSEG DO
    WITH SEGTABLE[SEG] DO
      BEGIN GENWORD(DISKADDR); GENWORD(CODELENG) END;
  FOR SEG := 0 TO MAXSEG DO
    WITH SEGTABLE[SEG] DO
      FOR LGTH := 1 TO 8 DO
	GENBYTE(ORD(SEGNAME[LGTH]));
  CURBLK := 0; CURBYTE := 0; WRITECODE(TRUE)
END (*COMPILE*) ;

BEGIN END.

========================================================================================
DOCUMENT :usus Folder:VOL17:filer.text
========================================================================================


SEGMENT PROCEDURE USERPROGRAM;
BEGIN END;

SEGMENT PROCEDURE COMPILER;
  SEGMENT PROCEDURE COMPINIT;
  BEGIN END;
BEGIN END;

SEGMENT PROCEDURE EDITOR;
BEGIN END;

SEGMENT PROCEDURE FILEHANDLER;
  VAR GCH: CHAR; GDIR: DIRP; GINX: DIRRANGE;
      BADCOMMAND: BOOLEAN; GSEGS: INTEGER; GKIND: FILEKIND;
      GUNIT: UNITNUM; GBUF: WINDOWP; GBUFBLKS: INTEGER;
      SYMSAVED,CODESAVED: BOOLEAN; (*WORKFILE INFO...HANDY*)
      GVID: VID; GTID: TID; GS: STRING;
      GVIDTID: STRING[25]; GTITLE: STRING[39]; INSTRING: STRING[127];
      GFIB: FIB; MONTHS: ARRAY [0..15] OF STRING[3];

  PROCEDURE FILERINIT;
    TYPE ABLOCK = PACKED ARRAY [1..FBLKSIZE] OF CHAR;
    VAR ONEBLOCK: ^ABLOCK;
	GAPSIZE,QUITSIZE: INTEGER;
  BEGIN
    SYMSAVED := TRUE; CODESAVED := TRUE;
    WITH USERINFO DO
      BEGIN
	IF GOTSYM THEN SYMSAVED := SYMTID <> 'SYSTEM.WRK.TEXT';
	IF GOTCODE THEN CODESAVED := CODETID <> 'SYSTEM.WRK.CODE'
      END;
    MONTHS[ 0] := 'XXX'; (*LEAVE THIS LINE IN!*)
    MONTHS[ 1] := 'JAN'; MONTHS[ 2] := 'FEB'; MONTHS[ 3] := 'MAR';
    MONTHS[ 4] := 'APR'; MONTHS[ 5] := 'MAY'; MONTHS[ 6] := 'JUN';
    MONTHS[ 7] := 'JUL'; MONTHS[ 8] := 'AUG'; MONTHS[ 9] := 'SEP';
    MONTHS[10] := 'OCT'; MONTHS[11] := 'NOV'; MONTHS[12] := 'DEC'; 
    MONTHS[13] := 'BAD'; MONTHS[14] := 'BAD'; MONTHS[15] := 'BAD'; 
    BADCOMMAND := FALSE; FINIT(GFIB,NIL,-1);
    MARK(GBUF); GBUFBLKS := 0;
    QUITSIZE := SIZEOF(DIRECTORY)+SIZEOF(FIB)+1400;
    REPEAT
      NEW(ONEBLOCK); GBUFBLKS := GBUFBLKS+1;
      GAPSIZE := ORD(SYSCOM^.LASTMP)-ORD(ONEBLOCK)-FBLKSIZE
    UNTIL ((GAPSIZE > 0) AND (GAPSIZE < QUITSIZE))
	OR (GBUFBLKS = 63); (*PREVENT INTEGER OFLOW*)
  END (*FILERINIT*) ;

  FUNCTION CHECKRSLT(RSLT: INTEGER): BOOLEAN;
  BEGIN
    CHECKRSLT := RSLT = 0;
    CASE RSLT OF
      1:  WRITE(OUTPUT,'Hard parity (CRC) error');
      2:  WRITE(OUTPUT,'Illegal unit number');
      3:  WRITE(OUTPUT,'Illegal operation on unit');
      4:  WRITE(OUTPUT,'Undefined hardware error');
      5:  WRITE(OUTPUT,'Volume has gone off-line');
      6:  WRITE(OUTPUT,'File lost in directory');
      7:  WRITE(OUTPUT,'Illegal file name');
      8:  WRITE(OUTPUT,'Insufficient space on volume');
      9:  WRITE(OUTPUT,'No such volume on-line');
     10:  WRITE(OUTPUT,'No such file on volume');
     11:  WRITE(OUTPUT,'Duplicate directory entries');
     12:  WRITE(OUTPUT,'Filer bug!!  not closed file')
    END
  END (* CHECKRSLT *) ;

  FUNCTION GETTITLE(MSG: STRING): BOOLEAN;
    VAR I: INTEGER;
  BEGIN GETTITLE := FALSE; GVIDTID := ''; GTITLE := '';
    IF LENGTH(INSTRING) = 0 THEN
      BEGIN WRITE(OUTPUT,MSG);
	IF NOT SYSCOM^.MISCINFO.SLOWTERM THEN
	  WRITE(OUTPUT,' what file');
	WRITE(OUTPUT,'? '); READLN(INPUT,INSTRING)
      END;
    IF LENGTH(INSTRING) > 0 THEN
      BEGIN
	I := SCAN(LENGTH(INSTRING), = ',', INSTRING[1]);
	IF I < LENGTH(INSTRING) THEN
	  BEGIN
	    GTITLE := COPY(INSTRING,1,I);
	    DELETE(INSTRING,1,I+1)
	  END
	ELSE
	  BEGIN
	    GTITLE := INSTRING;
	    INSTRING := ''
	  END;
	IF SCANTITLE(GTITLE,GVID,GTID,GSEGS,GKIND) THEN
	  BEGIN GETTITLE := TRUE;
	    GVIDTID := CONCAT(GVID,':',GTID)
	  END
	ELSE
	  WRITE(OUTPUT,'Illegal file name')
      END
  END (* GETTITLE *) ;

  FUNCTION GETVOLUME(LOOKHARD: BOOLEAN): BOOLEAN;
    LABEL 1;
  BEGIN GETVOLUME := FALSE;
    WRITE(OUTPUT,GS); READLN(INPUT,GS);
    INSERT(':',GS,LENGTH(GS)+1);
    IF SCANTITLE(GS,GVID,GTID,GSEGS,GKIND) THEN
      BEGIN
	GUNIT := VOLSEARCH(GVID,LOOKHARD,GDIR);
	GETVOLUME := GUNIT > 0;
	IF GUNIT = 0 THEN
	  WRITE(OUTPUT,GVID,': is not on-line')
	ELSE
	  IF LOOKHARD AND NOT UNITABLE[GUNIT].UISBLKD THEN
	    BEGIN GETVOLUME := FALSE;
	      WRITE(OUTPUT,GVID,': does not have a directory')
	    END
      END
    ELSE
      WRITE(OUTPUT,'Illegal volume name')
  END (*GETVOLUME*) ;

  PROCEDURE WHATWORK;
  BEGIN
    WITH USERINFO DO
      BEGIN WRITELN(OUTPUT);
	IF GOTSYM OR GOTCODE THEN
	  BEGIN WRITE(OUTPUT,'Workfile is ');
	    IF LENGTH(WORKTID) > 0 THEN
	      WRITE(OUTPUT,WORKTID)
	    ELSE
	      WRITE(OUTPUT,'not named');
	    IF NOT (SYMSAVED AND CODESAVED) THEN
	      WRITE(OUTPUT,' (not saved)')
	  END
	ELSE
	  WRITE(OUTPUT,'No workfile')
      END
  END (*WHATWORK*) ;

  PROCEDURE NEWWORK(GIVEBLURB: BOOLEAN);
    LABEL 1;
  BEGIN
    WITH USERINFO DO
      BEGIN
	IF NOT (SYMSAVED AND CODESAVED) THEN
	  BEGIN
	    WRITE(OUTPUT,'Throw away current workfile? ');
	    IF GETCHAR(FALSE) <> 'Y' THEN GOTO 1;
	    IF NOT GIVEBLURB THEN WRITELN(OUTPUT)
	  END;
	IF NOT SYMSAVED THEN
	  BEGIN
	    GS := '*SYSTEM.WRK.TEXT';
	    FOPEN(GFIB,GS,TRUE,NIL);
	    FCLOSE(GFIB,CPURGE)
	  END;
	IF NOT CODESAVED THEN
	  BEGIN
	    GS := '*SYSTEM.WRK.CODE';
	    FOPEN(GFIB,GS,TRUE,NIL);
	    FCLOSE(GFIB,CPURGE)
	  END;
	SYMSAVED := TRUE; CODESAVED := TRUE;
	GOTSYM := FALSE; GOTCODE := FALSE;
	WORKTID := ''; SYMTID := ''; CODETID := '';
	IF GIVEBLURB THEN
	  BEGIN WRITELN(OUTPUT);
	    WRITE(OUTPUT,'Empty workfile created')
	  END
      END;
1:
  END (*NEWWORK*) ;

  PROCEDURE GETWORK;
  BEGIN
    NEWWORK(FALSE);
    WITH USERINFO DO
      IF NOT (GOTSYM OR GOTCODE) THEN
	IF GETTITLE('Get') THEN
	  IF (LENGTH(GTID) > 0) AND (LENGTH(GTID) <= TIDLENG-5) THEN
	    BEGIN
	      WORKVID := GVID; WORKTID := GTID;
	      SYMTID := CONCAT(GTID,'.TEXT'); SYMVID := GVID;
	      GVIDTID := CONCAT(SYMVID,':',SYMTID);
	      FOPEN(GFIB,GVIDTID,TRUE,NIL);
	      GOTSYM := GFIB.FISOPEN;
	      IF GOTSYM THEN FCLOSE(GFIB,CNORMAL)
	      ELSE SYMTID := '';
	      CODETID := CONCAT(GTID,'.CODE'); CODEVID := GVID;
	      GVIDTID := CONCAT(CODEVID,':',CODETID);
	      FOPEN(GFIB,GVIDTID,TRUE,NIL);
	      GOTCODE := GFIB.FISOPEN;
	      IF GOTCODE THEN FCLOSE(GFIB,CNORMAL)
	      ELSE CODETID := '';
	      IF GOTSYM THEN WRITE(OUTPUT,'Text ');
	      IF GOTSYM AND GOTCODE THEN
		WRITE(OUTPUT,'and ');
	      IF GOTCODE THEN WRITE(OUTPUT,'Code ');
	      IF NOT (GOTSYM OR GOTCODE) THEN
		BEGIN WORKTID := '';
		  WRITE(OUTPUT,'No ')
		END;
	      WRITE(OUTPUT,'file loaded')
	    END
	  ELSE
	    BEGIN WORKTID := '';
	      WRITE(OUTPUT,'Illegal workfile name')
	    END
  END (*GETWORK*) ;

  PROCEDURE SAVEWORK;
    LABEL 1;
    VAR GETNEWTID: BOOLEAN;
  BEGIN
    WITH USERINFO DO
      BEGIN
	IF SYMSAVED AND CODESAVED THEN
	  BEGIN WRITELN(OUTPUT);
	    IF GOTSYM OR GOTCODE THEN
	      WRITE(OUTPUT,'Workfile already saved')
	    ELSE
	      WRITE(OUTPUT,'No workfile to save');
	    GOTO 1
	  END;
	IF WORKVID <> SYVID THEN WORKTID := '';
	GETNEWTID := LENGTH(WORKTID) = 0;
	IF NOT GETNEWTID THEN
	  BEGIN
	    WRITE(OUTPUT,'Save as ',WORKTID,'? ');
	    GETNEWTID := GETCHAR(TRUE) <> 'Y';
	    WRITELN(OUTPUT)
	  END;
	IF GETNEWTID THEN
	  IF GETTITLE('Save as') THEN
	    BEGIN WORKVID := GVID; WORKTID := GTID END
	  ELSE GOTO 1;
	IF (LENGTH(WORKTID) = 0) OR (LENGTH(WORKTID) > TIDLENG-5) THEN
	  BEGIN WORKTID := '';
	    WRITE(OUTPUT,'Illegal workfile name');
	    GOTO 1
	  END;
	IF WORKVID <> SYVID THEN
	  BEGIN WORKTID := '';
	    WRITE(OUTPUT,'Must save on system disk for now');
	    GOTO 1
	  END;
	IF NOT SYMSAVED THEN
	  BEGIN
	    GTITLE := '*SYSTEM.WRK.TEXT';
	    FOPEN(GFIB,GTITLE,TRUE,NIL);
	    IF GFIB.FISOPEN THEN
	     WITH GFIB.FHEADER DO
	      BEGIN
		DACCESS.YEAR := 100;
		SYMTID := CONCAT(WORKTID,'.TEXT');
		DTID := SYMTID;
		FCLOSE(GFIB,CNORMAL)
	      END
	    ELSE
	      BEGIN GOTSYM := FALSE;
		WRITELN(OUTPUT,'Lost workfile!')
	      END;
	    SYMSAVED := TRUE;
	    WRITE(OUTPUT,'Text ');
	    IF NOT CODESAVED THEN
	      WRITE(OUTPUT,'and ')
	  END;
	IF NOT CODESAVED THEN
	  BEGIN
	    GTITLE := '*SYSTEM.WRK.CODE';
	    FOPEN(GFIB,GTITLE,TRUE,NIL);
	    IF GFIB.FISOPEN THEN
	     WITH GFIB.FHEADER DO
	      BEGIN
		DACCESS.YEAR := 100;
		CODETID := CONCAT(WORKTID,'.CODE');
		DTID := CODETID;
		FCLOSE(GFIB,CNORMAL)
	      END
	    ELSE
	      BEGIN GOTCODE := FALSE;
		WRITE(OUTPUT,'Lost workfile!')
	      END;
	    CODESAVED := TRUE;
	    WRITE(OUTPUT,'Code ')
	  END;
	WRITE(OUTPUT,'file saved')
      END;
1:
  END (*SAVEWORK*) ;

  PROCEDURE PREFIXER;
  BEGIN
    GS := 'Default prefix volume name? ';
    IF NOT GETVOLUME(TRUE) THEN WRITELN(OUTPUT);
    DKVID := GVID;
    WRITE(OUTPUT,'Default prefix is ',DKVID,':')
  END (*PREFIXER*) ;

  PROCEDURE CHANGER;
    VAR LFIB: FIB;
  BEGIN
    REPEAT
      IF GETTITLE('Change') THEN
	BEGIN FOPEN(GFIB,GVIDTID,TRUE,NIL);
	  IF CHECKRSLT(IORESULT) THEN
	    BEGIN
	      IF GETTITLE('To') THEN
		WITH GFIB DO
		  BEGIN FINIT(LFIB,NIL,-1);
		    IF FISBLKD AND (LENGTH(FHEADER.DTID) > 0) THEN
		      BEGIN GVID := FVID;
			GVIDTID := CONCAT(GVID,':',GTID)
		      END;
		    FOPEN(LFIB,GVIDTID,TRUE,NIL);
		    IF FISBLKD AND (LENGTH(FHEADER.DTID) > 0) THEN
		      IF LENGTH(GTID) = 0 THEN
			WRITE(OUTPUT,'Must specify both titles')
		      ELSE
			BEGIN
			  IF LFIB.FISOPEN THEN
			    BEGIN
			      WRITE(OUTPUT,GTID,' exists...remove it? ');
			      IF GETCHAR(TRUE) = 'Y' THEN
				BEGIN
				  FCLOSE(LFIB,CNORMAL);
				  WRITELN(OUTPUT)
				END
			    END;
			  IF NOT LFIB.FISOPEN THEN
			    BEGIN
			      WRITE(OUTPUT,FVID,':',FHEADER.DTID,
				  ' changed to ',GTID);
			      FHEADER.DTID := GTID;
			      FHEADER.DACCESS.YEAR := 100
			    END
			END
		    ELSE
		      IF LENGTH(GTID) > 0 THEN
			WRITE(OUTPUT,'No title may be specified')
		      ELSE
			IF LFIB.FISOPEN THEN
			  WRITE(OUTPUT,'No duplicate volume names')
			ELSE
			  BEGIN
			    UNITABLE[FUNIT].UVID := GVID;
			    IF FISBLKD THEN
			      BEGIN (*CHANGE VOLUME NAME IN DIR*)
				NEW(GDIR);
				UNITREAD(FUNIT,GDIR^,SIZEOF(DIRECTORY),DIRBLK);
				GDIR^[0].DVID := GVID;
				UNITWRITE(FUNIT,GDIR^,(GDIR^[0].DNUMFILES+1)
					*SIZEOF(DIRENTRY),DIRBLK);
				RELEASE(GDIR)
			      END;
			    WRITE(OUTPUT,FVID,': changed to ',GVID,':');
			    FVID := GVID
			  END;
		    FCLOSE(LFIB,CNORMAL)
		  END;
	      FCLOSE(GFIB,CNORMAL)
	    END
	END;
      IF LENGTH(INSTRING) > 0 THEN WRITELN(OUTPUT)
    UNTIL LENGTH(INSTRING) = 0
  END (*CHANGER*) ;

  PROCEDURE REMOVER;
  BEGIN
    REPEAT
      IF GETTITLE('Remove') THEN
	BEGIN FOPEN(GFIB,GTITLE,TRUE,NIL);
	  IF CHECKRSLT(IORESULT) THEN
	    BEGIN FCLOSE(GFIB,CPURGE);
	      IF CHECKRSLT(IORESULT) THEN
		WRITE(OUTPUT,GVIDTID,' removed')
	    END
	END;
      IF LENGTH(INSTRING) > 0 THEN WRITELN(OUTPUT)
    UNTIL LENGTH(INSTRING) = 0
  END (*REMOVER*) ;

  PROCEDURE TRANSFER;
    VAR NBLOCKS,RSLT: INTEGER;
	LFIB: FIB;
  BEGIN
    REPEAT
      IF GETTITLE('Transfer') THEN
	BEGIN FOPEN(GFIB,GTITLE,TRUE,NIL);
	  IF CHECKRSLT(IORESULT) THEN
	    BEGIN
	      NBLOCKS := FBLOCKIO(GFIB,GBUF^,GBUFBLKS,-1,TRUE);
	      IF CHECKRSLT(IORESULT) THEN
		IF GETTITLE('To') THEN
		  BEGIN FINIT(LFIB,NIL,-1);
		    FOPEN(LFIB,GTITLE,FALSE,NIL);
		    IF CHECKRSLT(IORESULT) THEN
		      BEGIN
			WHILE NBLOCKS > 0 DO
			  BEGIN
			    RSLT := FBLOCKIO(LFIB,GBUF^,NBLOCKS,
					      -1,FALSE);
			    IF RSLT = NBLOCKS THEN
			      IF GFIB.FEOF THEN NBLOCKS := 0
			      ELSE
				BEGIN
				  NBLOCKS := FBLOCKIO(GFIB,GBUF^,GBUFBLKS,
							-1,TRUE);
				  IF NOT CHECKRSLT(IORESULT) THEN
				    BEGIN NBLOCKS := 0;
				      FCLOSE(LFIB,CPURGE)
				    END
				END
			    ELSE
			      BEGIN NBLOCKS := 0;
				FCLOSE(LFIB,CPURGE);
				WRITE(OUTPUT,'Output file full')
			      END
			  END;
			IF LFIB.FISOPEN THEN
			  BEGIN
			    WRITE(OUTPUT,GFIB.FVID,':',GFIB.FHEADER.DTID,
				' transferred to ',LFIB.FVID,
				':',LFIB.FHEADER.DTID);
			    WITH LFIB,GFIB.FHEADER DO
			      BEGIN
				FHEADER.DLASTBYTE := DLASTBYTE;
				FHEADER.DFKIND := DFKIND;
				FHEADER.DACCESS := DACCESS;
				IF (DACCESS.MONTH = 0) AND
				   (THEDATE.MONTH > 0) THEN
				  FHEADER.DACCESS := THEDATE
			      END;
			    FCLOSE(LFIB,CLOCK)
			  END
		      END
		  END;
	      FCLOSE(GFIB,CNORMAL)
	    END
	END;
      IF LENGTH(INSTRING) > 0 THEN WRITELN(OUTPUT)
    UNTIL LENGTH(INSTRING) = 0
  END (*TRANSFER*) ;

  PROCEDURE MAKEFILE;
  BEGIN
    REPEAT
      IF GETTITLE('Make') THEN
	BEGIN FOPEN(GFIB,GTITLE,FALSE,NIL);
	  IF CHECKRSLT(IORESULT) THEN
	    BEGIN
	      WITH GFIB DO
		FMAXBLK := FHEADER.DLASTBLK-FHEADER.DFIRSTBLK;
	      FCLOSE(GFIB,CLOCK);
	      IF CHECKRSLT(IORESULT) THEN
		WRITE(OUTPUT,GVIDTID,' created')
	    END
	END;
      IF LENGTH(INSTRING) > 0 THEN WRITELN(OUTPUT)
    UNTIL LENGTH(INSTRING) = 0
  END (*MAKEFILE*) ;

  PROCEDURE LISTDIR(DETAIL: BOOLEAN);
    VAR I: DIRRANGE;
	LINE,LARGEST,FREEBLKS,USEDAREA,USEDBLKS: INTEGER;

    PROCEDURE WRITELINE;
    BEGIN
      IF LINE = SYSCOM^.CRTINFO.HEIGHT THEN
	BEGIN
	  IF SPACEWAIT THEN EXIT(LISTDIR);
	  CLEARSCREEN; LINE := 2;
	  WRITELN(OUTPUT);
	  WRITE(OUTPUT,GVID,':')
	END;
      LINE := LINE+1; WRITELN(OUTPUT)
    END (*WRITELINE*) ;

    PROCEDURE FREECHECK(FIRSTOPEN,NEXTUSED: INTEGER);
      VAR FREEAREA: INTEGER;
    BEGIN
      FREEAREA := NEXTUSED-FIRSTOPEN;
      IF FREEAREA > LARGEST THEN LARGEST := FREEAREA;
      IF FREEAREA > 0 THEN
	BEGIN FREEBLKS := FREEBLKS+FREEAREA;
	  IF DETAIL THEN
	    BEGIN
	      WRITE(OUTPUT,'< UNUSED >      ',
			FREEAREA:4,' ':11,FIRSTOPEN:6);
	      WRITELINE
	    END
	END;
    END (*FREECHECK*) ;

  BEGIN (*LISTDIR*)
    GS := 'Directory of what volume? ';
    IF GETVOLUME(TRUE) THEN
      BEGIN
	FREEBLKS := 0; USEDBLKS := 0;
	LARGEST := 0; LINE := 3;
	WRITELN(OUTPUT,GVID,':');
	FOR I := 1 TO GDIR^[0].DNUMFILES DO
	  WITH GDIR^[I] DO
	    BEGIN
	      FREECHECK(GDIR^[I-1].DLASTBLK,DFIRSTBLK);
	      USEDAREA := DLASTBLK-DFIRSTBLK;
	      USEDBLKS := USEDBLKS+USEDAREA;
	      WRITE(OUTPUT,DTID,' ':TIDLENG-LENGTH(DTID)+1,USEDAREA:4);
	      IF DACCESS.MONTH > 0 THEN
		WRITE(OUTPUT,' ':2,DACCESS.DAY:2,'-',
			MONTHS[DACCESS.MONTH],'-',DACCESS.YEAR:2);
	      IF DETAIL THEN
		BEGIN
		  IF DACCESS.MONTH = 0 THEN WRITE(OUTPUT,' ':11);
		  WRITE(OUTPUT,DFIRSTBLK:6,DLASTBYTE:6);
		  GS := 'ILLEGAL';
		  CASE DFKIND OF
		    XDSKFILE: GS := 'Bad disk';
		    CODEFILE: GS := 'Codefile';
		    TEXTFILE: GS := 'Textfile';
		    INFOFILE: GS := 'Infofile';
		    DATAFILE: GS := 'Datafile';
		    GRAFFILE: GS := 'Graffile';
		    FOTOFILE: GS := 'Fotofile'
		  END;
		  WRITE(OUTPUT,' ':2,GS)
		END;
	      WRITELINE
	    END;
	FREECHECK(GDIR^[I-1].DLASTBLK,GDIR^[0].DEOVBLK);
	WRITE(OUTPUT,GDIR^[0].DNUMFILES,' files, ',
			USEDBLKS,' blocks in use, ',
			FREEBLKS,' unused');
	IF DETAIL THEN
	  WRITE(OUTPUT,', ',LARGEST,' in largest area')
      END
  END (*LISTDIR*) ;

  PROCEDURE LISTVOLS;
  BEGIN
    WRITELN(OUTPUT,'Volumes currently on-line:');
    GVID := '';
    GUNIT := VOLSEARCH(GVID,TRUE,GDIR);
    FOR GUNIT := 1 TO MAXUNIT DO
     WITH UNITABLE[GUNIT] DO
      IF LENGTH(UVID) > 0 THEN
	BEGIN
	  WRITE(OUTPUT,GUNIT:3);
	  IF UVID = SYVID THEN WRITE(OUTPUT,' * ')
	  ELSE
	    IF UVID = DKVID THEN WRITE(OUTPUT,' P ')
	    ELSE
	      IF UISBLKD THEN WRITE(OUTPUT,' # ')
	      ELSE WRITE(OUTPUT,'   ');
	  WRITELN(OUTPUT,UVID,':')
	END
  END (*LISTVOLS*) ;

  PROCEDURE BADBLOCKS;
    VAR I: INTEGER;
	A: PACKED ARRAY [0..FBLKSIZE] OF CHAR;
  BEGIN
    GS := 'Bad blocks of what volume? ';
    IF GETVOLUME(TRUE) THEN
      FOR I := 0 TO GDIR^[0].DEOVBLK-1 DO
	BEGIN
	  UNITREAD(GUNIT,A,FBLKSIZE,I);
	  IF SYSCOM^.IORSLT <> INOERROR THEN
	    WRITELN(OUTPUT,'Block ',I,' is bad')
	END
  END (*BADBLOCKS*) ;

  PROCEDURE ZEROVOLUME;
    LABEL 1;
    VAR LDE: DIRENTRY;
  BEGIN
    GUNIT := 0;
    WRITE(OUTPUT,'Zero what unit? ');
    READ(INPUT,GUNIT);
    IF NOT EOLN(INPUT) THEN WRITELN(OUTPUT);
    IF (GUNIT <= 0) OR (GUNIT > MAXUNIT) THEN
      BEGIN
	WRITE(OUTPUT,'Illegal unit #');
	GOTO 1
      END;
    IF NOT UNITABLE[GUNIT].UISBLKD THEN
      BEGIN
	WRITE(OUTPUT,'Unit cannot be zeroed');
	GOTO 1
      END;
    WRITE(OUTPUT,'New volume name (<CR> to escape)? ');
    READLN(INPUT,GVID);
    IF LENGTH(GVID) = 0 THEN GOTO 1;
    WITH LDE DO
      BEGIN
	DFIRSTBLK := 0; DLASTBLK := 6;
	DFKIND := UNTYPEDFILE; DVID := GVID;
	DEOVBLK := -1; DNUMFILES := 0;
	WRITE(OUTPUT,'Number of blocks on volume? ');
	READ(INPUT,DEOVBLK);
	IF NOT EOLN(INPUT) THEN WRITELN(OUTPUT);
	IF DEOVBLK <= 0 THEN
	  BEGIN
	    WRITE(OUTPUT,'Illegal number of blocks');
	    GOTO 1
	  END;
	UNITWRITE(GUNIT,LDE,SIZEOF(LDE),DIRBLK);
	WRITE(OUTPUT,GVID,': zeroed')
      END;
1:
  END (*ZEROVOLUME*) ;

  PROCEDURE DATESET;
    LABEL 1;
    VAR MONINDX,DAYNUM,YEARNUM,I: INTEGER;
	OK: BOOLEAN; CH: CHAR;
	DELIMS: SET OF ' '..'/';

    FUNCTION EATSPACES: BOOLEAN;
      VAR DONE: BOOLEAN;
    BEGIN
      IF LENGTH(GS) > 0 THEN
	REPEAT
	  DONE := GS[1] <> ' ';
	  IF NOT DONE THEN DELETE(GS,1,1)
	UNTIL DONE OR (LENGTH(GS) = 0);
      EATSPACES := LENGTH(GS) = 0
    END (*EATSPACES*) ;

  BEGIN (*DATESET*)
    DELIMS := [' ','-','/'];
    PL := 'DATESET:  <1..31>-<JAN..DEC>-<00..99>  OR <CR>';
    PROMPT; WRITELN(OUTPUT);
    WITH THEDATE DO
      IF MONTH = 0 THEN WRITELN(OUTPUT,'No current date')
      ELSE
	WRITELN(OUTPUT,'Today is ',DAY:2,'-',MONTHS[MONTH],'-',YEAR:2);
    WRITE(OUTPUT,'New date? '); READLN(INPUT,GS);
    IF EATSPACES THEN EXIT(DATESET);
    DAYNUM := 0;
    REPEAT
      OK := GS[1] IN ['0'..'9'];
      IF OK THEN
	BEGIN
	  DAYNUM := DAYNUM*10+ORD(GS[1])-ORD('0');
	  OK := DAYNUM <= 9; DELETE(GS,1,1)
	END
    UNTIL (LENGTH(GS) = 0) OR NOT OK;
    IF (DAYNUM < 1) OR (DAYNUM > 31) THEN GOTO 1;
    IF EATSPACES THEN GOTO 1;
    IF NOT (GS[1] IN DELIMS) THEN GOTO 1;
    DELETE(GS,1,1);
    IF EATSPACES OR (LENGTH(GS) < 3) THEN GOTO 1;
    MONINDX := 12;
    FOR I := 1 TO 3 DO
      BEGIN
	CH := GS[I];
	IF CH >= 'a' THEN
	  CH := CHR(ORD(CH)-ORD('a')+ORD('A'));
	MONTHS[0,I] := CH
      END;
    WHILE MONTHS[MONINDX] <> MONTHS[0] DO
      MONINDX := MONINDX-1;
    IF MONINDX = 0 THEN GOTO 1;
    DELETE(GS,1,3);
    IF EATSPACES THEN GOTO 1;
    IF NOT (GS[1] IN DELIMS) THEN GOTO 1;
    DELETE(GS,1,1);
    IF EATSPACES THEN GOTO 1;
    YEARNUM := 0;
    REPEAT
      OK := GS[1] IN ['0'..'9'];
      IF OK THEN
	BEGIN
	  YEARNUM := YEARNUM*10+ORD(GS[1])-ORD('0');
	  OK := YEARNUM <= 999; DELETE(GS,1,1)
	END
    UNTIL (LENGTH(GS) = 0) OR NOT OK;
    IF LENGTH(GS) > 0 THEN GOTO 1;
    WITH THEDATE DO
      BEGIN
	YEAR := YEARNUM MOD 100; MONTH := MONINDX; DAY := DAYNUM;
	WRITE(OUTPUT,'New date is ',DAY:2,'-',MONTHS[MONTH],'-',YEAR:2)
      END;
    IF FALSE THEN
1:    WRITE(OUTPUT,'Illegal date specification');
  END (* DATESET *) ;
  
  PROCEDURE XBLOCKS;
    LABEL 1;
    VAR LINX: DIRRANGE; CONFLICT: BOOLEAN;
	FIRSTBLK,LASTBLK,MAXBLK,MINBLK,LBLK,I: INTEGER;
	LDE: DIRENTRY; A,B: ARRAY [0..255] OF INTEGER;
  BEGIN
    GS := 'Examine blocks of what volume? ';
    IF GETVOLUME(TRUE) THEN
      BEGIN CONFLICT := FALSE;
	MINBLK := 32767; MAXBLK := -1;
	FIRSTBLK := 0; LASTBLK := 0;
	WRITE(OUTPUT,'What block number-range? ');
	READ(INPUT,FIRSTBLK);
	IF EOLN(INPUT) THEN LASTBLK := FIRSTBLK
	ELSE
	  BEGIN READ(INPUT,LASTBLK);
	    IF NOT EOLN(INPUT) THEN WRITELN(OUTPUT);
	    IF LASTBLK < 0 THEN LASTBLK := ABS(LASTBLK);
	    IF LASTBLK < FIRSTBLK THEN
	      BEGIN I := FIRSTBLK; FIRSTBLK := LASTBLK; LASTBLK := I END
	  END;
	IF FIRSTBLK < GDIR^[0].DLASTBLK THEN
	  BEGIN
	    WRITE(OUTPUT,'You want to risk the directory? ');
	    IF GETCHAR(TRUE) <> 'Y' THEN GOTO 1;
	    WRITELN(OUTPUT)
	  END;
	FOR LINX := 1 TO GDIR^[0].DNUMFILES DO
	  WITH GDIR^[LINX] DO
	    IF (FIRSTBLK < DLASTBLK) AND
		(LASTBLK >= DFIRSTBLK) THEN
	      BEGIN
		IF NOT CONFLICT THEN
		  BEGIN CONFLICT := TRUE;
		    WRITELN(OUTPUT,'File(s) endangered:')
		  END;
		WRITELN(OUTPUT,DTID,' ':TIDLENG-LENGTH(DTID)+1,
			DFIRSTBLK:6,DLASTBLK:6)
	      END;
	IF CONFLICT THEN
	  BEGIN
	    WRITE(OUTPUT,'Do you want to risk them? ');
	    IF GETCHAR(TRUE) <> 'Y' THEN GOTO 1;
	    WRITELN(OUTPUT)
	  END;
	FOR LBLK := FIRSTBLK TO LASTBLK DO
	  BEGIN WRITE(OUTPUT,'Block ',LBLK);
	    UNITREAD(GUNIT,A,FBLKSIZE,LBLK);
	    B := A;
	    UNITWRITE(GUNIT,A,FBLKSIZE,LBLK);
	    IF IORESULT = 0 THEN
	      UNITREAD(GUNIT,B,FBLKSIZE,LBLK);
	    IF (IORESULT = 0) AND (A = B) THEN
	      WRITELN(OUTPUT,' may be recoverable')
	    ELSE
	      BEGIN
		WRITELN(OUTPUT,' is not recoverable');
		IF LBLK < MINBLK THEN MINBLK := LBLK;
		IF LBLK > MAXBLK THEN MAXBLK := LBLK
	      END
	  END;
	IF MAXBLK < 0 THEN GOTO 1;
	IF MINBLK = MAXBLK THEN
	  WRITE(OUTPUT,'Block ',MINBLK,' has a hard error')
	ELSE
	  WRITE(OUTPUT,'Blocks ',MINBLK,' through ',MAXBLK,
			' have hard errors');
	WRITELN(OUTPUT);
	WRITE(OUTPUT,'Mark as bad');
	IF CONFLICT THEN
	  WRITE(OUTPUT,' (may remove files!)');
	WRITE(OUTPUT,'? ');
	IF GETCHAR(TRUE) <> 'Y' THEN GOTO 1;
	WRITELN(OUTPUT);
	IF CONFLICT THEN
	  BEGIN LINX := 1;  (*ZAP CONFLICTS*)
	    WHILE LINX <= GDIR^[0].DNUMFILES DO
	      WITH GDIR^[LINX] DO
		IF (MINBLK < DLASTBLK) AND
		    (MAXBLK >= DFIRSTBLK) THEN
		  DELENTRY(LINX,GDIR)
		ELSE LINX := LINX+1
	  END;
	IF GDIR^[0].DNUMFILES = MAXDIR THEN
	  BEGIN
	    WRITE(OUTPUT,'No room in directory');
	    GOTO 1
	  END;
	WITH LDE DO
	  BEGIN
	    DFIRSTBLK := MINBLK; DLASTBLK := MAXBLK+1;
	    DFKIND := XDSKFILE; DLASTBYTE := FBLKSIZE;
	    DACCESS := THEDATE; DTID := 'BAD.xxxxx.BAD';
	    FIRSTBLK := MINBLK;
	    FOR I := 4 DOWNTO 0 DO
	      BEGIN
		DTID[9-I] := CHR(FIRSTBLK DIV IPOT[I] + ORD('0'));
		FIRSTBLK := FIRSTBLK MOD IPOT[I]
	      END
	  END;
	LINX := GDIR^[0].DNUMFILES;
	WHILE MINBLK < GDIR^[LINX].DLASTBLK DO
	  LINX := LINX-1;
	INSENTRY(LDE,LINX+1,GDIR);
	WRITEDIR(GUNIT,GDIR);
	WRITE(OUTPUT,LDE.DTID,' marked')
      END;
1:
  END (*XBLOCKS*) ;

  PROCEDURE KRUNCH;
    LABEL 1;
    VAR LINX: DIRRANGE; NBLOCKS,DESTBLK: INTEGER;
	RELBLOCK,CHUNKSIZE,AINX,LBLOCK: INTEGER;
	REBOOT: BOOLEAN;
  BEGIN
    GS := 'Crunch what volume? ';
    IF GETVOLUME(TRUE) THEN
      BEGIN
	WRITE(OUTPUT,'Are you sure you want to crunch ',GVID,': ? ');
	IF GETCHAR(TRUE) <> 'Y' THEN GOTO 1;
	WRITELN(OUTPUT);
	SYSCOM^.MISCINFO.NOBREAK := TRUE;
	FOR LINX := 1 TO GDIR^[0].DNUMFILES DO
	  WITH GDIR^[LINX] DO
	    IF (DFKIND <> XDSKFILE) AND
		(DFIRSTBLK > GDIR^[LINX-1].DLASTBLK) THEN
	      BEGIN
		WRITELN(OUTPUT,'Moving ',DTID);
		NBLOCKS := DLASTBLK-DFIRSTBLK;
		DESTBLK := GDIR^[LINX-1].DLASTBLK;
		RELBLOCK := 0;
		REPEAT
		  CHUNKSIZE := NBLOCKS-RELBLOCK;
		  IF CHUNKSIZE > GBUFBLKS THEN CHUNKSIZE := GBUFBLKS;
		  IF CHUNKSIZE > 0 THEN
		    BEGIN AINX := 0;
		      FOR LBLOCK := DFIRSTBLK+RELBLOCK TO
					DFIRSTBLK+RELBLOCK+CHUNKSIZE-1 DO
			BEGIN
			  UNITREAD(GUNIT,GBUF^[AINX],FBLKSIZE,LBLOCK);
			  IF IORESULT <> 0 THEN
			    WRITELN(OUTPUT,'Read error, rel ',
				LBLOCK-DFIRSTBLK,', abs ',LBLOCK);
			  AINX := AINX+FBLKSIZE
			END;
		      AINX := 0;
		      FOR LBLOCK := DESTBLK+RELBLOCK TO
					DESTBLK+RELBLOCK+CHUNKSIZE-1 DO
			BEGIN
			  UNITWRITE(GUNIT,GBUF^[AINX],FBLKSIZE,LBLOCK);
			  IF IORESULT <> 0 THEN
			    WRITELN(OUTPUT,'Write error, rel ',
				LBLOCK-DESTBLK,', abs ',LBLOCK);
			  AINX := AINX+FBLKSIZE
			END;
		      RELBLOCK := RELBLOCK+CHUNKSIZE
		    END
		UNTIL CHUNKSIZE = 0;
		DFIRSTBLK := DESTBLK;
		DLASTBLK := DESTBLK+NBLOCKS
	      END;
	WRITEDIR(GUNIT,GDIR);
	WRITELN(OUTPUT,GVID,': crunched');
	REBOOT := GVID = SYVID;
	IF NOT REBOOT THEN
	  WITH USERINFO DO
	    IF GOTSYM THEN
	      REBOOT := SYMVID = GVID
	    ELSE
	      IF GOTCODE THEN
		REBOOT := CODEVID = GVID;
	IF REBOOT THEN
	  BEGIN
	    WRITELN(OUTPUT,'Please bootload');
	    REPEAT UNTIL FALSE
	  END;
	SYSCOM^.MISCINFO.NOBREAK := FALSE
      END;
1:
  END (*KRUNCH*) ;

BEGIN (*FILEHANDLER*)
  FILERINIT;
  REPEAT
    PL :=
'Filer: G(et, S(ave, W(hat, N(ew, L(dir, R(em, C(hng, T(rans, D(ate, Q(uit';
    PROMPT; GCH := GETCHAR(BADCOMMAND); CLEARSCREEN;
    BADCOMMAND := NOT (GCH IN  ['G','S','W','N','L','E','C','R','D',
				'T','M','V','B','Z','P','X','K']);
    INSTRING := ''; (*IN CASE OF REMOVE ETC*)
    CASE GCH OF
      'G':  GETWORK;
      'S':  SAVEWORK;
      'W':  WHATWORK;
      'N':  NEWWORK(TRUE);
      'L':  LISTDIR(FALSE);
      'E':  LISTDIR(TRUE);
      'C':  CHANGER;
      'R':  REMOVER;
      'P':  PREFIXER;
      'T':  TRANSFER;
      'M':  MAKEFILE;
      'V':  LISTVOLS;
      'B':  BADBLOCKS;
      'Z':  ZEROVOLUME;
      'X':  XBLOCKS;
      'K':  KRUNCH;
      'D':  DATESET
    END
  UNTIL GCH = 'Q'
END (*FILEHANDLER*) ;

BEGIN END.

========================================================================================
DOCUMENT :usus Folder:VOL17:globals.text
========================================================================================

(*$U-*)
PROGRAM PASCALSYSTEM;

(************************************************)
(*                                              *)
(*    UCSD PASCAL OPERATING SYSTEM              *)
(*                                              *)
(*    RELEASE LEVEL:  I.3   AUGUST, 1977        *)
(*                                              *)
(*    WRITTEN BY ROGER T. SUMNER                *)
(*    WINTER 1977                               *)
(*                                              *)
(*    INSTITUTE FOR INFORMATION SYSTEMS         *)
(*    UC SAN DIEGO, LA JOLLA, CA                *)
(*                                              *)
(*    KENNETH L. BOWLES, DIRECTOR               *)
(*                                              *)
(*    THIS SOFTWARE IS THE PROPERTY OF THE      *)
(*  REGENTS OF THE UNIVERSITY OF CALIFORNIA.    *)
(*                                              *)
(************************************************)

CONST
     MAXUNIT = 8;	(*MAXIMUM PHYSICAL UNIT # FOR UREAD*)
     MAXDIR = 77;	(*MAX NUMBER OF ENTRIES IN A DIRECTORY*)
     VIDLENG = 7;	(*NUMBER OF CHARS IN A VOLUME ID*)
     TIDLENG = 15;	(*NUMBER OF CHARS IN TITLE ID*)
     MAXSEG = 15;	(*MAX CODE SEGMENT NUMBER*)
     FBLKSIZE = 512;	(*STANDARD DISK BLOCK LENGTH*)
     DIRBLK = 2;	(*DISK ADDR OF DIRECTORY*)
     AGELIMIT = 300;	(*MAX AGE FOR GDIRP...IN TICKS*)
     EOL = 13;		(*END-OF-LINE...ASCII CR*)

TYPE

     IORSLTWD = (INOERROR,IBADBLOCK,IBADUNIT,IBADMODE,IHARDXTRA,
		 ILOSTUNIT,ILOSTFILE,IBADTITLE,INOROOM,INOUNIT,
		 INOFILE,IDUPFILE,INOTCLOSED,INOTOPEN,IBADFORMAT);

					(*ARCHIVAL INFO...THE DATE*)

     DATEREC = PACKED RECORD
		 MONTH: 0..12;		(*0 IMPLIES DATE NOT MEANINGFUL*)
		 DAY: 0..31;		(*DAY OF MONTH*)
		 YEAR: 0..100		(*100 IS TEMP DISK FLAG*)
	       END (*DATEREC*) ;

					(*VOLUME TABLES*)
     UNITNUM = 0..MAXUNIT;
     VID = STRING[VIDLENG];

					(*DISK DIRECTORIES*)
     DIRRANGE = 0..MAXDIR;
     TID = STRING[TIDLENG];

     FILEKIND = (UNTYPEDFILE,XDSKFILE,CODEFILE,TEXTFILE,
		 INFOFILE,DATAFILE,GRAFFILE,FOTOFILE);

     DIRENTRY = RECORD
		  DFIRSTBLK: INTEGER;	(*FIRST PHYSICAL DISK ADDR*)
		  DLASTBLK: INTEGER;	(*POINTS AT BLOCK FOLLOWING*)
		  CASE DFKIND: FILEKIND OF
		    UNTYPEDFILE: (*ONLY IN DIR[0]...VOLUME INFO*)
		       (DVID: VID;		(*NAME OF DISK VOLUME*)
			DEOVBLK: INTEGER;	(*LASTBLK OF VOLUME*)
			DNUMFILES: DIRRANGE;	(*NUM FILES IN DIR*)
			DLOADTIME: INTEGER);	(*TIME OF LAST ACCESS*)
		    XDSKFILE,CODEFILE,TEXTFILE,INFOFILE,
		    DATAFILE,GRAFFILE,FOTOFILE:
		       (DTID: TID;		(*TITLE OF FILE*)
			DLASTBYTE: 1..FBLKSIZE;	(*NUM BYTES IN LAST BLOCK*)
			DACCESS: DATEREC)	(*LAST MODIFICATION DATE*)
		END (*DIRENTRY*) ;

     DIRP = ^DIRECTORY;

     DIRECTORY = ARRAY [DIRRANGE] OF DIRENTRY;

					(*FILE INFORMATION*)

     CLOSETYPE = (CNORMAL,CLOCK,CPURGE,CCRUNCH);
     WINDOWP = ^WINDOW;
     WINDOW = PACKED ARRAY [0..0] OF CHAR;
     FIBP = ^FIB;

     FIB = RECORD
	     FWINDOW: WINDOWP;	(*USER WINDOW...F^, USED BY GET-PUT*)
	     FEOF,FEOLN: BOOLEAN;
	     FRECSIZE: INTEGER;	(*IN BYTES...0=>BLOCKFILE, 1=>CHARFILE*)
	     CASE FISOPEN: BOOLEAN OF
	       TRUE: (FISBLKD,		(*FILE IS ON BLOCK DEVICE*)
		      FGOTACHAR:BOOLEAN;(*MARK FOR CHAR LOOK-AHEAD*)
		      FUNIT: UNITNUM;	(*PHYSICAL UNIT #*)
		      FVID: VID;	(*VOLUME NAME*)
		      FNXTBLK,		(*NEXT REL BLOCK TO IO*)
		      FMAXBLK: INTEGER;	(*MAX REL BLOCK ACCESSED*)
		      FMODIFIED:BOOLEAN;(*PLEASE SET NEW DATE IN CLOSE*)
		      FHEADER: DIRENTRY;(*COPY OF DISK DIR ENTRY*)
		      CASE FSOFTBUF: BOOLEAN OF	(*DISK GET-PUT STUFF*)
			TRUE: (FNXTBYTE,FMAXBYTE: INTEGER;
			       FBUFCHNGD: BOOLEAN;
			       FBUFFER: PACKED ARRAY [0..FBLKSIZE] OF CHAR))
	   END (*FIB*) ;

					(*USER WORKFILE STUFF*)

     INFOREC = RECORD
		 SYMFIBP,CODEFIBP: FIBP;	(*WORKFILES FOR SCRATCH*)
		 ERRSYM,ERRBLK,ERRNUM: INTEGER;	(*ERROR STUFF IN EDIT*)
		 STUPID: BOOLEAN;		(*STUDENT PROGRAMMER ID!!*)
		 GOTSYM,GOTCODE: BOOLEAN;	(*TITLES ARE MEANINGFUL*)
		 WORKVID,SYMVID,CODEVID: VID;	(*PERM&CUR WORKFILE VOLUMES*)
		 WORKTID,SYMTID,CODETID: TID	(*PERM&CUR WORKFILES TITLE*)
	       END (*INFOREC*) ;

					(*CODE SEGMENT LAYOUTS*)

     SEGRANGE = 0..MAXSEG;
     SEGDESC = RECORD
		 DISKADDR: INTEGER;	(*REL # IN CODE...ABS # IN SYSCOM^*)
		 CODELENG: INTEGER	(*# BYTES TO READ IN*)
	       END (*SEGDESC*) ;

					(*DEBUGGER STUFF*)

     BYTERANGE = 0..255;
     TRICKARRAY = ARRAY [0..0] OF INTEGER; (* FOR MEMORY DIDDLING*)
     MSCWP = ^ MSCW;		(*MARK STACK RECORD POINTER*)
     MSCW = RECORD
	      STATLINK: MSCWP;	(*POINTER TO PARENT MSCW*)
	      DYNLINK: MSCWP;	(*POINTER TO CALLER'S MSCW*)
	      MSSEG,MSJTAB: ^TRICKARRAY;
	      MSIPC: INTEGER;
	      LOCALDATA: TRICKARRAY
	    END (*MSCW*) ;

					(*SYSTEM COMMUNICATION AREA*)
					(*SEE INTERPRETERS...NOTE  *)
					(*THAT WE ASSUME BACKWARD  *)
					(*FIELD ALLOCATION IS DONE *)
     SYSCOMREC = RECORD
		   IORSLT: IORSLTWD;	(*RESULT OF LAST IO CALL*)
		   XEQERR: INTEGER;	(*REASON FOR EXECERROR CALL*)
		   SYSUNIT: UNITNUM;	(*PHYSICAL UNIT OF BOOTLOAD*)
		   BUGSTATE: INTEGER;(*DEBUGGER INFO*)
		   GDIRP: DIRP;		(*GLOBAL DIR POINTER,SEE VOLSEARCH*)
		   LASTMP,STKBASE,BOMBP: MSCWP;
		   MEMTOP,SEG,JTAB: INTEGER;
		   BOMBIPC: INTEGER;	(*WHERE XEQERR BLOWUP WAS*)
		   EXPANSION: ARRAY [0..14] OF INTEGER;
		   HIGHTIME,LOWTIME: INTEGER;
		   MISCINFO: PACKED RECORD
			       NOBREAK,STUPID,SLOWTERM,
			       HASXYCRT,HASLCCRT,HAS8510A,HASCLOCK: BOOLEAN
			     END;
		   CRTTYPE: INTEGER;
		   CRTCTRL: PACKED RECORD
			      RLF,NDFS,ERASEEOL,ERASEEOS,HOME,ESCAPE: CHAR;
			      BACKSPACE: CHAR;
			      FILLCOUNT: 0..255;
			      EXPANSION: PACKED ARRAY [0..3] OF CHAR
			    END;
		   CRTINFO: PACKED RECORD
			      WIDTH,HEIGHT: INTEGER;
			      RIGHT,LEFT,DOWN,UP: CHAR;
			      BADCH,CHARDEL,STOP,BREAK,FLUSH,EOF: CHAR;
			      ALTMODE,LINEDEL: CHAR;
			      EXPANSION: PACKED ARRAY [0..5] OF CHAR
			    END;
		   SEGTABLE: ARRAY [SEGRANGE] OF
			       RECORD
				 CODEUNIT: UNITNUM;
				 CODEDESC: SEGDESC
			       END
		 END (*SYSCOM*);

VAR
    SYSCOM: ^SYSCOMREC;			(*MAGIC PARAM...SET UP IN BOOT*)
    GFILES: ARRAY [0..5] OF FIBP;	(*GLOBAL FILES, 0=INPUT, 1=OUTPUT*)
    EMPTYHEAP: ^INTEGER;		(*HEAP MARK FOR MEM MANAGING*)
    INPUTFIB,OUTPUTFIB,SYSTERM: FIBP;	(*ACTUAL FILES...GFILES ARE COPIES*)
    SYVID,DKVID: VID;			(*SYSUNIT VOLID & DEFAULT VOLID*)
    THEDATE: DATEREC;			(*TODAY...SET IN FILER OR SIGN ON*)
    DEBUGINFO: ^INTEGER;		(*DEBUGGERS GLOBAL INFO WHILE RUNIN*)
    PL: STRING;				(*PROMPTLINE STRING...SEE PROMPT*)
    IPOT: ARRAY [0..4] OF INTEGER;	(*INTEGER POWERS OF TEN*)
    FILLER: STRING[11];			(*NULLS FOR CARRIAGE DELAY*)
    USERINFO: INFOREC;			(*WORK STUFF FOR COMPILER ETC*)
    UNITABLE: ARRAY [UNITNUM] OF (*0 NOT USED*)
		RECORD
		  UVID: VID;	(*VOLUME ID FOR UNIT*)
		  CASE UISBLKD: BOOLEAN OF
		    TRUE: (UEOVBLK: INTEGER)
		END (*UNITABLE*) ;

(*-------------------------------------------------------------------------*)
(* SYSTEM PROCEDURE FORWARD DECLARATIONS *)
(* THESE ARE ADDRESSED BY OBJECT CODE... *)
(*  DO NOT MOVE WITHOUT CAREFUL THOUGHT  *)

PROCEDURE EXECERROR;
  FORWARD;
PROCEDURE FINIT(VAR F: FIB; WINDOW: WINDOWP; RECWORDS: INTEGER);
  FORWARD;
PROCEDURE FRESET(VAR F: FIB);
  FORWARD;
PROCEDURE FOPEN(VAR F: FIB; VAR FTITLE: STRING;
		FOPENOLD: BOOLEAN; JUNK: FIBP);
  FORWARD;
PROCEDURE FCLOSE(VAR F: FIB; FTYPE: CLOSETYPE);
  FORWARD;
PROCEDURE FGET(VAR F: FIB);
  FORWARD;
PROCEDURE FPUT(VAR F: FIB);
  FORWARD;
PROCEDURE FSEEK(VAR F: FIB);
  FORWARD;
FUNCTION FEOF(VAR F: FIB): BOOLEAN;
  FORWARD;
FUNCTION FEOLN(VAR F: FIB): BOOLEAN;
  FORWARD;
PROCEDURE FREADINT(VAR F: FIB; VAR I: INTEGER);
  FORWARD;
PROCEDURE FWRITEINT(VAR F: FIB; I,RLENG: INTEGER);
  FORWARD;
PROCEDURE FREADREAL(VAR F: FIB; VAR X: REAL);
  FORWARD;
PROCEDURE FWRITEREAL(VAR F: FIB; X: REAL; W,D: INTEGER);
  FORWARD;
PROCEDURE FREADCHAR(VAR F: FIB; VAR CH: CHAR);
  FORWARD;
PROCEDURE FWRITECHAR(VAR F: FIB; CH: CHAR; RLENG: INTEGER);
  FORWARD;
PROCEDURE FREADSTRING(VAR F: FIB; VAR S: STRING; SLENG: INTEGER);
  FORWARD;
PROCEDURE FWRITESTRING(VAR F: FIB; VAR S: STRING; RLENG: INTEGER);
  FORWARD;
PROCEDURE FWRITEBYTES(VAR F: FIB; VAR A: WINDOW; RLENG,ALENG: INTEGER);
  FORWARD;
PROCEDURE FREADLN(VAR F: FIB);
  FORWARD;
PROCEDURE FWRITELN(VAR F: FIB);
  FORWARD;
PROCEDURE SCONCAT(VAR DEST,SRC: STRING; DESTLENG: INTEGER);
  FORWARD;
PROCEDURE SINSERT(VAR SRC,DEST: STRING; DESTLENG,INSINX: INTEGER);
  FORWARD;
PROCEDURE SCOPY(VAR SRC,DEST: STRING; SRCINX,COPYLENG: INTEGER);
  FORWARD;
PROCEDURE SDELETE(VAR DEST: STRING; DELINX,DELLENG: INTEGER);
  FORWARD;
FUNCTION SPOS(VAR TARGET,SRC: STRING): INTEGER;
  FORWARD;
FUNCTION FBLOCKIO(VAR F: FIB; VAR A: WINDOW;
		  NBLOCKS,RBLOCK: INTEGER; DOREAD: BOOLEAN): INTEGER;
  FORWARD;

(* NON FIXED FORWARD DECLARATIONS *)

FUNCTION VOLSEARCH(VAR FVID: VID; LOOKHARD: BOOLEAN;
		   VAR FDIR: DIRP): UNITNUM;
  FORWARD;
PROCEDURE WRITEDIR(FUNIT: UNITNUM; FDIR: DIRP);
  FORWARD;
FUNCTION DIRSEARCH(VAR FTID: TID; FINDPERM: BOOLEAN; FDIR: DIRP): DIRRANGE;
  FORWARD;
FUNCTION SCANTITLE(FTITLE: STRING; VAR FVID: VID; VAR FTID: TID;
		   VAR FSEGS: INTEGER; VAR FKIND: FILEKIND): BOOLEAN;
  FORWARD;
PROCEDURE DELENTRY(FINX: DIRRANGE; FDIR: DIRP);
  FORWARD;
PROCEDURE INSENTRY(VAR FENTRY: DIRENTRY; FINX: DIRRANGE; FDIR: DIRP);
  FORWARD;
PROCEDURE CLEARSCREEN;
  FORWARD;
PROCEDURE PROMPT;
  FORWARD;
FUNCTION SPACEWAIT: BOOLEAN;
  FORWARD;
FUNCTION GETCHAR(FLUSH: BOOLEAN): CHAR;
  FORWARD;
PROCEDURE EXECUTE(RUNWORKFILE: BOOLEAN);
  FORWARD;
PROCEDURE COMMAND;
  FORWARD;

========================================================================================
DOCUMENT :usus Folder:VOL17:linker.text
========================================================================================

(*$R+,I-*)
PROGRAM LINKER;

CONST MAXSEG = 15;

TYPE SEGNUM = 0..MAXSEG;
     BLOCK0 = RECORD
		SEGDESC: ARRAY [SEGNUM] OF
			   RECORD
			     DISKADDR: INTEGER;
			     CODELENG: INTEGER
			   END;
		SEGNAME: ARRAY [SEGNUM] OF
			   PACKED ARRAY [0..7] OF CHAR;
		FILLER: PACKED ARRAY [1..320] OF CHAR
	      END;

VAR NBLOCKS,RSLT,OUTBLOCK: INTEGER;
    BUF: ^INTEGER;
    SEG: SEGNUM;
    TITLE: STRING;
    CODETBL: BLOCK0;
    CODE,INFILE: FILE;

FUNCTION CHECKIO:BOOLEAN;
VAR RSLT:INTEGER;
BEGIN
  CHECKIO:=IORESULT=0;
  IF IORESULT <> 0 THEN
    BEGIN
    RSLT:=IORESULT;
    WRITELN(OUTPUT,'I/O error # ',RSLT);
    END;
END; (* CHECKIO *)

FUNCTION OPENFILE: BOOLEAN;
BEGIN
  REPEAT
    WRITE(OUTPUT,'Link Code File? '); READLN(INPUT,TITLE);
    IF LENGTH(TITLE) > 0 THEN OPENOLD(INFILE,TITLE);
  UNTIL (CHECKIO) OR (LENGTH(TITLE) = 0);
  OPENFILE := LENGTH(TITLE) > 0
END (*OPENFILE*) ;

PROCEDURE LINKCODE;
  VAR NBLOCKS: INTEGER;
      INTBL: BLOCK0;

  FUNCTION CONFIRM:BOOLEAN;
  VAR CH:CHAR;
  BEGIN
    CONFIRM:=FALSE;
    WITH INTBL DO
      BEGIN
      IF SEGDESC[SEG].CODELENG > 24 THEN
	BEGIN
	WRITE(OUTPUT,'Linking ',SEGNAME[SEG],'.  Please Confirm (y/n)');
	READ(INPUT,CH);
	WRITELN(OUTPUT);
	IF (CODETBL.SEGDESC[SEG].CODELENG <> 0) AND (CH='Y') THEN
	  BEGIN
	  WRITE(OUTPUT,
'WARNING - This segment has already been linked in.  Please Reconfirm');
	  READ(INPUT,CH);
	  WRITELN(OUTPUT);
	  END;
	CONFIRM := CH = 'Y';
	END;
      END;
  END; (* CONFIRM *)

BEGIN
  IF BLOCKREAD(INFILE,INTBL,1,0) = 1 THEN
    BEGIN
      WITH INTBL DO
	FOR SEG := 0 TO MAXSEG DO
	    WITH SEGDESC[SEG] DO
	      IF CONFIRM THEN
		BEGIN NBLOCKS := (CODELENG+511) DIV 512;
		  IF BLOCKREAD(INFILE,BUF^,NBLOCKS,DISKADDR) <> NBLOCKS THEN
		    WRITELN(OUTPUT,'Error reading seg ',SEG)
		  ELSE
		    IF BLOCKWRITE(CODE,BUF^,NBLOCKS,OUTBLOCK) <> NBLOCKS THEN
		      WRITELN(OUTPUT,'I/O error - no room on disk')
		    ELSE
		      BEGIN
			WRITELN(OUTPUT,SEGNAME[SEG],' Seg # ',SEG,', Block ',
				OUTBLOCK,', ',CODELENG,' Bytes');
			CODETBL.SEGNAME[SEG] := SEGNAME[SEG];
			CODETBL.SEGDESC[SEG].CODELENG := CODELENG;
			CODETBL.SEGDESC[SEG].DISKADDR := OUTBLOCK;
			OUTBLOCK := OUTBLOCK + NBLOCKS
		      END
		END
    END
  ELSE
    BEGIN
    RSLT:=IORESULT;
    WRITELN(OUTPUT,'Input file read error # ',RSLT);
    END;
  CLOSE(INFILE)
END (*LINKCODE*) ;

BEGIN
  REPEAT
    WRITE(OUTPUT,'Output code file? '); READLN(INPUT,TITLE);
    IF LENGTH(TITLE) > 0 THEN OPENNEW(CODE,TITLE)
  UNTIL (LENGTH(TITLE) = 0) OR (CHECKIO);
  IF LENGTH(TITLE) > 0 THEN
      BEGIN OUTBLOCK := 1; NEW(BUF);
	WITH CODETBL DO
	  FOR SEG := 0 TO MAXSEG DO
	    BEGIN  SEGNAME[SEG] := '        ';
	      SEGDESC[SEG].CODELENG := 0;
	      SEGDESC[SEG].DISKADDR := 0
	    END;
	WHILE OPENFILE DO LINKCODE;
	IF BLOCKWRITE(CODE,CODETBL,1,0) = 1 THEN CLOSE(CODE,LOCK)
	ELSE
	  WRITELN(OUTPUT,'Code file write error ')
      END
END.

========================================================================================
DOCUMENT :usus Folder:VOL17:system.a.text
========================================================================================


SEGMENT PROCEDURE USERPROGRAM(VAR INPUT,OUTPUT: FIB);
BEGIN FWRITELN(SYSTERM^);
  PL := 'No user program linked in';
  FWRITESTRING(SYSTERM^,PL,0)
END (*USERPROGRAM*) ;

SEGMENT PROCEDURE COMPILER(VAR USERINFO: INFOREC);
  SEGMENT PROCEDURE COMPINIT;
  BEGIN END (*COMPINIT*) ;
BEGIN FWRITELN(SYSTERM^);
  PL := 'No compiler linked in';
  USERINFO.ERRNUM := 400;
  FWRITESTRING(SYSTERM^,PL,0)
END (*COMPILER*) ;

SEGMENT PROCEDURE EDITOR; 
BEGIN FWRITELN(SYSTERM^);
  PL := 'No editor linked in';
  FWRITESTRING(SYSTERM^,PL,0)
END (*EDITOR*) ;

SEGMENT PROCEDURE FILEHANDLER;
BEGIN FWRITELN(SYSTERM^);
  PL := 'No file handler linked in';
  FWRITESTRING(SYSTERM^,PL,0)
END (*FILEHANDLER*) ;

SEGMENT PROCEDURE DEBUGGER;
BEGIN FWRITELN(SYSTERM^);
  PL := 'No debugger linked in';
  FWRITESTRING(SYSTERM^,PL,0)
END (*DEBUGGER*) ;

SEGMENT PROCEDURE INITIALIZE;
  VAR DOTRITON,JUSTBOOTED: BOOLEAN; LTITLE: STRING[20];
      DISPLAY: ARRAY [0..79,0..19] OF INTEGER; (*FOR TRITON*)

  PROCEDURE BUILDUNITABLE;
    VAR LUNIT: UNITNUM; LDIR: DIRP;
  BEGIN
    FOR LUNIT := 0 TO MAXUNIT DO
      WITH UNITABLE[LUNIT] DO
	BEGIN UISBLKD := FALSE; UVID := '';
	  IF UNITBUSY(LUNIT) THEN UNITCLEAR(LUNIT)
	END;
    UNITABLE[1].UVID := 'CONSOLE';
    UNITABLE[2].UVID := 'SYSTERM';
    UNITABLE[4].UISBLKD := TRUE;
    UNITABLE[4].UEOVBLK := 0;
    UNITABLE[5].UISBLKD := TRUE;
    UNITABLE[5].UEOVBLK := 0;
    SYVID := '';
    LUNIT := VOLSEARCH(SYVID,TRUE,LDIR);
    SYVID := UNITABLE[SYSCOM^.SYSUNIT].UVID;
    IF LENGTH(SYVID) = 0 THEN HALT;
    UNITCLEAR(6);
    IF IORESULT = ORD(INOERROR) THEN
      UNITABLE[6].UVID := 'PRINTER';
    UNITCLEAR(7);
    IF IORESULT = ORD(INOERROR) THEN
      UNITABLE[7].UVID := 'SPEAKER';
    UNITCLEAR(8);
    IF IORESULT = ORD(INOERROR) THEN
      UNITABLE[8].UVID := 'NETWORK';
  END (*BUILDUNITABLE*) ;

  PROCEDURE INITCHARSET;
  TYPE CHARSET= ARRAY [32..127] OF
		  PACKED ARRAY [0..9] OF 0..255;
  VAR I: INTEGER;
      TRIX: RECORD CASE BOOLEAN OF
	      TRUE:  (CHARADDR: INTEGER);
	      FALSE: (CHARBUFP: ^ CHAR)
	    END;
      CHARBUF: RECORD
		   SET1: CHARSET;
		   FILLER1: PACKED ARRAY [0..63] OF CHAR;
		   SET2: CHARSET;
		   FILLER2: PACKED ARRAY [0..63] OF CHAR;
		   TRITON: ARRAY [0..63,0..3] OF INTEGER
		 END (*CHARBUF*) ;
      LFIB: FIB;
  BEGIN FINIT(LFIB,NIL,-1);
    LTITLE := '*SYSTEM.CHARSET';
    FOPEN(LFIB,LTITLE,TRUE,NIL);
    IF LFIB.FISOPEN THEN
      BEGIN UNITWRITE(3,TRIX,128);
	IF IORESULT = ORD(INOERROR) THEN
	  BEGIN
	    WITH LFIB.FHEADER DO
	      BEGIN DOTRITON := DLASTBLK-DFIRSTBLK > 4;
		UNITREAD(LFIB.FUNIT,CHARBUF,SIZEOF(CHARBUF),DFIRSTBLK)
	      END;
	    TRIX.CHARADDR := 512-8192;	(*UNIBUS TRICKYNESS!*)
	    FOR I := 32 TO 127 DO
	      BEGIN
		MOVELEFT(CHARBUF.SET1[I],TRIX.CHARBUFP^,10);
		TRIX.CHARADDR := TRIX.CHARADDR+16
	      END;
	    TRIX.CHARADDR := 512-6144;
	    FOR I := 32 TO 127 DO
	      BEGIN
		MOVELEFT(CHARBUF.SET2[I],TRIX.CHARBUFP^,10);
		TRIX.CHARADDR := TRIX.CHARADDR+16
	      END;
	    UNITABLE[3].UVID := 'GRAPHIC';
	    UNITWRITE(3,I,0)
	  END
      END
    ELSE
      SYSCOM^.MISCINFO.HAS8510A := FALSE;
    IF DOTRITON THEN
      BEGIN (*INITIALIZE DISPLAY ARRAY*)
	FILLCHAR(DISPLAY,SIZEOF(DISPLAY),0);
	FOR I := 0 TO 63 DO MOVELEFT(CHARBUF.TRITON[I],DISPLAY[I,10],8)
      END;
    FCLOSE(LFIB,CNORMAL)
  END (*INITCHARSET*) ;

BEGIN
  JUSTBOOTED := EMPTYHEAP = NIL;
  IF JUSTBOOTED THEN
    BEGIN (*BASIC FILE AND HEAP SETTUP*)
      NEW(INPUTFIB,TRUE,FALSE); FINIT(INPUTFIB^,NIL,0);
      NEW(OUTPUTFIB,TRUE,FALSE); FINIT(OUTPUTFIB^,NIL,0);
      NEW(SYSTERM,TRUE,FALSE); FINIT(SYSTERM^,NIL,0);
      NEW(INPUTFIB^.FWINDOW);
      NEW(OUTPUTFIB^.FWINDOW);
      NEW(SYSTERM^.FWINDOW);
      WITH USERINFO DO
        BEGIN
          NEW(SYMFIBP,TRUE,FALSE); FINIT(SYMFIBP^,NIL,-1);
          NEW(CODEFIBP,TRUE,FALSE); FINIT(CODEFIBP^,NIL,-1)
        END;
      MARK(EMPTYHEAP)
    END
  ELSE (*ALREADY UNDERWAY*)
    BEGIN
      FCLOSE(USERINFO.SYMFIBP^,CNORMAL);
      FCLOSE(USERINFO.CODEFIBP^,CNORMAL);
      RELEASE(EMPTYHEAP)
    END;
  DEBUGINFO := NIL; DOTRITON := FALSE;
  IPOT[0] := 1; IPOT[1] := 10; IPOT[2] := 100;
  IPOT[3] := 1000; IPOT[4] := 10000;
  WITH SYSCOM^ DO
    BEGIN
      FILLER[0] := CHR(CRTCTRL.FILLCOUNT);
      FILLCHAR(FILLER[1],CRTCTRL.FILLCOUNT,CHR(0));
      XEQERR := 0; IORSLT := INOERROR;
      BUGSTATE := 0; GDIRP := NIL
    END;
  BUILDUNITABLE;
  IF JUSTBOOTED THEN
    BEGIN DKVID := SYVID;
      WITH THEDATE DO
	BEGIN MONTH := 0; DAY := 0; YEAR := 0 END;
      LTITLE := 'CONSOLE:';
      FOPEN(INPUTFIB^,LTITLE,TRUE,NIL);
      FOPEN(OUTPUTFIB^,LTITLE,TRUE,NIL);
      LTITLE := 'SYSTERM:';
      FOPEN(SYSTERM^,LTITLE,TRUE,NIL);
      WITH USERINFO DO
        BEGIN (*INITIALIZE WORK FILES ETC*)
	  SYMTID := ''; CODETID := ''; WORKTID := '';
	  SYMVID := SYVID; CODEVID := SYVID; WORKVID := SYVID;
          LTITLE := '*SYSTEM.WRK.TEXT';
          FOPEN(SYMFIBP^,LTITLE,TRUE,NIL);
	  GOTSYM := SYMFIBP^.FISOPEN;
	  IF GOTSYM THEN
	    SYMTID := SYMFIBP^.FHEADER.DTID;
	  FCLOSE(SYMFIBP^,CNORMAL);
          LTITLE := '*SYSTEM.WRK.CODE';
          FOPEN(CODEFIBP^,LTITLE,TRUE,NIL);
	  GOTCODE := CODEFIBP^.FISOPEN;
	  IF GOTCODE THEN
	    CODETID := CODEFIBP^.FHEADER.DTID;
	  FCLOSE(CODEFIBP^,CNORMAL);
          STUPID := SYSCOM^.MISCINFO.STUPID
	END
    END;
  FRESET(INPUTFIB^);
  FRESET(OUTPUTFIB^);
  FRESET(SYSTERM^);
  IF NOT JUSTBOOTED THEN
    IF GFILES[0] <> INPUTFIB THEN
      FCLOSE(GFILES[0]^,CNORMAL);
  GFILES[0] := INPUTFIB;
  GFILES[1] := OUTPUTFIB;
  GFILES[2] := SYSTERM;
  GFILES[3] := NIL; GFILES[4] := NIL; GFILES[5] := NIL;
  IF SYSCOM^.MISCINFO.HAS8510A THEN INITCHARSET;
  CLEARSCREEN; WRITELN(OUTPUT);
  IF JUSTBOOTED THEN
    BEGIN
      IF DOTRITON THEN
        BEGIN (*ASSUME DATA MEDIA SCREEN*)
          WRITE(OUTPUT,CHR(30),CHR(32),CHR(42));
          UNITWRITE(3,DISPLAY[-80],23)
        END;
      WRITELN(OUTPUT,'Welcome  ',SYVID,',  to');
      IF DOTRITON THEN WRITELN(OUTPUT);
      WRITE(OUTPUT,'U.C.S.D.  Pascal  System  I.3')
    END
  ELSE
    WRITE(OUTPUT,'System re-initialized')
END (*INITIALIZE*) ;

PROCEDURE EXECERROR;
BEGIN
  WITH SYSCOM^ DO
    BEGIN
      IF XEQERR = 4 THEN
	BEGIN RELEASE(EMPTYHEAP);
	  PL := '**** STACK OVERFLOW!!';
	  UNITWRITE(2,PL[1],LENGTH(PL));
	  EXIT(COMMAND)
	END;
      BOMBP^.MSIPC := BOMBIPC;
      IF BUGSTATE <> 0 THEN
	BEGIN DEBUGGER; XEQERR := 0 END
      ELSE
	BEGIN FWRITELN(SYSTERM^);
	  WRITELN(OUTPUT,'Run time error # ',ORD(XEQERR));
	  WRITE(OUTPUT,'S# ',BOMBP^.MSSEG^[0] MOD 256);
	  WRITE(OUTPUT,', P# ',BOMBP^.MSJTAB^[0] MOD 256);
	  WRITE(OUTPUT,', I# ',
		BOMBIPC-ORD(BOMBP^.MSJTAB)+2+BOMBP^.MSJTAB^[-1]);
	  IF NOT SPACEWAIT THEN EXIT(COMMAND)
	END
    END
END (*EXECERROR*) ;

FUNCTION CHECKDEL(CH: CHAR; VAR SINX: INTEGER): BOOLEAN;
BEGIN CHECKDEL := FALSE;
  WITH SYSCOM^,CRTCTRL,CRTINFO DO
    BEGIN
      IF CH = LINEDEL THEN
	BEGIN CHECKDEL := TRUE;
	  IF (BACKSPACE = CHR(0)) OR (ERASEEOL = CHR(0)) THEN
	    BEGIN SINX := 1;
	      WRITELN(OUTPUT,'<ZAP')
	    END
	  ELSE
	    BEGIN
	      WHILE SINX > 1 DO
		BEGIN SINX := SINX-1; WRITE(OUTPUT,BACKSPACE) END;
	      WRITE(OUTPUT,ESCAPE,ERASEEOL)
	    END
	END;
      IF CH = CHARDEL THEN
	BEGIN CHECKDEL := TRUE;
	  IF SINX > 1 THEN
	    BEGIN SINX := SINX-1;
	      IF BACKSPACE = CHR(0) THEN
		IF CHARDEL < ' ' THEN
		  WRITE(OUTPUT,'_')
		ELSE (*ASSUME PRINTABLE*)
	      ELSE
		BEGIN
		  IF CHARDEL <> BACKSPACE THEN
		    WRITE(OUTPUT,BACKSPACE);
		  WRITE(OUTPUT,' ',BACKSPACE)
		END
	    END
	  ELSE
	    IF CHARDEL = BACKSPACE THEN
	      WRITE(OUTPUT,' ')
	END
    END
END (*CHECKDEL*) ;

PROCEDURE HOMECURSOR;
BEGIN
  WITH SYSCOM^,CRTCTRL DO
    BEGIN
      IF ESCAPE <> CHR(0) THEN
	FWRITECHAR(SYSTERM^,ESCAPE,1);
      FWRITECHAR(SYSTERM^,HOME,1);
      IF (LENGTH(FILLER) > 0) AND (HOME <> CHR(EOL)) THEN
	FWRITESTRING(SYSTERM^,FILLER,0)
    END
END (*HOMECURSOR*) ;

PROCEDURE CLEARSCREEN;
BEGIN HOMECURSOR;
  WITH SYSCOM^,CRTCTRL DO
    BEGIN
      IF MISCINFO.HAS8510A THEN UNITCLEAR(3);
      IF ERASEEOS <> CHR(0) THEN
	BEGIN
	  IF ESCAPE <> CHR(0) THEN
	    WRITE(OUTPUT,ESCAPE);
	  WRITE(OUTPUT,ERASEEOS);
	  IF LENGTH(FILLER) > 0 THEN
	    WRITE(OUTPUT,FILLER)
	END
    END
END (*CLEARSCREEN*) ;

PROCEDURE PROMPT;
  VAR I: INTEGER;
BEGIN HOMECURSOR;
  WITH SYSCOM^,CRTCTRL DO
    BEGIN
      IF ERASEEOL <> CHR(0) THEN
	BEGIN
	  IF ESCAPE <> CHR(0) THEN
	    WRITE(OUTPUT,ESCAPE);
	  WRITE(OUTPUT,ERASEEOL);
	  IF LENGTH(FILLER) > 0 THEN
	    WRITE(OUTPUT,FILLER)
	END;
      IF MISCINFO.SLOWTERM THEN
	BEGIN
	  I := SCAN(LENGTH(PL),=':',PL[1]);
	  IF I <> LENGTH(PL) THEN PL[0] := CHR(I+1)
	END
    END;
  WRITE(OUTPUT,PL)
END (*PROMPT*) ;

FUNCTION GETCHAR(*FLUSH: BOOLEAN*);
  VAR CH: CHAR;
BEGIN
  IF FLUSH THEN UNITCLEAR(1);
  INPUTFIB^.FGOTACHAR := FALSE;
  READ(INPUT,CH);
  IF (CH >= 'a') AND (CH <= 'z') THEN
    CH := CHR(ORD(CH)-ORD('a')+ORD('A'));
  GETCHAR := CH
END (*GETCHAR*) ;

FUNCTION SPACEWAIT;
  VAR CH: CHAR;
BEGIN
  PL := 'Type a <SPACE> to continue';
  REPEAT PROMPT;
    CH := GETCHAR(TRUE)
  UNTIL (CH = ' ') OR (CH = SYSCOM^.CRTINFO.ALTMODE);
  SPACEWAIT := CH <> ' '
END (*SPACEWAIT*) ;

FUNCTION SCANTITLE(*FTITLE: STRING; VAR FVID: VID; VAR FTID: TID;
		    VAR FSEGS: INTEGER; VAR FKIND: FILEKIND*);
  VAR I,RBRACK: INTEGER; CH: CHAR; OK: BOOLEAN;
BEGIN
  FVID := ''; FTID := '';
  FSEGS := 0; FKIND := UNTYPEDFILE;
  SCANTITLE := FALSE; I := 1;
  WHILE I <= LENGTH(FTITLE) DO
    BEGIN CH := FTITLE[I];
      IF CH <= ' ' THEN DELETE(FTITLE,I,1)
      ELSE
	BEGIN
	  IF (CH >= 'a') AND (CH <= 'z') THEN
	    FTITLE[I] := CHR(ORD(CH)-ORD('a')+ORD('A'));
	  I := I+1
	END
    END;
  IF LENGTH(FTITLE) > 0 THEN
    BEGIN
      IF FTITLE[1] = '*' THEN
	BEGIN FVID := SYVID; DELETE(FTITLE,1,1) END;
      I := POS(':',FTITLE);
      IF I <= 1 THEN
	BEGIN
	  IF LENGTH(FVID) = 0 THEN FVID := DKVID;
	  IF I = 1 THEN DELETE(FTITLE,1,1)
	END
      ELSE
	IF I-1 <= VIDLENG THEN
	  BEGIN
	    FVID := COPY(FTITLE,1,I-1);
	    DELETE(FTITLE,1,I)
	  END;
      IF LENGTH(FVID) > 0 THEN
	BEGIN
	  I := POS('[',FTITLE);
	  IF I > 0 THEN I := I-1
	  ELSE I := LENGTH(FTITLE);
	  IF I <= TIDLENG THEN
	    BEGIN
	      IF I > 0 THEN
		BEGIN FTID := COPY(FTITLE,1,I); DELETE(FTITLE,1,I) END;
	      IF LENGTH(FTITLE) = 0 THEN OK := TRUE
	      ELSE
		BEGIN OK := FALSE;
		  RBRACK := POS(']',FTITLE);
		  IF RBRACK = 2 THEN OK := TRUE
		  ELSE
		    IF RBRACK > 2 THEN
		      BEGIN OK := TRUE; I := 2;
			REPEAT CH := FTITLE[I];
			  IF (CH >= '0') AND (CH <= '9') THEN
			    FSEGS := FSEGS*10+ORD(CH)-ORD('0')
			  ELSE OK := FALSE;
			  I := I+1
			UNTIL (I = RBRACK) OR NOT OK
		      END
		END;
	      SCANTITLE := OK;
	      IF OK AND (LENGTH(FTID) > 5) THEN
		BEGIN
		  FTITLE := COPY(FTID,LENGTH(FTID)-4,5);
		  IF FTITLE = '.TEXT' THEN FKIND := TEXTFILE
		  ELSE
		  IF FTITLE = '.CODE' THEN FKIND := CODEFILE
		  ELSE
		  IF FTITLE = '.DATA' THEN FKIND := DATAFILE
		  ELSE
		  IF FTITLE = '.INFO' THEN FKIND := INFOFILE
		  ELSE
		  IF FTITLE = '.GRAF' THEN FKIND := GRAFFILE
		  ELSE
		  IF FTITLE = '.FOTO' THEN FKIND := FOTOFILE
		END
	    END
	END
    END
END (*SCANTITLE*) ;

(* VOLUME AND DIRECTORY HANDLERS *)

FUNCTION FETCHDIR(FUNIT: UNITNUM): BOOLEAN;
  VAR LINX: DIRRANGE; OK: BOOLEAN; HNOW: INTEGER;
BEGIN FETCHDIR := FALSE;
  WITH SYSCOM^,UNITABLE[FUNIT] DO
    BEGIN (*READ IN AND VALIDATE DIR*)
      IF GDIRP = NIL THEN NEW(GDIRP);
      UNITREAD(FUNIT,GDIRP^,SIZEOF(DIRECTORY),DIRBLK);
      OK := IORSLT = INOERROR;
      IF OK THEN
	WITH GDIRP^[0] DO
	  BEGIN OK := FALSE; (*CHECK OUT DIR*)
	    IF (DFIRSTBLK = 0) AND (DFKIND = UNTYPEDFILE) THEN
	      IF (LENGTH(DVID) > 0) AND (LENGTH(DVID) <= VIDLENG) AND
		 (DNUMFILES >= 0) AND (DNUMFILES <= MAXDIR) THEN
		BEGIN OK := TRUE; (*SO FAR SO GOOD*)
		  IF DVID <> UVID THEN
		    BEGIN (*NEW VOLUME IN UNIT...CAREFUL*)
		      LINX := 1;
		      WHILE LINX <= DNUMFILES DO
			WITH GDIRP^[LINX] DO
			  IF (DFKIND <= UNTYPEDFILE) OR
			     (DFKIND > FOTOFILE) OR
			     (LENGTH(DTID) <= 0) OR
			     (LENGTH(DTID) > TIDLENG) OR
			     (DLASTBLK < DFIRSTBLK) OR
			     (DLASTBYTE > FBLKSIZE) OR
			     (DLASTBYTE <= 0) OR
			     (DACCESS.YEAR >= 100) THEN
			    BEGIN OK := FALSE; DELENTRY(LINX,GDIRP) END
			  ELSE
			    LINX := LINX+1;
		      IF NOT OK THEN
			BEGIN (*MUST HAVE BEEN CHANGED...WRITEIT*)
			  UNITWRITE(FUNIT,GDIRP^,
				(DNUMFILES+1)*SIZEOF(DIRENTRY),DIRBLK);
			  OK := IORSLT = INOERROR
			END
		    END
		END;
	    IF OK THEN
	      BEGIN UVID := DVID; UEOVBLK := DEOVBLK;
		TIME(HNOW,DLOADTIME)
	      END
	  END;
      FETCHDIR := OK;
      IF NOT OK THEN
	BEGIN UVID := ''; UEOVBLK := 0;
	  RELEASE(GDIRP); GDIRP := NIL
	END
    END
END (*FETCHDIR*) ;

PROCEDURE WRITEDIR(*FUNIT: UNITNUM; FDIR: DIRP*);
  VAR HNOW,LNOW: INTEGER; OK: BOOLEAN; LDE: DIRENTRY;
BEGIN
  WITH UNITABLE[FUNIT],FDIR^[0] DO
    BEGIN OK := UVID = DVID;
      IF OK THEN
	BEGIN TIME(HNOW,LNOW);
	  OK := (LNOW-DLOADTIME <= AGELIMIT) AND
		SYSCOM^.MISCINFO.HASCLOCK;
	  IF NOT OK THEN
	    BEGIN (*NO CLOCK OR TOO OLD*)
	      UNITREAD(FUNIT,LDE,SIZEOF(DIRENTRY),DIRBLK);
	      IF IORESULT = ORD(INOERROR) THEN
		OK := DVID = LDE.DVID;
	    END;
	  IF OK THEN
	    BEGIN (*WE GUESS ALL IS SAFE...WRITEIT*)
	      UNITWRITE(FUNIT,FDIR^,
			(DNUMFILES+1)*SIZEOF(DIRENTRY),DIRBLK);
	      OK := IORESULT = ORD(INOERROR);
	      IF OK THEN TIME(HNOW,DLOADTIME)
	    END
	END;
      IF NOT OK THEN
	BEGIN SYSCOM^.IORSLT := ILOSTUNIT;
	  UVID := ''; UEOVBLK := 0
	END
    END
END (*WRITEDIR*) ;

FUNCTION VOLSEARCH(*VAR FVID: VID; LOOKHARD: BOOLEAN; VAR FDIR: DIRP*);
  VAR LUNIT: UNITNUM; OK: BOOLEAN; HNOW,LNOW: INTEGER;
BEGIN VOLSEARCH := 0; FDIR := NIL;
  OK := FALSE; LUNIT := MAXUNIT;
  IF LENGTH(FVID) > 0 THEN
    REPEAT (*FIRST PASS THRU TABLE*)
      OK := FVID = UNITABLE[LUNIT].UVID;
      IF NOT OK THEN LUNIT := LUNIT-1
    UNTIL OK OR (LUNIT = 0);
  IF OK THEN
    IF UNITABLE[LUNIT].UISBLKD THEN
      WITH SYSCOM^ DO
	BEGIN OK := FALSE;  (*SEE IF GDIRP IS GOOD*)
	  IF GDIRP <> NIL THEN
	    IF FVID = GDIRP^[0].DVID THEN
	      BEGIN TIME(HNOW,LNOW);
		OK := LNOW-GDIRP^[0].DLOADTIME <= AGELIMIT
	      END;
	  IF NOT OK THEN
	    IF FETCHDIR(LUNIT) THEN
	      OK := FVID = GDIRP^[0].DVID
	END;
  IF NOT OK AND LOOKHARD THEN
    BEGIN LUNIT := MAXUNIT; (*CHECK EACH DISK UNIT*)
      REPEAT
	WITH UNITABLE[LUNIT] DO
	  IF UISBLKD THEN
	    IF FETCHDIR(LUNIT) THEN
	      OK := FVID = UVID;
	IF NOT OK THEN LUNIT := LUNIT-1
      UNTIL OK OR (LUNIT = 0)
    END;
  IF OK THEN
    BEGIN VOLSEARCH := LUNIT;
      IF UNITABLE[LUNIT].UISBLKD THEN
	BEGIN FDIR := SYSCOM^.GDIRP;
	  TIME(HNOW,FDIR^[0].DLOADTIME)
	END
    END
END (*VOLSEARCH*) ;

FUNCTION DIRSEARCH(*VAR FTID: TID; FINDPERM: BOOLEAN; FDIR: DIRP*);
  VAR I: DIRRANGE; FOUND: BOOLEAN;
BEGIN DIRSEARCH := 0; FOUND := FALSE; I := 1;
  WHILE (I <= FDIR^[0].DNUMFILES) AND NOT FOUND DO
    BEGIN
      WITH FDIR^[I] DO
	IF DTID = FTID THEN
	  IF FINDPERM = (DACCESS.YEAR <> 100) THEN
	    BEGIN DIRSEARCH := I; FOUND := TRUE END;
      I := I+1
    END
END (*DIRSEARCH*) ;

PROCEDURE DELENTRY(*FINX: DIRRANGE; FDIR: DIRP*);
  VAR I: DIRRANGE;
BEGIN
  WITH FDIR^[0] DO
    BEGIN
      FOR I := FINX TO DNUMFILES-1 DO FDIR^[I] := FDIR^[I+1];
      FDIR^[DNUMFILES].DTID := '';
      DNUMFILES := DNUMFILES-1
    END
END (*DELENTRY*) ;

PROCEDURE INSENTRY(*VAR FENTRY: DIRENTRY; FINX: DIRRANGE; FDIR: DIRP*);
  VAR I: DIRRANGE;
BEGIN
  WITH FDIR^[0] DO
    BEGIN
      FOR I := DNUMFILES DOWNTO FINX DO FDIR^[I+1] := FDIR^[I];
      FDIR^[FINX] := FENTRY;
      DNUMFILES := DNUMFILES+1
    END
END (*INSENTRY*) ;

FUNCTION ENTERTEMP(VAR FTID: TID; FSEGS: INTEGER;
		      FKIND: FILEKIND; FDIR: DIRP): DIRRANGE;
  VAR I,LASTI,DINX: DIRRANGE; LDE: DIRENTRY;

  PROCEDURE FINDMAX(CURINX: DIRRANGE; FIRSTOPEN,NEXTUSED: INTEGER);
    VAR FREEAREA: INTEGER;
  BEGIN
    FREEAREA := NEXTUSED-FIRSTOPEN;
    IF FREEAREA > FSEGS THEN
      BEGIN DINX := CURINX; FSEGS := FREEAREA END
  END (*FINDMAX*) ;

BEGIN (*ENTERTEMP*)
  DINX := 0; LASTI := FDIR^[0].DNUMFILES;
  IF FSEGS = 0 THEN
    BEGIN
      FOR I := 1 TO LASTI DO
	FINDMAX(I,FDIR^[I-1].DLASTBLK,FDIR^[I].DFIRSTBLK);
      FINDMAX(LASTI+1,FDIR^[LASTI].DLASTBLK,FDIR^[0].DEOVBLK)
    END
  ELSE
    BEGIN I := 1;
      WHILE I <= LASTI DO
	BEGIN
	  IF FDIR^[I].DFIRSTBLK-FDIR^[I-1].DLASTBLK >= FSEGS THEN
	    BEGIN DINX := I; I := LASTI END;
	  I := I+1
	END;
      IF DINX = 0 THEN
	IF FDIR^[0].DEOVBLK-FDIR^[LASTI].DLASTBLK >= FSEGS THEN
	  DINX := LASTI+1
    END;
  IF LASTI = MAXDIR THEN DINX := 0
  ELSE
   IF DINX > 0 THEN
    BEGIN
      WITH LDE DO
	BEGIN
	  DFIRSTBLK := FDIR^[DINX-1].DLASTBLK;
	  DLASTBLK := DFIRSTBLK+FSEGS;
	  DFKIND := FKIND; DTID := FTID;
	  DLASTBYTE := FBLKSIZE;
	  WITH DACCESS DO
	    BEGIN MONTH := 0; DAY := 0; YEAR := 100 END
	END;
      INSENTRY(LDE,DINX,FDIR)
    END;
  ENTERTEMP := DINX
END (*ENTERTEMP*) ;

(* FILE STATE HANDLERS *)

PROCEDURE FINIT(*VAR F: FIB; WINDOW: WINDOWP; RECWORDS: INTEGER*);
BEGIN
  WITH F DO
    BEGIN FISOPEN := FALSE; FEOF := TRUE;
      FEOLN := TRUE; FWINDOW := WINDOW;
      IF RECWORDS = 0 THEN FRECSIZE := 1
      ELSE
	IF RECWORDS < 0 THEN FRECSIZE := 0
	ELSE FRECSIZE := RECWORDS+RECWORDS
    END
END (*FINIT*) ;

PROCEDURE FOPEN(*VAR F: FIB; VAR FTITLE: STRING;
		 FOPENOLD: BOOLEAN; JUNK PARAM*);
  LABEL 1;
  VAR LDIR: DIRP; LUNIT: UNITNUM; LINX: DIRRANGE;
      LSEGS: INTEGER; LKIND: FILEKIND; LVID: VID; LTID: TID;
BEGIN SYSCOM^.IORSLT := INOERROR;
  WITH F DO
    IF FISOPEN THEN SYSCOM^.IORSLT := INOTCLOSED
    ELSE
      IF SCANTITLE(FTITLE,LVID,LTID,LSEGS,LKIND) THEN
	BEGIN (*GOT AN OK TITLE*)
	  IF ORD(FOPENOLD) > 1 THEN (*OLD CODE FILE*)
	    FOPENOLD := (ORD(FOPENOLD) = 2) OR (ORD(FOPENOLD) = 4);
	  LUNIT := VOLSEARCH(LVID,TRUE,LDIR);
	  IF LUNIT = 0 THEN SYSCOM^.IORSLT := INOUNIT
	  ELSE
	    WITH UNITABLE[LUNIT] DO
	      BEGIN (*OK...OPEN UP FILE*)
		FISOPEN := TRUE; FEOF := FALSE;
		FEOLN := FALSE; FMODIFIED := FALSE;
		FUNIT := LUNIT; FVID := LVID; FNXTBLK := 0;
		FISBLKD := UISBLKD; FGOTACHAR := FALSE;
		FSOFTBUF := FISBLKD AND (FRECSIZE <> 0);
		IF (LENGTH(LTID) = 0) OR NOT UISBLKD THEN
		 WITH FHEADER DO
		  BEGIN (*DIRECT UNIT OPEN, SET UP DUMMY FHEADER*)
		    DFIRSTBLK := 0; DLASTBLK := 0;
		    IF UISBLKD THEN DLASTBLK := UEOVBLK;
		    DFKIND := LKIND; DTID := '';
		    DLASTBYTE := FBLKSIZE;
		    WITH DACCESS DO
		      BEGIN MONTH := 0; DAY := 0; YEAR := 0 END
		  END
		ELSE
		  BEGIN (*LOOKUP OR ENTER FHEADER IN DIRECTORY*)
		    LINX := DIRSEARCH(LTID,FOPENOLD,LDIR);
		    IF FOPENOLD THEN
		      IF LINX = 0 THEN
			BEGIN SYSCOM^.IORSLT := INOFILE; GOTO 1 END
		      ELSE FHEADER := LDIR^[LINX]
		    ELSE (*OPEN NEW FILE*)
		      IF LINX > 0 THEN
			BEGIN SYSCOM^.IORSLT := IDUPFILE; GOTO 1 END
		      ELSE
			BEGIN (*MAKE A TEMP ENTRY*)
			  IF LKIND = UNTYPEDFILE THEN LKIND := DATAFILE;
			  LINX := ENTERTEMP(LTID,LSEGS,LKIND,LDIR);
			  IF LINX = 0 THEN
			    BEGIN SYSCOM^.IORSLT := INOROOM; GOTO 1 END;
			  FHEADER := LDIR^[LINX]; FMODIFIED := TRUE;
			  WRITEDIR(LUNIT,LDIR)
			END
		  END;
		IF FOPENOLD THEN
		  FMAXBLK := FHEADER.DLASTBLK-FHEADER.DFIRSTBLK
		ELSE FMAXBLK := 0;
		IF FSOFTBUF THEN
		  BEGIN
		    FNXTBYTE := FBLKSIZE; FBUFCHNGD := FALSE;
		    IF FOPENOLD THEN FMAXBYTE := FHEADER.DLASTBYTE
		    ELSE FMAXBYTE := FBLKSIZE;
		    WITH FHEADER DO
		      IF (FRECSIZE = 1) AND (DFKIND = TEXTFILE) THEN
			BEGIN FNXTBLK := 2;
			  IF NOT FOPENOLD THEN
			    BEGIN (*NEW TEXT...NULLS IN FIRST PAGE*)
			      FILLCHAR(FBUFFER,SIZEOF(FBUFFER),0);
			      UNITWRITE(FUNIT,FBUFFER,FBLKSIZE,DFIRSTBLK);
			      UNITWRITE(FUNIT,FBUFFER,FBLKSIZE,DFIRSTBLK+1)
			    END
			END
		  END;
	1:	IF IORESULT <> ORD(INOERROR) THEN
		  BEGIN FISOPEN := FALSE; FEOF := TRUE; FEOLN := TRUE END
	      END
	END
      ELSE SYSCOM^.IORSLT := IBADTITLE
END (*FOPEN*) ;

PROCEDURE FCLOSE(*VAR F: FIB; FTYPE: CLOSETYPE*);
  LABEL 1;
  VAR LINX,DUPINX: DIRRANGE; LDIR: DIRP; FOUND: BOOLEAN;
BEGIN SYSCOM^.IORSLT := INOERROR;
  WITH F DO
    IF FISOPEN AND (FWINDOW <> INPUTFIB^.FWINDOW)
	AND (FWINDOW <> SYSTERM^.FWINDOW) THEN
      BEGIN
	IF FISBLKD THEN
	  WITH FHEADER DO
	    IF LENGTH(DTID) > 0 THEN
	      BEGIN (*FILE IN A DISK DIRECTORY...FIXUP MAYBE*)
		IF FTYPE = CCRUNCH THEN
		  BEGIN FMAXBLK := FNXTBLK;
		    DACCESS.YEAR := 100; FTYPE := CLOCK;
		    IF FSOFTBUF THEN FMAXBYTE := FNXTBYTE
		  END;
		IF FTYPE <> CPURGE THEN FRESET(F);
		IF FMODIFIED OR (DACCESS.YEAR = 100) OR (FTYPE = CPURGE) THEN
		  BEGIN (*HAVE TO CHANGE DIRECTORY ENTRY*)
		    IF FUNIT <> VOLSEARCH(FVID,FALSE,LDIR) THEN
		      BEGIN SYSCOM^.IORSLT := ILOSTUNIT; GOTO 1 END;
		    LINX := 1; FOUND := FALSE;
		    WHILE (LINX <= LDIR^[0].DNUMFILES) AND NOT FOUND DO
		      BEGIN (*LOOK FOR FIRST BLOCK MATCH*)
			FOUND := (LDIR^[LINX].DFIRSTBLK = DFIRSTBLK) AND
				 (LDIR^[LINX].DLASTBLK = DLASTBLK);
			LINX := LINX + 1
		      END;
		    IF NOT FOUND THEN
		      BEGIN SYSCOM^.IORSLT := ILOSTFILE; GOTO 1 END;
		    LINX := LINX - 1; (*CORRECT OVERRUN*)
		    IF ((FTYPE = CNORMAL) AND (LDIR^[LINX].DACCESS.YEAR = 100)) 
			   OR (FTYPE = CPURGE) THEN
			DELENTRY(LINX,LDIR)  (*ZAP FILE OUT OF EXISTANCE*)
		    ELSE
		      BEGIN (*WELL...LOCK IN A PERM DIR ENTRY*)
			DUPINX := DIRSEARCH(DTID,TRUE,LDIR);
			IF (DUPINX <> 0) AND (DUPINX <> LINX) THEN
			  BEGIN (*A DUPLICATE PERM ENTRY...ZAP OLD ONE*)
			    DELENTRY(DUPINX,LDIR);
			    IF DUPINX < LINX THEN LINX := LINX-1
			  END;
			IF LDIR^[LINX].DACCESS.YEAR = 100 THEN
			  IF DACCESS.YEAR = 100 THEN
			    DACCESS := THEDATE
			  ELSE (*LEAVE ALONE...FILER SPECIAL CASE*)
			ELSE
			  IF FMODIFIED AND (THEDATE.MONTH <> 0) THEN
			    DACCESS := THEDATE
			  ELSE
			    DACCESS := LDIR^[LINX].DACCESS;
			DLASTBLK := DFIRSTBLK+FMAXBLK;
			IF FSOFTBUF THEN DLASTBYTE := FMAXBYTE;
			FMODIFIED := FALSE; LDIR^[LINX] := FHEADER
		      END;
		    WRITEDIR(FUNIT,LDIR)
		  END
	      END;
	IF FTYPE = CPURGE THEN
	  IF LENGTH(FHEADER.DTID) = 0 THEN
	    UNITABLE[FUNIT].UVID := '';
1:	FEOF := TRUE; FEOLN := TRUE; FISOPEN := FALSE
      END
END (*FCLOSE*) ;

PROCEDURE FSEEK(*F: FIB; RECNUM: INTEGER*);
BEGIN
END (*FSEEK*) ;

========================================================================================
DOCUMENT :usus Folder:VOL17:system.b.text
========================================================================================


(* INPUT-OUTPUT PRIMITIVES *)

FUNCTION CANTSTRETCH(VAR F: FIB): BOOLEAN;
  LABEL 1;
  VAR LINX: DIRRANGE; FOUND: BOOLEAN; LAVAILBLK: INTEGER; LDIR: DIRP;
BEGIN CANTSTRETCH := TRUE;
  WITH F,FHEADER DO
    IF LENGTH(DTID) > 0 THEN
      BEGIN (*IN A DIRECTORY FOR SURE*)
	IF FUNIT <> VOLSEARCH(FVID,FALSE,LDIR) THEN
	  BEGIN SYSCOM^.IORSLT := ILOSTUNIT; GOTO 1 END;
	FOUND := FALSE; LINX := 1;
	WHILE (LINX <= LDIR^[0].DNUMFILES) AND NOT FOUND DO
	  BEGIN
	    FOUND := (LDIR^[LINX].DFIRSTBLK = DFIRSTBLK) AND
		     (LDIR^[LINX].DLASTBLK = DLASTBLK);
	    LINX := LINX+1
	  END;
	IF NOT FOUND THEN
	  BEGIN SYSCOM^.IORSLT := ILOSTFILE; GOTO 1 END;
	IF LINX > LDIR^[0].DNUMFILES THEN
	  LAVAILBLK := LDIR^[0].DEOVBLK
	ELSE LAVAILBLK := LDIR^[LINX].DFIRSTBLK;
	IF (DLASTBLK < LAVAILBLK) OR (DLASTBYTE < FBLKSIZE) THEN
	  BEGIN
	    WITH LDIR^[LINX-1] DO
	      BEGIN
		DLASTBLK := LAVAILBLK; DLASTBYTE := FBLKSIZE;
		WRITEDIR(FUNIT,LDIR);
		IF IORESULT <> ORD(INOERROR) THEN GOTO 1
	      END;
	    FEOF := FALSE; FEOLN := FALSE; FGOTACHAR := FALSE;
	    DLASTBLK := LAVAILBLK; DLASTBYTE := FBLKSIZE;
	    DACCESS.YEAR := 100; CANTSTRETCH := FALSE
	  END
      END;
  IF FALSE THEN
1:  BEGIN F.FEOF := TRUE; F.FEOLN := TRUE END
END (*CANTSTRETCH*) ;

PROCEDURE FRESET(*VAR F: FIB*);
  VAR BIGGER: BOOLEAN;
BEGIN SYSCOM^.IORSLT := INOERROR;
  WITH F DO
    IF FISOPEN THEN
      BEGIN FGOTACHAR := FALSE; FEOLN := FALSE; FEOF := FALSE;
	IF FISBLKD THEN
	  BEGIN BIGGER := FNXTBLK > FMAXBLK;
	    IF BIGGER THEN FMAXBLK := FNXTBLK;
	    IF FSOFTBUF THEN
	      BEGIN
		IF BIGGER THEN FMAXBYTE := FNXTBYTE
		ELSE
		  IF FNXTBLK = FMAXBLK THEN
		    IF FNXTBYTE > FMAXBYTE THEN
			FMAXBYTE := FNXTBYTE;
		IF FBUFCHNGD THEN
		  BEGIN FBUFCHNGD := FALSE; FMODIFIED := TRUE;
		    UNITWRITE(FUNIT,FBUFFER,FBLKSIZE,
				    FHEADER.DFIRSTBLK+FNXTBLK-1)
		  END;
		FNXTBYTE := FBLKSIZE
	      END;
	    FNXTBLK := 0;
	    IF FSOFTBUF THEN
	      IF (FRECSIZE = 1) AND (FHEADER.DFKIND = TEXTFILE) THEN
		FNXTBLK := 2
	  END
      END
END (*FRESET*) ;

FUNCTION FBLOCKIO(*VAR F: FIB; VAR A: WINDOW;
		   NBLOCKS,RBLOCK: INTEGER; DOREAD: BOOLEAN*);
  LABEL 1;
BEGIN FBLOCKIO := 0; SYSCOM^.IORSLT := INOERROR;
  WITH F DO
    IF FISOPEN AND (NBLOCKS >= 0) THEN
      IF FISBLKD THEN
	WITH FHEADER DO
	  BEGIN
	    IF RBLOCK < 0 THEN RBLOCK := FNXTBLK;
	    RBLOCK := DFIRSTBLK+RBLOCK;
	    IF RBLOCK+NBLOCKS > DLASTBLK THEN
	      IF DOREAD THEN NBLOCKS := DLASTBLK-RBLOCK
	      ELSE
		IF CANTSTRETCH(F) THEN NBLOCKS := DLASTBLK-RBLOCK
		ELSE
		  IF RBLOCK+NBLOCKS > DLASTBLK THEN
		    NBLOCKS := DLASTBLK-RBLOCK;
	    FEOF := RBLOCK >= DLASTBLK;
	    IF NOT FEOF THEN
	      BEGIN
		IF DOREAD THEN
		  UNITREAD(FUNIT,A,NBLOCKS*FBLKSIZE,RBLOCK)
		ELSE
		  BEGIN FMODIFIED := TRUE;
		    UNITWRITE(FUNIT,A,NBLOCKS*FBLKSIZE,RBLOCK)
		  END;
		IF IORESULT <> ORD(INOERROR) THEN GOTO 1;
		FBLOCKIO := NBLOCKS;
		RBLOCK := RBLOCK+NBLOCKS;
		FEOF := RBLOCK = DLASTBLK;
		FNXTBLK := RBLOCK-DFIRSTBLK;
		FMAXBYTE := FBLKSIZE;
		IF FNXTBLK > FMAXBLK THEN FMAXBLK := FNXTBLK
	      END
	  END
      ELSE
	BEGIN FBLOCKIO := NBLOCKS;
	  IF DOREAD THEN
	    UNITREAD(FUNIT,A,NBLOCKS*FBLKSIZE,RBLOCK)
	  ELSE
	    UNITWRITE(FUNIT,A,NBLOCKS*FBLKSIZE,RBLOCK);
	  IF IORESULT = ORD(INOERROR) THEN
	    IF DOREAD THEN
	      BEGIN RBLOCK := NBLOCKS*FBLKSIZE;
		RBLOCK := RBLOCK+SCAN(-RBLOCK,<>CHR(0),A[RBLOCK-1]);
		RBLOCK := (RBLOCK+FBLKSIZE-1) DIV FBLKSIZE;
		FBLOCKIO := RBLOCK;
		FEOF := RBLOCK < NBLOCKS
	      END
	    ELSE
	  ELSE FBLOCKIO := 0
	END
    ELSE SYSCOM^.IORSLT := INOTOPEN;
1:
END (*FBLOCKIO*) ;

PROCEDURE FGET(*VAR F: FIB*);
  LABEL 1;
  VAR LEFTOGET,WININX,LEFTINBUF,AMOUNT: INTEGER;
      DONE: BOOLEAN;
BEGIN SYSCOM^.IORSLT := INOERROR;
  WITH F DO
    IF FISOPEN THEN
      BEGIN
	IF FSOFTBUF THEN
	  WITH FHEADER DO
	    BEGIN
	      LEFTOGET := FRECSIZE; WININX := 0;
	      REPEAT
		IF FNXTBLK = FMAXBLK THEN
		  IF FNXTBYTE+LEFTOGET > FMAXBYTE THEN GOTO 1
		  ELSE LEFTINBUF := DLASTBYTE-FNXTBYTE
		ELSE LEFTINBUF := FBLKSIZE-FNXTBYTE;
		AMOUNT := LEFTOGET;
		IF AMOUNT > LEFTINBUF THEN AMOUNT := LEFTINBUF;
		IF AMOUNT > 0 THEN
		  BEGIN
		    MOVELEFT(FBUFFER[FNXTBYTE],FWINDOW^[WININX],AMOUNT);
		    FNXTBYTE := FNXTBYTE+AMOUNT;
		    WININX := WININX+AMOUNT;
		    LEFTOGET := LEFTOGET-AMOUNT
		  END;
		DONE := LEFTOGET = 0;
		IF NOT DONE THEN
		  BEGIN FNXTBYTE := 0; (*GET NEXT BLOCK*)
		    IF FBUFCHNGD THEN
		      BEGIN FBUFCHNGD := FALSE; FMODIFIED := TRUE;
			UNITWRITE(FUNIT,FBUFFER,FBLKSIZE,DFIRSTBLK+FNXTBLK-1)
		      END;
		    IF IORESULT <> ORD(INOERROR) THEN GOTO 1;
		    UNITREAD(FUNIT,FBUFFER,FBLKSIZE,DFIRSTBLK+FNXTBLK);
		    FNXTBLK := FNXTBLK+1;
		    IF IORESULT <> ORD(INOERROR) THEN GOTO 1
		  END
	      UNTIL DONE
	    END
	ELSE
	  BEGIN
	    UNITREAD(FUNIT,FWINDOW^,FRECSIZE);
	    IF IORESULT <> ORD(INOERROR) THEN GOTO 1
	  END;
	IF FRECSIZE = 1 THEN (*FILE OF CHAR*)
	  BEGIN FEOLN := FALSE; FGOTACHAR := TRUE;
	    IF FWINDOW^[0] = CHR(EOL) THEN
	      BEGIN FWINDOW^[0] := ' '; FEOLN := TRUE END;
	    IF FWINDOW^[0] = CHR(0) THEN
	      BEGIN (*EOF HANDLING*)
		IF FSOFTBUF AND (FHEADER.DFKIND = TEXTFILE) THEN
		  BEGIN (*END OF 2 BLOCK PAGE*)
		    IF ODD(FNXTBLK) THEN FNXTBLK := FNXTBLK+1;
		    FNXTBYTE := FBLKSIZE; FGET(F)
		  END
		ELSE
		  BEGIN FWINDOW^[0] := ' '; GOTO 1 END
	      END
	  END
      END
    ELSE SYSCOM^.IORSLT := INOTOPEN;
  IF FALSE THEN
1:  BEGIN F.FEOF := TRUE; F.FEOLN := TRUE END
END (*FGET*) ;

PROCEDURE FPUT(*VAR F: FIB*);
  LABEL 1;
  VAR LEFTOPUT,WININX,LEFTINBUF,AMOUNT: INTEGER;
      DONE: BOOLEAN;
BEGIN SYSCOM^.IORSLT := INOERROR;
  WITH F DO
    IF FISOPEN THEN
      BEGIN
	IF FSOFTBUF THEN
	  WITH FHEADER DO
	    BEGIN
	      LEFTOPUT := FRECSIZE; WININX := 0;
	      REPEAT
		IF DFIRSTBLK+FNXTBLK = DLASTBLK THEN
		  IF FNXTBYTE+LEFTOPUT > DLASTBYTE THEN
		    IF CANTSTRETCH(F) THEN GOTO 1
		    ELSE LEFTINBUF := FBLKSIZE-FNXTBYTE
		  ELSE LEFTINBUF := DLASTBYTE-FNXTBYTE
		ELSE LEFTINBUF := FBLKSIZE-FNXTBYTE;
		AMOUNT := LEFTOPUT;
		IF AMOUNT > LEFTINBUF THEN AMOUNT := LEFTINBUF;
		IF AMOUNT > 0 THEN
		  BEGIN FBUFCHNGD := TRUE;
		    MOVELEFT(FWINDOW^[WININX],FBUFFER[FNXTBYTE],AMOUNT);
		    FNXTBYTE := FNXTBYTE+AMOUNT;
		    WININX := WININX+AMOUNT;
		    LEFTOPUT := LEFTOPUT-AMOUNT
		  END;
		DONE := LEFTOPUT = 0;
		IF NOT DONE THEN
		  BEGIN FNXTBYTE := 0; (*WRITE BUFFER...MAYBE GET NEXT*)
		    IF FBUFCHNGD THEN
		      BEGIN FBUFCHNGD := FALSE; FMODIFIED := TRUE;
			UNITWRITE(FUNIT,FBUFFER,FBLKSIZE,DFIRSTBLK+FNXTBLK-1)
		      END;
		    IF IORESULT <> ORD(INOERROR) THEN GOTO 1;
		    IF FNXTBLK < FMAXBLK THEN
		      UNITREAD(FUNIT,FBUFFER,FBLKSIZE,DFIRSTBLK+FNXTBLK)
		    ELSE
		      IF FRECSIZE = 1 THEN
			FILLCHAR(FBUFFER,FBLKSIZE,CHR(0));
		    FNXTBLK := FNXTBLK+1;
		    IF IORESULT <> ORD(INOERROR) THEN GOTO 1
		  END
	      UNTIL DONE;
	      IF FRECSIZE = 1 THEN
		IF FWINDOW^[0] = CHR(EOL) THEN
		  IF DFKIND = TEXTFILE THEN
		    IF (FNXTBYTE >= FBLKSIZE-80) AND NOT ODD(FNXTBLK) THEN
		      BEGIN
			FNXTBYTE := FBLKSIZE-1;
			FWINDOW^[0] := CHR(0);
			FPUT(F)
		      END

	    END
	ELSE
	  BEGIN
	    UNITWRITE(FUNIT,FWINDOW^,FRECSIZE);
	    IF IORESULT <> ORD(INOERROR) THEN GOTO 1
	  END
      END
    ELSE SYSCOM^.IORSLT := INOTOPEN;
  IF FALSE THEN
1:  BEGIN F.FEOF := TRUE; F.FEOLN := TRUE END
END (*FPUT*) ;

FUNCTION FEOF(*VAR F: FIB*);
BEGIN FEOF := F.FEOF END;

(* TEXT FILE INTRINSICS *)

FUNCTION FEOLN(*VAR F: FIB*);
BEGIN FEOLN := F.FEOLN END;

PROCEDURE FWRITELN(*VAR F: FIB*);
BEGIN
  F.FWINDOW^[0] := CHR(EOL); FPUT(F)
END (*FWRITELN*) ;

PROCEDURE FWRITECHAR(*VAR F: FIB; CH: CHAR; RLENG: INTEGER*);
  LABEL  1;
BEGIN
  WITH F DO
    IF FISOPEN THEN
      IF FSOFTBUF THEN
	BEGIN
	  WHILE RLENG > 1 DO
	    BEGIN FWINDOW^[0] := ' '; FPUT(F);
	      RLENG := RLENG-1
	    END;
	  FWINDOW^[0] := CH; FPUT(F)
	END
      ELSE
	BEGIN
	  WHILE RLENG > 1 DO
	    BEGIN FWINDOW^[0] := ' ';
	      UNITWRITE(FUNIT,FWINDOW^,1);
	      RLENG := RLENG-1
	    END;
	  FWINDOW^[0] := CH;
	  UNITWRITE(FUNIT,FWINDOW^,1)
	END
    ELSE SYSCOM^.IORSLT := INOTOPEN;
1:
END (*FWRITECHAR*) ;

PROCEDURE FWRITEINT(*VAR F: FIB; I,RLENG: INTEGER*);
  VAR POT,COL: INTEGER; CH: CHAR;
      SUPPRESSING: BOOLEAN; S: STRING[10];
BEGIN COL := 1; SUPPRESSING := TRUE;
  IF I < 0 THEN
    BEGIN I := ABS(I); S[1] := '-'; COL := 2;
      IF I < 0 THEN I := 0
    END;
  FOR POT := 4 DOWNTO 0 DO
    BEGIN CH := CHR(I DIV IPOT[POT] + ORD('0'));
      IF (CH = '0') AND (POT > 0) AND SUPPRESSING THEN
      ELSE (*FORMAT THE CHAR*)
	BEGIN SUPPRESSING := FALSE;
	  S[COL] := CH; COL := COL+1;
	  IF CH <> '0' THEN I := I MOD IPOT[POT]
	END
    END;
  S[0] := CHR(COL-1);
  FWRITESTRING(F,S,RLENG)
END (*FWRITEINT*) ;

PROCEDURE FWRITEREAL(*VAR F: FIB; X: REAL; W,D: INTEGER*);
  VAR I,J,TRUNCX,SINX: INTEGER;
      CH: CHAR; S: STRING[20];

  PROCEDURE PUTCH(CH: CHAR);
  BEGIN
    S[SINX] := CH; SINX := SINX+1
  END (*PUTCH*) ;

BEGIN
    S[0] := CHR(20); SINX := 1; PUTCH(' ');
    IF (W < 0) OR (D < 0) OR (D > 6) THEN
      BEGIN D := 0; W := 0 END;
    IF X < 0 THEN
      BEGIN X := ABS(X); S[1] := '-' END;
    IF X = 0 THEN I := 0
    ELSE I := TRUNC(LOG(X));
    IF I > 0 THEN X := X/PWROFTEN(I)
    ELSE
      IF I < 0 THEN X := X*PWROFTEN(ABS(I));
    IF X = 0 THEN
      BEGIN CH := '0'; TRUNCX := 0 END
    ELSE
      REPEAT TRUNCX := TRUNC(X);
	CH := CHR(TRUNCX+ORD('0'));
	IF TRUNCX = 0 THEN
	  BEGIN I := I-1; X := X*10 END
      UNTIL TRUNCX <> 0;
    PUTCH(CH); PUTCH('.');
    X := (X-TRUNCX)*10; J := 0;
    REPEAT TRUNCX := TRUNC(X);
      PUTCH(CHR(TRUNCX+ORD('0')));
      X := (X-TRUNCX)*10;
      J := J+1
    UNTIL J = 6;
    SINX := 3;
    IF (I > 0) AND (I < 6) THEN
      IF (6-I) >= D THEN
	BEGIN
	  MOVELEFT(S[SINX+1],S[SINX],I);
	  SINX := SINX+I; S[SINX] := '.';
	  I := 0
	END;
    IF D = 0 THEN
      BEGIN D := 9;
	WHILE S[D] = '0' DO D := D-1;
	D := D-SINX;
	IF D = 0 THEN D := 1
      END;
    SINX := SINX+D+1;
    IF SINX <= 9 THEN
      IF S[SINX] >= '5' THEN
	BEGIN
	  FOR J := SINX-1 DOWNTO 2 DO
	    IF S[J] <> '.' THEN
	      BEGIN
		S[J] := SUCC(S[J]);
		IF S[J] > '9' THEN S[J] := '0'
		ELSE J := 0
	      END;
	  IF J > 0 THEN
	    BEGIN SINX := SINX+1;
	      MOVERIGHT(S[2],S[3],12);
	      S[2] := '1'
	    END
	END;
    IF I <> 0 THEN
      BEGIN PUTCH('E');
	IF I < 0 THEN
	  BEGIN PUTCH('-'); I := ABS(I) END;
	IF I > 9 THEN
	  BEGIN PUTCH(CHR(I DIV 10 + ORD('0')));
	    I := I MOD 10
	  END;
	PUTCH(CHR(I + ORD('0')))
      END;
    S[0] := CHR(SINX-1);
    FWRITESTRING(F,S,W)
END (*FWRITEREAL*) ;

PROCEDURE FWRITESTRING(*VAR F: FIB; VAR S: STRING; RLENG: INTEGER*);
  VAR SINX: INTEGER;
BEGIN
  WITH F DO
    IF FISOPEN THEN
      BEGIN
	IF RLENG <= 0 THEN RLENG := LENGTH(S);
	IF RLENG > LENGTH(S) THEN
	  BEGIN FWRITECHAR(F,' ',RLENG-LENGTH(S)); RLENG := LENGTH(S) END;
	IF FSOFTBUF THEN
	  BEGIN SINX := 1;
	    WHILE (SINX <= RLENG) AND NOT FEOF DO
	      BEGIN FWINDOW^[0] := S[SINX]; FPUT(F); SINX := SINX+1 END
	  END
	ELSE
	  UNITWRITE(FUNIT,S[1],RLENG)
      END
    ELSE SYSCOM^.IORSLT := INOTOPEN
END (*FWRITESTRING*) ;

PROCEDURE FWRITEBYTES(*VAR F: FIB; VAR A: WINDOW; RLENG,ALENG: INTEGER*);
  VAR AINX: INTEGER;
BEGIN
  WITH F DO
    IF FISOPEN THEN
      BEGIN
	IF RLENG > ALENG THEN
	  BEGIN FWRITECHAR(F,' ',RLENG-ALENG); RLENG := ALENG END;
	IF FSOFTBUF THEN
	  BEGIN AINX := 0;
	    WHILE (AINX < RLENG) AND NOT FEOF DO
	      BEGIN FWINDOW^[0] := A[AINX]; FPUT(F); AINX := AINX+1 END
	  END
	ELSE
	  UNITWRITE(FUNIT,A,RLENG)
      END
    ELSE SYSCOM^.IORSLT := INOTOPEN
END (*FWRITEBYTES*) ;

PROCEDURE FREADLN(*VAR F: FIB*);
BEGIN
  WHILE NOT F.FEOLN DO FGET(F);
  F.FGOTACHAR := FALSE; F.FEOLN := FALSE
END (*FREADLN*) ;

PROCEDURE FREADCHAR(*VAR F: FIB; VAR CH: CHAR*);
BEGIN
  WITH F DO
    IF FISOPEN THEN
      BEGIN SYSCOM^.IORSLT := INOERROR;
	IF NOT FGOTACHAR THEN FGET(F);
	CH := FWINDOW^[0];
	FGOTACHAR := FALSE
      END
    ELSE SYSCOM^.IORSLT := INOTOPEN
END (*FREADCHAR*) ;

PROCEDURE FREADINT(*VAR F: FIB; VAR I: INTEGER*);
  LABEL 1;
  VAR CH: CHAR; NEG,IVALID: BOOLEAN;
BEGIN
  WITH F DO
    IF FISOPEN THEN
      BEGIN I := 0; NEG := FALSE; IVALID := FALSE;
	IF NOT FGOTACHAR THEN FGET(F);
	WHILE (FWINDOW^[0] = ' ') AND NOT FEOF DO FGET(F);
	IF FEOF THEN GOTO 1;
	CH := FWINDOW^[0];
	IF (CH = '+') OR (CH = '-') THEN
	  BEGIN NEG := CH = '-'; FGET(F); CH := FWINDOW^[0] END;
	WHILE (CH IN ['0'..'9']) AND NOT FEOF DO
	  BEGIN IVALID := TRUE;
	    I := I*10 + ORD(CH) - ORD('0');
	    FGET(F); CH := FWINDOW^[0]
	  END;
	IF IVALID OR FEOF THEN
	  IF NEG THEN I := -I ELSE (*NADA*)
	ELSE SYSCOM^.IORSLT := IBADFORMAT
      END
    ELSE SYSCOM^.IORSLT := INOTOPEN;
1:
END (*FREADINT*) ;

PROCEDURE FREADREAL(*VAR F: FIB; VAR X: REAL*);
  LABEL 1;
  VAR CH: CHAR; NEG,XVALID: BOOLEAN; IPOT: INTEGER;
      NUMBERS: SET OF '0'..'9';
BEGIN
  WITH F DO
    IF FISOPEN THEN
      BEGIN X := 0; NEG := FALSE; XVALID := FALSE;
	NUMBERS := ['0'..'9'];
	IF NOT FGOTACHAR THEN FGET(F);
	WHILE (FWINDOW^[0] = ' ') AND NOT FEOF DO FGET(F);
	IF FEOF THEN GOTO 1;
	CH := FWINDOW^[0];
	IF (CH = '+') OR (CH = '-') THEN
	  BEGIN NEG := CH = '-'; FGET(F); CH := FWINDOW^[0] END;
	WHILE (CH IN NUMBERS) AND NOT FEOF DO
	  BEGIN XVALID := TRUE;
	    X := X*10 + (ORD(CH)-ORD('0'));
	    FGET(F); CH := FWINDOW^[0]
	  END;
	IF FEOF THEN GOTO 1;
	IPOT := -1;
	IF CH = '.' THEN
	  BEGIN IPOT := 0;
	    REPEAT FGET(F); CH := FWINDOW^[0];
	      IF CH IN NUMBERS THEN
		BEGIN XVALID := TRUE; IPOT := IPOT + 1;
		  X := X + (ORD(CH)-ORD('0'))/PWROFTEN(IPOT)
		END
	    UNTIL FEOF OR NOT (CH IN NUMBERS);
	    IF FEOF THEN GOTO 1
	  END;
	IF ((CH = 'e') OR (CH = 'E')) AND (XVALID OR (IPOT < 0)) THEN
	  BEGIN FGOTACHAR := FALSE; FREADINT(F,IPOT);
	    IF FEOF THEN GOTO 1;
	    IF NOT XVALID THEN X := 1; XVALID := TRUE;
	    IF IPOT < 0 THEN X := X/PWROFTEN(ABS(IPOT))
	    ELSE X := X*PWROFTEN(IPOT)
	  END;
	IF XVALID THEN
	  IF NEG THEN X := -X
	  ELSE
	ELSE SYSCOM^.IORSLT := IBADFORMAT
      END
    ELSE SYSCOM^.IORSLT := INOTOPEN;
1:
END (*FREADREAL*) ;

PROCEDURE FREADSTRING(*VAR F: FIB; VAR S: STRING; SLENG: INTEGER*);
  VAR SINX: INTEGER; CH: CHAR;
BEGIN
  WITH F DO
    IF FISOPEN THEN
      BEGIN SINX := 1;
	IF FEOLN THEN FREADLN(F);
	S[0] := CHR(SLENG); (*NO INV INDEX*)
	WHILE (SINX <= SLENG) AND NOT (FEOLN OR FEOF) DO
	  BEGIN
	    IF NOT FGOTACHAR THEN FGET(F);
	    IF NOT FEOLN THEN
	      BEGIN
		CH := FWINDOW^[0]; FGOTACHAR := FALSE;
		IF FUNIT = 1 THEN
		  IF CHECKDEL(CH,SINX) THEN
		  ELSE
		    BEGIN S[SINX] := CH; SINX := SINX + 1 END
		ELSE
		  BEGIN S[SINX] := CH; SINX := SINX + 1 END
	      END
	  END;
	S[0] := CHR(SINX - 1);
	WHILE NOT FEOLN DO FGET(F)
      END
    ELSE SYSCOM^.IORSLT := INOTOPEN
END (*FREADSTRING*) ;

(* STRING VARIABLE INTRINSICS *)

PROCEDURE SCONCAT(*VAR SRC,DEST: STRING; DESTLENG: INTEGER*);
BEGIN
  IF LENGTH(SRC)+LENGTH(DEST) <= DESTLENG THEN
    BEGIN
      MOVELEFT(SRC[1],DEST[LENGTH(DEST)+1],LENGTH(SRC));
      DEST[0] := CHR(LENGTH(SRC)+LENGTH(DEST))
    END
END (*SCONCAT*) ;

PROCEDURE SINSERT(*VAR SRC,DEST: STRING; DESTLENG,INSINX: INTEGER*);
  VAR ONRIGHT: INTEGER;
BEGIN
  IF (INSINX > 0) AND (LENGTH(SRC) > 0) AND
      (LENGTH(SRC)+LENGTH(DEST) <= DESTLENG) THEN
    BEGIN
      ONRIGHT := LENGTH(DEST)-INSINX+1;
      IF ONRIGHT > 0 THEN
	BEGIN
	  MOVERIGHT(DEST[INSINX],DEST[INSINX+LENGTH(SRC)],ONRIGHT);
	  ONRIGHT := 0
	END;
      IF ONRIGHT = 0 THEN
	BEGIN
	  MOVELEFT(SRC[1],DEST[INSINX],LENGTH(SRC));
	  DEST[0] := CHR(LENGTH(DEST)+LENGTH(SRC))
	END
    END
END (*SINSERT*) ;

PROCEDURE SCOPY(*VAR SRC,DEST: STRING; SRCINX,COPYLENG: INTEGER*);
BEGIN DEST := '';
  IF (SRCINX > 0) AND (COPYLENG > 0) AND
      (SRCINX+COPYLENG-1 <= LENGTH(SRC)) THEN
    BEGIN
      MOVELEFT(SRC[SRCINX],DEST[1],COPYLENG);
      DEST[0] := CHR(COPYLENG)
    END
END (*SCOPY*) ;

PROCEDURE SDELETE(*VAR DEST: STRING; DELINX,DELLENG: INTEGER*);
  VAR ONRIGHT: INTEGER;
BEGIN
  IF (DELINX > 0) AND (DELLENG > 0) THEN
    BEGIN
      ONRIGHT := LENGTH(DEST)-DELINX-DELLENG+1;
      IF ONRIGHT = 0 THEN DEST[0] := CHR(DELINX-1)
      ELSE
	IF ONRIGHT > 0 THEN
	  BEGIN
	    MOVELEFT(DEST[DELINX+DELLENG],DEST[DELINX],ONRIGHT);
	    DEST[0] := CHR(LENGTH(DEST)-DELLENG)
	  END
    END
END (*SDELETE*) ;

FUNCTION SPOS(*VAR TARGET,SRC: STRING*);
  LABEL 1;
  VAR I,LASTI: INTEGER; FIRSTCH: CHAR; TEMP: STRING;
BEGIN SPOS := 0;
  IF LENGTH(TARGET) > 0 THEN
    BEGIN FIRSTCH := TARGET[1];
      LASTI := LENGTH(SRC)-LENGTH(TARGET)+1;
      I := 1; TEMP[0] := TARGET[0];
      WHILE I <= LASTI DO
	BEGIN
	  IF SRC[I] = FIRSTCH THEN
	    BEGIN
	      MOVELEFT(SRC[I],TEMP[1],LENGTH(TARGET));
	      IF TEMP = TARGET THEN
		BEGIN SPOS := I; GOTO 1 END
	    END;
	  I := I+1
	END
    END;
1:
END (*SPOS*) ;

(*MAIN STUFF OF SYSTEM*)

PROCEDURE COMPILE;
  LABEL 1;
  VAR LTITLE: STRING[25];
BEGIN
  WITH USERINFO DO
    IF NOT GOTSYM THEN
      BEGIN WRITELN(OUTPUT);
	WRITE(OUTPUT,'No workfile')
      END
    ELSE
      BEGIN
	LTITLE := CONCAT(SYMVID,':',SYMTID);
	FOPEN(SYMFIBP^,LTITLE,TRUE,NIL);
	IF IORESULT <> ORD(INOERROR) THEN
	  BEGIN WRITELN(OUTPUT);
	    WRITE(OUTPUT,'Lost workfile!');
	    GOTSYM := FALSE; GOTO 1
	  END;
	LTITLE := '*SYSTEM.WRK.CODE';
	FOPEN(CODEFIBP^,LTITLE,FALSE,NIL);
	ERRNUM := 0; ERRBLK := 0; ERRSYM := 0;
	WRITELN(OUTPUT,'Compiling...');
	COMPILER(USERINFO);
	RELEASE(EMPTYHEAP);
	FCLOSE(SYMFIBP^,CNORMAL);
	IF SYSCOM^.MISCINFO.HAS8510A THEN UNITCLEAR(3);
	IF ERRNUM > 0 THEN
	  BEGIN
	    FCLOSE(CODEFIBP^,CPURGE);
	    GOTCODE := FALSE;
	    IF STUPID THEN EDITOR;
	    ERRNUM := 0
	  END
	ELSE
	  BEGIN
	    CODEVID := CODEFIBP^.FVID;
	    CODETID := CODEFIBP^.FHEADER.DTID;
	    FCLOSE(CODEFIBP^,CLOCK);
	    GOTCODE := TRUE
	  END
      END;
1:
END (*COMPILE*) ;

PROCEDURE EXECUTE(*RUNWORKFILE: BOOLEAN*);
  LABEL 1;
  VAR LSEG: SEGRANGE; LTITLE: STRING[25];
      LSEGTABLE: ARRAY [SEGRANGE] OF SEGDESC;
BEGIN
  IF RUNWORKFILE THEN
    BEGIN WRITELN(OUTPUT);
      LTITLE := CONCAT(USERINFO.CODEVID,':',USERINFO.CODETID)
    END
  ELSE
    BEGIN
      PL := 'Execute? ';
      IF NOT SYSCOM^.MISCINFO.SLOWTERM THEN
	INSERT(' what file',PL,8);
      PROMPT; READLN(INPUT,LTITLE);
      IF LENGTH(LTITLE) = 0 THEN GOTO 1;
      IF LTITLE[LENGTH(LTITLE)] = '.' THEN
	DELETE(LTITLE,LENGTH(LTITLE),1)
      ELSE
	LTITLE := CONCAT(LTITLE,'.CODE')
    END;
  FOPEN(USERINFO.CODEFIBP^,LTITLE,TRUE,NIL);
  IF IORESULT <> ORD(INOERROR) THEN
    BEGIN
      IF RUNWORKFILE THEN
	BEGIN USERINFO.GOTCODE := FALSE;
	  WRITE(OUTPUT,'Lost workfile!')
	END
      ELSE
	IF IORESULT = ORD(IBADTITLE) THEN
	  WRITE(OUTPUT,'Illegal title')
	ELSE
	  WRITE(OUTPUT,'Can''t find file');
      GOTO 1
    END;
  IF USERINFO.CODEFIBP^.FHEADER.DFKIND <> CODEFILE THEN
    WRITE(OUTPUT,'Must be a code file')
  ELSE
    WITH SYSCOM^,USERINFO DO
      BEGIN
	UNITREAD(CODEFIBP^.FUNIT,LSEGTABLE,(MAXSEG+1)*4,
			CODEFIBP^.FHEADER.DFIRSTBLK);
	IF IORESULT <> ORD(INOERROR) THEN 
	  BEGIN
	    IF RUNWORKFILE THEN WRITELN(OUTPUT);
	    WRITE(OUTPUT,'Bad block # 0'); GOTO 1
	  END;
	FOR LSEG := 1 TO MAXSEG DO
	  IF (LSEG = 1) OR (LSEG >= 10) THEN
	    WITH SEGTABLE[LSEG],LSEGTABLE[LSEG] DO
	      BEGIN CODEUNIT := CODEFIBP^.FUNIT;
		CODEDESC.CODELENG := CODELENG;
		CODEDESC.DISKADDR := DISKADDR + CODEFIBP^.FHEADER.DFIRSTBLK
	      END;
	FRESET(INPUTFIB^); FRESET(OUTPUTFIB^); FRESET(SYSTERM^);
	WRITELN(OUTPUT,'Running...');
	USERPROGRAM(INPUTFIB^,OUTPUTFIB^);
	IF UNITBUSY(1) OR UNITBUSY(2) THEN UNITCLEAR(1);
	FRESET(INPUTFIB^); FRESET(OUTPUTFIB^); FRESET(SYSTERM^)
      END;
1: FCLOSE(USERINFO.CODEFIBP^,CNORMAL)
END (*EXECUTE*) ;

PROCEDURE COMMAND;
  VAR CH: CHAR; BADCOMMAND: BOOLEAN;
BEGIN BADCOMMAND := FALSE;
  REPEAT
    RELEASE(EMPTYHEAP);
    PL :=
'Command: E(dit, R(un, F(ile, C(ompile, X(ecute, D(ebug, I(nit, H(alt';
    PROMPT; CH := GETCHAR(BADCOMMAND); CLEARSCREEN;
    BADCOMMAND := NOT (CH IN ['E','D','R','F','C','X','U','I','H']);
    CASE CH OF
      'E':  EDITOR;
  'D','R':  BEGIN
	      IF NOT USERINFO.GOTCODE THEN COMPILE;
	      IF USERINFO.GOTCODE THEN
		BEGIN CLEARSCREEN;
		  IF CH = 'R' THEN EXECUTE(TRUE)
		  ELSE DEBUGGER
		END
	    END;
      'F':  FILEHANDLER;
      'C':  COMPILE;
      'X':  EXECUTE(FALSE);
      'U':  BEGIN
	      FRESET(INPUTFIB^); FRESET(OUTPUTFIB^); FRESET(SYSTERM^);
	      USERPROGRAM(INPUTFIB^,OUTPUTFIB^); UNITCLEAR(1);
	      FRESET(INPUTFIB^); FRESET(OUTPUTFIB^); FRESET(SYSTERM^)
	    END;
      'I':  INITIALIZE;
      'H':  EMPTYHEAP := NIL
    END
  UNTIL CH = 'H'
END (*COMMAND*) ;

BEGIN (*UCSD PASCAL SYSTEM*)
  EMPTYHEAP := NIL;
  INITIALIZE;
  REPEAT
    COMMAND;
    IF EMPTYHEAP <> NIL THEN
      INITIALIZE
  UNTIL EMPTYHEAP = NIL;
  CLEARSCREEN;
  PL := 'Open for business...'; PROMPT
END (*PASCALSYSTEM*) .

(*$I XOP:GLOBALS.TEXT *)
(*$I XOP:SYSTEM.A.TEXT *)
(*$I XOP:SYSTEM.B.TEXT *)
(*$I XOP:GLOBALS.TEXT *)
(*$I XOP:SYSTEM.A.TEXT *)
(*$I XOP:SYSTEM.B.TEXT *)

========================================================================================
DOCUMENT :usus Folder:VOL17:vol17.doc.text
========================================================================================

                             USUS Library Volume 17
                                        
                            UCSD Version I.3 Sources

SYSTEM.A.TEXT     48  The Operating System
SYSTEM.B.TEXT     44    an include file of the operating system
LINKER.TEXT        8  The Linker 
FILER.TEXT        50  The Filer
YALOE.TEXT        44  Yaloe (I.3 didn't have a screen editor)
GLOBALS.TEXT      22  Globals for the system
COMP.A.TEXT       40  First file of the Compiler
COMP.B.TEXT       34    an include file
COMP.C.TEXT       44      ditto
COMP.D.TEXT       52      ditto
COMP.E.TEXT       46      ditto
COMP.F.TEXT       34      ditto
BOOTER.TEXT        4  The bootstrap copier
XFER.TEXT          6  A single disk file transfer program
VOL11.DOC.TEXT     6  You're reading it
__________________________________________________________________________

Please transfer the text below to a disk label if you copy this volume.

    USUS Volume 17 -***- USUS Software Library
                         
   For not-for-profit use by USUS members only.
  May be used and distributed only according to 
      stated policy and the author's wishes.



This volume was assembled by George Schreyer from material collected by
the Library committee.

__________________________________________________________________________




========================================================================================
DOCUMENT :usus Folder:VOL17:xfer.text
========================================================================================

(*$I-*)  (*no bomb for errors in I/O*)
PROGRAM LARGEFILESINGLEDISKTRANSFER;
(* Keith *)
CONST
  BLOCKS = 62;
VAR
  LGTH: 0..BLOCKS;
  ITITLE,OTITLE: STRING[30];
  BUF: PACKED ARRAY[0..32000] OF CHAR;
  IFILE,OFILE: FILE;

PROCEDURE INDISK;
BEGIN
  WRITE('Please insert disk containing source file and type <return>');
  READLN;
END;

PROCEDURE OUTDISK;
BEGIN
  WRITE('Please insert disk onto which file is to be copied and type <return>');
  READLN;
END;

BEGIN
  IF EOLN THEN READLN;
  INDISK;
  REPEAT
    WRITE('Please type full input filename: ');
    READLN(ITITLE);
    IF LENGTH(ITITLE) = 0 THEN EXIT(PROGRAM);
    OPENOLD(IFILE,ITITLE);
  UNTIL IORESULT = 0;
  OUTDISK;
  REPEAT
    WRITE('Please type full output filename: ');
    READLN(OTITLE);
    IF LENGTH(OTITLE) = 0 THEN EXIT(PROGRAM);
    OPENNEW(OFILE,OTITLE);
  UNTIL IORESULT = 0;
  REPEAT
    INDISK;
    LGTH := BLOCKREAD(IFILE,BUF,BLOCKS);
    IF (IORESULT <> 0) THEN
      BEGIN
	WRITELN('Error encountered in reading');
	EXIT(PROGRAM)
      END;
    OUTDISK;
    IF (BLOCKWRITE(OFILE,BUF,LGTH) <> LGTH) THEN
      BEGIN
	WRITELN('Error encountered in output');
	EXIT(PROGRAM)
      END;
  UNTIL LGTH < BLOCKS;
  CLOSE(OFILE,LOCK);
  CLOSE(IFILE,NORMAL);
  WRITELN('Copy completed successfully');
END.

========================================================================================
DOCUMENT :usus Folder:VOL17:yaloe.text
========================================================================================


SEGMENT PROCEDURE USERPROGRAM(VAR I,O: TEXT);
  BEGIN
  END;

SEGMENT PROCEDURE COMPILER;
  SEGMENT PROCEDURE COMPINIT;
  BEGIN END;
BEGIN END;


SEGMENT PROCEDURE EDITOR
(* ADD THIS LINE FOR
  (VAR INN,OWWT: TEXT);
                    DEBUGGING AND WORKING ON THIS SEGMENT *);

(* YALOE * YALOE * YALOE * YALOE * YALOE * YALOE * YALOE * YALOE *
 * This text editor is based on the command structure
 * of the RT-11 system text editor.  Initially structured
 * and writted by Richard Kaufmann and Greg Davidson.
 * Later modified, enhanced, and quickened by Keith Shillington.
 * Released continuously from early June 1977.
 * Latest fixes by Roger Sumner for I.3  8-AUG-77
 * 11-AUG-77 Keith Shillington  backspacing changes
 * YALOE * YALOE * YALOE * YALOE * YALOE * YALOE * YALOE * YALOE *)

 CONST
  RET = 13;  TAB = 9;
  CTRLX = (*030o*) 24;
  DC1 =   (*021o*) 17;
  EXECSIZE = 1000;
  MAXMAC = 9; (* CHANGING THIS HAS IMPACT ON THE CODE... *)
  SHIFT = 15;
TYPE
  FILEBUF = PACKED ARRAY[0..1023] OF CHAR;
  COMARRAY = PACKED ARRAY[0..99] OF CHAR;
  BUFCHUNK = PACKED ARRAY[0..999] OF CHAR;
VAR
  I,J,ENDPOS,CURSOR: INTEGER;
  BUFSIZE,BUFEND: INTEGER;
  EQUALLENGTH: INTEGER;
  ESC: CHAR;
  CTRLU: INTEGER;
  BACK,ACR: CHAR;
  EXEC: ^COMARRAY;
  BUF: ^BUFCHUNK;
  MACROS: ARRAY[0..MAXMAC] OF
	      RECORD
		LGTH: INTEGER;
		EXEC: ^COMARRAY
	      END;
  OPTION: PACKED RECORD
	LISTSIZE: 0..100;
	ONOFF: BOOLEAN
  END;
  IOFILE: FILE;

FUNCTION COMMAND: BOOLEAN; FORWARD;

FUNCTION MIN(A,B:INTEGER): INTEGER;
BEGIN
  IF A>B THEN MIN := B ELSE MIN := A
END;

FUNCTION NEWFIN: BOOLEAN; (* TRUE IF ERROR OCCURS *)
LABEL 1;
VAR
  NBLOCKS,STASHSIZE,STASHEDAT: INTEGER;
    STASHCURSOR,NPAGES,I,NEXT: INTEGER;
    DIDDLED: BOOLEAN;
BEGIN
  NEWFIN := FALSE;
  IF BLOCKREAD(IOFILE,I,0,2) = 0 THEN BEGIN (* OK *)
    STASHCURSOR := CURSOR;
    STASHSIZE := ENDPOS - CURSOR;  STASHEDAT := BUFEND-STASHSIZE;
    IF (STASHEDAT > CURSOR) THEN (* THERE IS ROOM *)
      MOVERIGHT(BUF^[CURSOR],BUF^[STASHEDAT],STASHSIZE)
    ELSE
      BEGIN
        WRITELN(OUTPUT,'not enough space');
	NEWFIN := TRUE;
	GOTO 1;
      END;
    DIDDLED := FALSE;
    IF ODD(CURSOR) THEN BEGIN
      DIDDLED := TRUE;
      CURSOR := CURSOR +1;
    END;
    NBLOCKS := (STASHEDAT - CURSOR) DIV 512;
    NBLOCKS := BLOCKREAD(IOFILE,BUF^[CURSOR],NBLOCKS);
    IF (NOT EOF(IOFILE)) OR (IORESULT <> 0) OR (ODD(NBLOCKS)) THEN BEGIN
      CLOSE(IOFILE);
      WRITELN(OUTPUT,'not enough space');
      CURSOR := STASHCURSOR;
      NEWFIN := TRUE;
      GOTO 1;
    END;
    NPAGES := NBLOCKS DIV 2;
    IF DIDDLED THEN (* UGH *) BEGIN
      CURSOR := CURSOR -1;
      MOVELEFT(BUF^[CURSOR+1],BUF^[CURSOR],NPAGES*1024);
    END;
    NEXT := CURSOR;
    WHILE NPAGES > 0 DO BEGIN
      NPAGES := NPAGES -1;
      CURSOR := CURSOR +1023;
      NEXT := NEXT +1024;
      I := SCAN(-1024,<>CHR(0),BUF^[CURSOR]);
      CURSOR := CURSOR +I +1; (* POINT AT FIRST NUL *)
      IF NPAGES > 0 THEN  MOVELEFT(BUF^[NEXT],BUF^[CURSOR],1024);
    END;
1:	(* THIS IS WHERE THE WOUND IS CLOSED AND HEALED *)
    CLOSE(IOFILE);
    MOVELEFT(BUF^[STASHEDAT],BUF^[CURSOR],STASHSIZE);
    ENDPOS := STASHSIZE +CURSOR;
    BUF^[ENDPOS] := CHR(0);
    CURSOR := STASHCURSOR;
  END;
END;

PROCEDURE INITIALIZE;
VAR
  BUFMAKER: ^BUFCHUNK;
  SPACEMAKER: ^COMARRAY;
  HERE: ^INTEGER;
  LIMIT: INTEGER;
  TEST: BOOLEAN;
BEGIN
  WRITE(OUTPUT,'YALOE:');
  IF NOT SYSCOM^.MISCINFO.SLOWTERM THEN
    WRITE(OUTPUT,
	' - ? <esc><esc> for details');
  WRITELN(OUTPUT);
  NEW(BUF); (* BASE OF THE BUFFER *)
  BUFSIZE := SIZEOF(BUFCHUNK);
  LIMIT := ORD(SYSCOM^.LASTMP);
  REPEAT
    MARK(HERE);
    TEST := ((LIMIT - ORD(HERE))<5000) AND ((LIMIT - ORD(HERE))>0);
    IF NOT TEST THEN
      BEGIN
	NEW(BUFMAKER);
	BUFSIZE := BUFSIZE +SIZEOF(BUFCHUNK)
      END;
  UNTIL TEST;
  NEW(EXEC);
  FOR I := 1 TO 9 DO NEW(SPACEMAKER); (* CREATE SPACE FOR BASIC COMMAND *)
  FOR I := 0 TO MAXMAC DO
    MACROS[I].EXEC := NIL;
  CURSOR := 0;  ENDPOS := 0;  
  OPTION.ONOFF := FALSE;
  BUFEND := BUFSIZE;
  I := 0;  
  ACR := CHR(RET);
  BACK := SYSCOM^.CRTCTRL.BACKSPACE;
  ESC := SYSCOM^.CRTINFO.ALTMODE;
  CTRLU := ORD(SYSCOM^.CRTINFO.LINEDEL);
  WITH USERINFO DO
   IF GOTSYM THEN BEGIN
    OPENOLD(IOFILE,CONCAT(SYMVID,':',SYMTID));
    IF NEWFIN THEN
    BEGIN WRITELN(OUTPUT,'Lost workfile source');
      GOTSYM := FALSE
    END
    ELSE BEGIN
      WRITE(OUTPUT,'Workfile ');
      IF LENGTH(WORKTID) > 0 THEN
	WRITE(OUTPUT,WORKTID,' ');
      WRITELN(OUTPUT,'read in');
     END
   END ELSE BEGIN
    ENDPOS := 0; BUF^[0] := CHR(0);
    WRITELN(OUTPUT,'No workfile to read');
  END;
  CURSOR := 0;
  EQUALLENGTH := 0;
END;


  PROCEDURE NEWOUTLOOK;
  VAR  I:INTEGER;
    STASHCURSOR: INTEGER;
    P: ^INTEGER;
    COM: ^FILEBUF;
  BEGIN
    STASHCURSOR := CURSOR;
    MARK(P);
    NEW(COM);
    FILLCHAR(COM^[0],1024,CHR(0));
    CURSOR := 0;
    IF BLOCKWRITE(IOFILE,COM^,2) = 2 THEN
    WHILE (CURSOR + 1023) < ENDPOS DO BEGIN
      I := SCAN(-1022, = CHR(RET), BUF^[CURSOR +1022]);
      MOVELEFT(BUF^[CURSOR],COM^,1023+I);
      FILLCHAR(COM^[1023+I],ABS(I)+1,CHR(0));
      IF BLOCKWRITE(IOFILE,COM^,2) <>2 THEN BEGIN
	RELEASE(P);
	WRITELN(OUTPUT, 'Output file error: Help');
	CLOSE(IOFILE);
	EXIT(COMMAND);
      END;
      CURSOR := CURSOR+1023+I;
    END;
    IF (CURSOR < ENDPOS) THEN BEGIN
      FILLCHAR(BUF^[ENDPOS],1024-(ENDPOS-CURSOR),CHR(0));
      MOVELEFT(BUF^[CURSOR],COM^,1024);
      IF BLOCKWRITE(IOFILE,COM^,2) <>2 THEN BEGIN
	RELEASE(P);
	WRITELN(OUTPUT,'Output file error.  HELP!');
	CLOSE(IOFILE);
	EXIT(COMMAND);
      END;
    END;
    RELEASE(P);
    CLOSE(IOFILE,LOCK);
    CURSOR := STASHCURSOR;
  END;

PROCEDURE CLOSETHEWORLD(VAR CH: CHAR);
VAR
  LTITLE : STRING[29];
  EXITSET: SET OF 'A'..'z';
BEGIN
  EXITSET := ['E','e','U','u','R','r'];
  REPEAT
    IF NOT (CH IN EXITSET) THEN BEGIN
      CLEARSCREEN;
      WRITELN(OUTPUT,'Output options are:');
      WRITELN(OUTPUT,'    (U) - output to workfile');
      WRITELN(OUTPUT,'    (E) - exit with no output');
      WRITELN(OUTPUT,'    (R) - return to the editor');
      READ(INPUT,CH);
    END;
    IF (CH='U') OR (CH='u') THEN 
      WITH USERINFO DO BEGIN
	LTITLE := '*SYSTEM.WRK.TEXT';
	OPENNEW(IOFILE,LTITLE); NEWOUTLOOK;
	(*IF WE GET HERE THEN FILE IS LOCKED ON DISK OK*)
	SYMVID := SYVID; SYMTID := 'SYSTEM.WRK.TEXT'; GOTSYM := TRUE;
	LTITLE := '*SYSTEM.WRK.CODE';
	OPENOLD(IOFILE,LTITLE); CLOSE(IOFILE,PURGE);
	GOTCODE := FALSE; CODETID := ''
    END
  UNTIL CH IN EXITSET;
END;


PROCEDURE PROMPTS;
VAR
  HERE: ^INTEGER;
BEGIN
  MARK(HERE);
  CLEARSCREEN;
  WRITELN(OUTPUT,'Yet Another Line Oriented Editor.');
  WRITELN(OUTPUT);
  WRITELN(OUTPUT,
	'Advance  Beginning  Change  Delete  Get  Insert  Jump');
  WRITELN(OUTPUT,'Kill  List  Macro <definition>  Now <macro execution>');
  WRITELN(OUTPUT,'Quit <Esc Update>  Read <filename>  Save  Unsave  Verify');
  WRITELN(OUTPUT,'Write <filename>  eXchange  ?elp');
  WRITELN(OUTPUT,'Ctrl-X (can) to cancel command input.');
  WRITELN(OUTPUT);
  WRITELN(OUTPUT,'The macros you have defined are:');
  WRITE(OUTPUT,' - ');
  FOR I := 0 TO MAXMAC DO
    IF MACROS[I].EXEC <> NIL THEN
      WRITE(OUTPUT,I,' - ');
  WRITELN(OUTPUT);
  WRITE(OUTPUT,'Your text buffer is ',BUFSIZE,' bytes, ',ENDPOS);
  WRITELN(OUTPUT,' of which are filled, leaving ',BUFSIZE-ENDPOS);
  WRITE(OUTPUT,'Your ''save'' text is ',BUFSIZE-BUFEND,' bytes');
END;

PROCEDURE INCOMMAND;
LABEL 1,2;
VAR ONEESC,WARNED: BOOLEAN;
  CH: CHAR;
  FACTOR,T: INTEGER;
  CHDEL: CHAR;
  CRTESC,UP,EEOL,BELL: CHAR;
  SLOW,WASBS: BOOLEAN;
BEGIN
  FILLCHAR(EXEC^,EXECSIZE,ESC);
  FACTOR := 0;
  WITH SYSCOM^,CRTCTRL,MISCINFO DO
    BEGIN
      BELL := CRTINFO.BADCH;
      SLOW := (BACKSPACE = CHR(0)); (* NO CONTROL *)
      CHDEL := CRTINFO.CHARDEL;
      CRTESC := ESCAPE;
      UP := RLF;
      EEOL := ERASEEOL
    END;
  WASBS := FALSE;
  CH := ' ';
  I := 0;
  WARNED := FALSE;
  ONEESC := FALSE;
  READ(KEYBOARD,CH);
  IF EOLN(KEYBOARD) THEN CH := ACR;
  WHILE (CH <> ESC) OR NOT ONEESC DO
    BEGIN
      IF CH = CHR(SHIFT) THEN
	IF SYSCOM^.MISCINFO.HAS8510A THEN		(*KAS 8/15*)
	  IF FACTOR = 128 THEN FACTOR := 0 ELSE FACTOR := 128;
      ONEESC := (CH = ESC);
      IF ONEESC THEN GOTO 1;
      IF CH = CHDEL THEN
	    IF (I > 0) THEN
	      BEGIN
		I := PRED(I);
		IF SLOW THEN
		  IF WASBS THEN WRITE(OUTPUT,EXEC^[I])
		  ELSE WRITE(OUTPUT,'%',EXEC^[I])
		ELSE
		  IF EXEC^[I] = CHR(TAB) THEN
		    FOR T := 1 TO 8 DO WRITE(OUTPUT,BACK)
		  ELSE WRITE(OUTPUT,BACK,' ',BACK);
	      END;
      IF (CH = CHR(CTRLU)) THEN
	BEGIN
	  IF SLOW THEN
	    WRITELN(OUTPUT,'<ZAP')
	  ELSE
	    BEGIN
	      WRITELN(OUTPUT,CRTESC,UP);
	      WRITE(OUTPUT,CRTESC,EEOL);
	    END;
	  WHILE (I > 0) AND (EXEC^[I] <> ACR) DO I := PRED(I);
	  IF I <> 0 THEN I := SUCC(I) ELSE WRITE(OUTPUT,'*')
        END
      ELSE
      IF (CH < ' ') THEN
	BEGIN
	  IF ORD(CH) IN [RET,TAB,DC1] THEN
		BEGIN
	1:		EXEC^[I] := CH;
			I := SUCC(I);
			IF ONEESC THEN WRITE(OUTPUT,'$')
			ELSE IF ORD(CH) = DC1 THEN WRITE(OUTPUT,BELL)
			     ELSE WRITE(OUTPUT,CH)
		END;
	  IF CH = CHR(CTRLX) THEN BEGIN
			 I := 0;
			 WRITELN(OUTPUT);
			 EXIT(INCOMMAND)
		       END
	END
      ELSE
	BEGIN
	  IF WASBS AND SLOW THEN
	    WRITE(OUTPUT,'%',CH)
	  ELSE
	    WRITE(OUTPUT,CH);
	  EXEC^[I] := CH;
	  I := SUCC(I)
	END;
    WASBS := (CH = CHDEL);
    IF I >= (EXECSIZE - 80 (*WARNING*)) THEN
      IF I > (EXECSIZE - 2) THEN REPEAT
	WRITELN(OUTPUT,'Command buffer full.  Type <esc> <esc> or (^X).');
	READ(KEYBOARD,CH);
	IF CH=CHR(CTRLX) THEN BEGIN
	  I := 0;  EXIT(INCOMMAND)
	END ELSE
	IF CH = ESC THEN BEGIN
	  READ(KEYBOARD,CH);
	  IF CH = ESC THEN
	    EXIT(INCOMMAND);
	END;
      UNTIL FALSE
      ELSE IF NOT WARNED AND (CH = ACR) THEN
	BEGIN
	  WRITELN(OUTPUT,'please finish',CHR(7)(* BELL *));
	  WARNED:=TRUE;
	END;
    READ(KEYBOARD,CH);
    IF EOLN(KEYBOARD) THEN CH := ACR;
    IF CH >= ' ' THEN
      CH := CHR(ORD(CH)+FACTOR)
    END;
  WRITELN(OUTPUT,'$');
  I:=I-1;
END;


FUNCTION COMMAND(*: BOOLEAN *);
  VAR RCOUNT:INTEGER;
    THISCH: CHAR;
    NEG:BOOLEAN;
    NUMBER: SET OF '0'..'9';


PROCEDURE SYNTAX(ERRCH: CHAR);
BEGIN
  WRITELN(OUTPUT,ERRCH,' : IS IN ERROR, COMMAND STOPPED.');
  EXIT(COMMAND);
END;

PROCEDURE LINEPLACE(VAR PTR: INTEGER; N: INTEGER);
  VAR I: INTEGER;
BEGIN
  PTR := CURSOR; (* A NICE PLACE TO START *)
  IF (N <= 0) THEN (* LOOK BACK *) BEGIN 
    REPEAT
      PTR := PTR -1;
      I := SCAN(-(PTR+1),=ACR,BUF^[PTR]);
      PTR := PTR +I;
      N := SUCC(N);
    UNTIL (N > 0) OR (PTR < 0);
  PTR := SUCC(PTR);
  END ELSE REPEAT
    I := SCAN(ENDPOS-PTR-1,=ACR,BUF^[PTR]);
    PTR := PTR+I+1;
    N := N -1;
  UNTIL (N=0) OR (PTR = ENDPOS);
END;

PROCEDURE DELETESTUFF;
VAR
  COUNT: INTEGER;
BEGIN
  IF (RCOUNT = 0) THEN
    BEGIN
      LINEPLACE(COUNT,0);
      RCOUNT := COUNT - CURSOR;
    END;
  COUNT:=CURSOR+RCOUNT;
  IF RCOUNT<0 THEN
    BEGIN
    IF COUNT<0 THEN COUNT := 0;
    MOVELEFT(BUF^[CURSOR],BUF^[COUNT],ENDPOS-CURSOR+1);
    ENDPOS:=ENDPOS-(CURSOR-COUNT);
    CURSOR:=COUNT;
  END
  ELSE
    IF (COUNT >= ENDPOS) OR (COUNT < 0) THEN
      BEGIN
	ENDPOS := CURSOR;  BUF^[CURSOR] := CHR(0);
      END
    ELSE
      BEGIN
	MOVELEFT(BUF^[COUNT],BUF^[CURSOR],ENDPOS-COUNT+1);
	ENDPOS:=ENDPOS-(COUNT-CURSOR);
      END;
END;


PROCEDURE GETTER;
VAR
  DIR,SIZE: INTEGER;
  FOUND,HARDEND: BOOLEAN;
  FIRST: CHAR;
  PATTERN,QUESTION: STRING[100];

  PROCEDURE FINDIT;
  BEGIN
    REPEAT
      IF DIR < 0 THEN
	BEGIN
	  CURSOR := CURSOR + SCAN(-CURSOR,=FIRST,BUF^[CURSOR]);
	  IF CURSOR <= 0 THEN
	    BEGIN
	      HARDEND := TRUE;
	      CURSOR := 0;
	      EXIT(FINDIT)
	    END
	END
      ELSE
	BEGIN
	  CURSOR := CURSOR + SCAN(ENDPOS-CURSOR+1,=FIRST,BUF^[CURSOR]);
	  IF CURSOR >= ENDPOS THEN
	    BEGIN
	      HARDEND := TRUE;
	      CURSOR := ENDPOS;
	      EXIT(FINDIT)
	    END
	END;
      MOVELEFT(BUF^[CURSOR],QUESTION[1],SIZE);
      FOUND := (QUESTION = PATTERN);
      CURSOR := CURSOR + DIR
    UNTIL FOUND
  END (* FINDIT *);

BEGIN
  IF RCOUNT < 0 THEN
    BEGIN
      RCOUNT := -RCOUNT;
      DIR := -1
    END
  ELSE DIR := 1;
  J := J+1;
  SIZE := 0;
  FIRST := EXEC^[J];
  WHILE EXEC^[J +SIZE] <> ESC DO SIZE := SIZE +1;
  MOVELEFT(EXEC^[J],PATTERN[1],SIZE);
  PATTERN[0] := CHR(SIZE);
  QUESTION[0] := CHR(SIZE);
  HARDEND := FALSE;
  FOUND := FALSE;
  REPEAT
    FINDIT;
    RCOUNT := RCOUNT -1
  UNTIL (RCOUNT <= 0) OR HARDEND;
  IF HARDEND THEN
    BEGIN
      WRITELN(OUTPUT,PATTERN,' not found');
      EXIT(COMMAND)
    END;
  IF DIR < 0 THEN CURSOR := CURSOR +1
  ELSE CURSOR := CURSOR +SIZE -1;
  J := J +SIZE;
  EQUALLENGTH := SIZE
END (* GETTER *);

PROCEDURE INSERTTEXT;
VAR
  SIZEOVER: BOOLEAN;  LENGTH,TEMP: INTEGER;
BEGIN
  SIZEOVER := FALSE;  J := J+1;
  LENGTH := SCAN(I-J,=(ESC),EXEC^[J]);
  TEMP := ENDPOS+LENGTH;
  IF (TEMP > BUFSIZE) THEN
    BEGIN
      WRITELN(OUTPUT,'insertion truncated, not enough space');
      SIZEOVER := TRUE;
      LENGTH := BUFSIZE-ENDPOS;
      TEMP := BUFSIZE;
    END;
  IF (TEMP > BUFEND) THEN
    BEGIN
      WRITELN(OUTPUT,'''save'' area deleted.');
      BUFEND := BUFSIZE;
    END;
  MOVERIGHT(BUF^[CURSOR],BUF^[CURSOR+LENGTH],BUFEND-(CURSOR+LENGTH));
  MOVELEFT(EXEC^[J],BUF^[CURSOR],LENGTH);
  ENDPOS := ENDPOS +LENGTH;
  CURSOR := CURSOR +LENGTH;
  EQUALLENGTH := LENGTH;
  IF SIZEOVER THEN EXIT(COMMAND);
  J := J +LENGTH;
END (* INSERT NEW TEXT *);

PROCEDURE JUMP;
BEGIN
  IF RCOUNT = 0 THEN LINEPLACE(CURSOR,0)
  ELSE CURSOR := CURSOR + RCOUNT;
  IF (CURSOR<0) AND (RCOUNT<0) THEN CURSOR := 0
  ELSE
   IF (CURSOR<0) OR (CURSOR>ENDPOS) THEN CURSOR := ENDPOS;
END;


PROCEDURE KILL;
  VAR POSITION:INTEGER;
BEGIN
  LINEPLACE(POSITION,RCOUNT);
  IF RCOUNT<=0 THEN
    BEGIN
      MOVELEFT(BUF^[CURSOR],BUF^[POSITION],(ENDPOS-CURSOR+1));
      ENDPOS := ENDPOS - (CURSOR - POSITION);
      CURSOR := CURSOR - (CURSOR - POSITION);
    END
  ELSE
    BEGIN
      MOVELEFT(BUF^[POSITION],BUF^[CURSOR],(ENDPOS-POSITION+1));
      ENDPOS := ENDPOS - (POSITION - CURSOR);
    END;
END;


PROCEDURE LIST;
  VAR POSITION: INTEGER;
BEGIN
  LINEPLACE(POSITION,RCOUNT);
  IF RCOUNT<=0 THEN
    UNITWRITE(1(* CONSOLE: *),BUF^[POSITION],CURSOR-POSITION)
  ELSE
    UNITWRITE(1(* CONSOLE: *),BUF^[CURSOR],POSITION-CURSOR)
END;


PROCEDURE MACRODEFINITION;
VAR
  STOPCH: CHAR;
  LGTH: INTEGER;
BEGIN
  IF (RCOUNT<0) OR (RCOUNT>MAXMAC) THEN SYNTAX('#');
  IF MACROS[RCOUNT].EXEC = NIL THEN NEW(MACROS[RCOUNT].EXEC);
  STOPCH := EXEC^[J+1];
  LGTH := SCAN(I-J,=STOPCH,EXEC^[J+2]);
  IF (LGTH = (I-J)) OR (LGTH > SIZEOF(COMARRAY)) OR (LGTH = 0) THEN
    BEGIN
      WRITELN(OUTPUT,'Error in macro definition');
      EXIT(COMMAND);
    END;
  MOVELEFT(EXEC^[J+2],MACROS[RCOUNT].EXEC^[0],LGTH);
  FILLCHAR(MACROS[RCOUNT].EXEC^[LGTH+1],SIZEOF(COMARRAY)-LGTH,ESC);
  MACROS[RCOUNT].LGTH := LGTH;
  J := J+LGTH+2;
END (* DEFINE MACRO *);

PROCEDURE NOWEXECUTEMACRO;
VAR
  SAVE: RECORD
	  EXEC: ^COMARRAY;
	  I,J: INTEGER
	END;
  MACNUM: INTEGER;
  ERROR: BOOLEAN;
BEGIN
  J := J +1;
  SAVE.EXEC := EXEC;
  SAVE.I := I;
  SAVE.J := J;
  IF EXEC^[J] = ESC THEN MACNUM := 1
  ELSE MACNUM := ORD(EXEC^[J])-ORD('0');
  IF (MACROS[MACNUM].EXEC = NIL) THEN
    BEGIN
      WRITELN(OUTPUT,'ILLEGAL MACRO...Try again');
      EXIT(COMMAND)
    END;
  IF (MACNUM<0) OR (MACNUM > MAXMAC) THEN SYNTAX('#');
  EXEC := MACROS[MACNUM].EXEC;
  I := MACROS[MACNUM].LGTH;
  WHILE RCOUNT > 0 DO
    BEGIN
      RCOUNT := RCOUNT -1;
      IF COMMAND THEN
	BEGIN
	  COMMAND := TRUE;
	  EXIT(COMMAND)
	END;
      ERROR := (J<I);
      IF ERROR THEN
	BEGIN
	  RCOUNT := 0;
	  WRITELN(OUTPUT,'macro halted');
	END;
    END;
  EXEC := SAVE.EXEC;
  I := SAVE.I;
  J := SAVE.J;
  IF ERROR THEN EXIT(COMMAND);
END (* NOW EXECUTE MACRO *);

PROCEDURE OPTIONMOD;
BEGIN
  WITH OPTION DO
    BEGIN
      ONOFF := NOT ONOFF;
      IF ONOFF THEN
	WITH SYSCOM^.CRTINFO DO
	  IF RCOUNT > 1 THEN
	    LISTSIZE := RCOUNT
	  ELSE
	    LISTSIZE := HEIGHT DIV 2 -1
    END
END;

PROCEDURE READFILE;
VAR
  LGTH: INTEGER;
  TITLE: STRING[40];
BEGIN
  J := J +1;
  LGTH := SCAN(30,=ESC,EXEC^[J]);
  IF (LGTH <= 30) AND (LGTH > 0) THEN
    BEGIN
      TITLE[0] := CHR(LGTH);
      MOVELEFT(EXEC^[J],TITLE[1],LGTH);
      OPENOLD(IOFILE,TITLE);
      IF IORESULT = 0 THEN
	BEGIN IF NEWFIN THEN EXIT(COMMAND) END
      ELSE
        BEGIN
	  OPENOLD(IOFILE,CONCAT(TITLE,'.TEXT'));
	  IF IORESULT = 0 THEN
	    BEGIN IF NEWFIN THEN EXIT(COMMAND) END
	  ELSE
	    BEGIN
	      WRITELN(OUTPUT,'File: ',TITLE,' is in error.  Not read');
	      EXIT(COMMAND);
	    END;
        END
    END
  ELSE
    BEGIN
      WRITELN(OUTPUT,'File name error.');
      EXIT(COMMAND);
    END;
  J := J +LGTH;
END;

PROCEDURE SAVE;
VAR
  POS,DELTA: INTEGER;
BEGIN
  LINEPLACE(POS,RCOUNT);
  IF RCOUNT <= 0 THEN
    DELTA := CURSOR -POS
  ELSE
    DELTA := POS -CURSOR;
  BUFEND := BUFSIZE -DELTA;
  IF BUFEND <= ENDPOS THEN
    BEGIN
      BUFEND := BUFSIZE;
      WRITELN(OUTPUT,'Not enough room to save in');
      EXIT(COMMAND);
    END;
  IF RCOUNT <= 0 THEN
    MOVELEFT(BUF^[POS],BUF^[BUFEND],DELTA)
  ELSE
    MOVELEFT(BUF^[CURSOR],BUF^[BUFEND],DELTA)
END (* SAVE *);

PROCEDURE UNSAVE;
VAR
  STASHSIZE,STASHEDAT,DELTA: INTEGER;
BEGIN
  IF RCOUNT = 0 THEN
    BUFEND := BUFSIZE
  ELSE
    BEGIN
      STASHSIZE := ENDPOS -CURSOR;
      DELTA := BUFSIZE -BUFEND;
      STASHEDAT := CURSOR +DELTA;
      IF ((STASHEDAT +STASHSIZE) < BUFEND) THEN
	BEGIN
	  MOVERIGHT(BUF^[CURSOR],BUF^[STASHEDAT],STASHSIZE);
	  MOVELEFT(BUF^[BUFEND],BUF^[CURSOR],DELTA);
	  ENDPOS := ENDPOS +DELTA;
	  BUF^[ENDPOS] := CHR(0)
	END
      ELSE
	BEGIN WRITELN(OUTPUT,'not enough space'); EXIT(COMMAND) END
    END (* ~=0 *)
END (* UNSAVE *);

PROCEDURE VIEW;
BEGIN
  RCOUNT := 0;  LIST;
  RCOUNT := 1;  LIST
END;

PROCEDURE WRITEFILE;
VAR
  LGTH: INTEGER;
  TITLE: STRING[40];
BEGIN
  J := J +1;
  LGTH := SCAN(30,=ESC,EXEC^[J]);
  IF (LGTH > 0) AND (LGTH <= 30) THEN BEGIN
    TITLE[0] := CHR(LGTH);
    MOVELEFT(EXEC^[J],TITLE[1],LGTH);
    IF (TITLE[LGTH] <> '.') AND (TITLE[LGTH] <> ']') AND
	(POS('.TEXT',TITLE) = 0) THEN
      TITLE := CONCAT(TITLE,'.TEXT');
    IF (TITLE[LGTH] = '.') THEN DELETE(TITLE,LGTH,1);
    OPENNEW(IOFILE,TITLE);
    IF IORESULT = 0 THEN
      NEWOUTLOOK
    ELSE BEGIN
      WRITELN(OUTPUT,CONCAT('File: ',TITLE,' is in error. Write not done.'));
      EXIT(COMMAND);
    END;
  END ELSE BEGIN
    WRITELN(OUTPUT,'Illegal title');
    EXIT(COMMAND);
  END;
  J := J +LGTH;
END;

BEGIN (*COMMAND*)
  COMMAND := FALSE;
  NUMBER := ['0'..'9'];
  J := 0;
  WHILE (J<I) DO
    BEGIN
      WHILE (EXEC^[J] IN [' ',ACR,CHR(TAB),ESC]) AND (J<I) DO
	J := SUCC(J);
      THISCH := EXEC^[J];
      NEG := (THISCH = '-');
      IF THISCH IN ['+','-'] THEN
	BEGIN
	  J := J +1;
	  THISCH := EXEC^[J]
	END;
      IF (THISCH IN NUMBER) THEN
	BEGIN
	  RCOUNT := 0;
	  REPEAT
	    RCOUNT := (RCOUNT*10) + ORD(EXEC^[J])-ORD('0');
	    J := SUCC(J)
	  UNTIL ((NOT (EXEC^[J] IN NUMBER)) OR (RCOUNT > 3200));
	  THISCH := EXEC^[J];
	END(* IN NUMBER *)
      ELSE RCOUNT := 1;
      IF (THISCH IN ['=','/']) THEN
	IF (RCOUNT <> 1) THEN SYNTAX(THISCH)
	ELSE
	  BEGIN
	    IF (THISCH = '=') THEN RCOUNT := -EQUALLENGTH
	    ELSE (* = '/' *) RCOUNT := 32700;
	    J := J +1;
	    THISCH := EXEC^[J]
	  END;
      IF NEG THEN RCOUNT := -RCOUNT;
      IF (J >= I) THEN EXIT(COMMAND);
      IF (THISCH IN ['?','A'..'Z','a'..'z']) THEN
	CASE THISCH OF
	  '?'    : PROMPTS;
	  'a','A':LINEPLACE(CURSOR,RCOUNT);
	  'b','B':CURSOR:=0; (*DA END*)
	  'c','C':BEGIN DELETESTUFF; INSERTTEXT END;
	  'd','D':DELETESTUFF;
	  'e','E':CLEARSCREEN;
	  'G','F','f','g':GETTER;
	  'H','h':WRITELN(OUTPUT,'Unimplemented');
	  'I','i': INSERTTEXT;
	  'J','j':JUMP;
	  'K','k':KILL;
	  'L','l':LIST;
	  'M','m': MACRODEFINITION;
	  'N','n': NOWEXECUTEMACRO;
	  'O','o': OPTIONMOD;
	  'p','t','y','z',
	  'P','T','Y','Z': SYNTAX(THISCH);
	  'Q','q': BEGIN
		  THISCH := EXEC^[J+1];
		  CLOSETHEWORLD(THISCH);
		  COMMAND := (THISCH IN ['E','e','U','u']);
		  EXIT(COMMAND)
		END;
	  'R','r':READFILE;
	  'S','s':SAVE;
	  'U','u':UNSAVE;
	  'V','v':VIEW;
	  'W','w':WRITEFILE;
	  'X','x':BEGIN KILL; INSERTTEXT END
	END
      ELSE SYNTAX(THISCH);
      J:=J+1;
    END (* WHILE J <= I *);
  IF OPTION.ONOFF THEN
    BEGIN
      CLEARSCREEN;
      RCOUNT := -OPTION.LISTSIZE;
      LIST;
      WRITE(OUTPUT,CHR(10 (* LF *)));
      RCOUNT := OPTION.LISTSIZE;
      LIST
    END;
END (* COMMAND *);

BEGIN (*EDITOR*)
  INITIALIZE;
  REPEAT
    WRITE(KEYBOARD,'*'); (*CLEARS ^F AND ^S FLAGS!*)
(*    this line is for the havaheart command
 *  MOVELEFT(EXEC^,BUF^[ENDPOS+1],MIN(I,BUFEND-ENDPOS));
 *        which some day may be implemented *)
    INCOMMAND
  UNTIL COMMAND;
END;

BEGIN (* JUST A DUMMY *)
END.

========================================================================================
DOCUMENT :usus Folder:VOL18:8queens.text
========================================================================================

{$R-,F-}(* This program finds all 92 positions of 8 queens on a cherssboard *)
(* such that no queen checks another queen.  The backtracking       *)
(* algorithmn is recursive.                                         *)

(* Run-time on the CDC 6400: 1017 msec. (679 msec without range checking)*)

PROGRAM EIGHTQUEENS(OUTPUT);
VAR I, q, iterations : INTEGER;
    SAFE: BOOLEAN;
    A : ARRAY[1..8] OF BOOLEAN;
    B : ARRAY[2..16] OF BOOLEAN;
    C : ARRAY[-7..7] OF BOOLEAN;
    X : ARRAY[1..8] OF INTEGER;
    
    SHITIME ,SLOWTIME, EHITIME, ELOWTIME: INTEGER;
   
Procedure Print;
  Var k: integer;
Begin
for k := 1 to 8 do (*
Write (x[k]: 2);
Writeln; *)
End;


PROCEDURE TRYCOL(J : INTEGER);
   VAR I : INTEGER; 
   
   PROCEDURE SETQUEEN;
   BEGIN A[I] := FALSE;  B[I+J] := FALSE;  C[I-J] := FALSE;
   END;
   
   PROCEDURE REMOVEQUEEN;
   BEGIN  A[I] := TRUE;  B[I+J] := TRUE;  C[I-J] := TRUE
   END;
BEGIN
   I:=0;
   REPEAT I := I+1;  SAFE := A[I] AND B[I+J] AND C[I-J];
      IF SAFE THEN 
      BEGIN  SETQUEEN;  X[J] := I;
         IF J < 8 THEN TRYCOL(J+1) ELSE PRINT;
         REMOVEQUEEN
      END
   UNTIL I = 8
END;

BEGIN   FOR I := 1 TO 8 DO A[I] := TRUE;
        FOR I := 2 TO 16 DO B[I] := TRUE;
        FOR I := -7 TO 7 DO C[I] := TRUE;
        
   Writeln;
   Writeln ('8 queens  (R-)');
   WRITE('Iterations ?  (<cr> starts benchmark) ');
   READLN (iterations);
     for q := 1 to iterations do begin
     (*
     Page (output);
     *)
     TRYCOL(1);  
     end;
   WRITELN('DONE', CHR (7));
END.

========================================================================================
DOCUMENT :usus Folder:VOL18:ancest.s.text
========================================================================================

{$R-,F-} { Ancestor matrix.  Set version.  }
(* A SECOND VERSION OF THE ALGORITHM USES THE PASCAL SET STRUCTURE   *)  
(* INSTEAD OF A BOOLEAN MATRIX.  tHE RELATION R[I,J] IS EXPRESSED AS *)
(* "J IN R[I]".  SINCE THE PASCAL 6000-3.4 COMPILER RESTRICST SETS   *)
(* TO HAVE AT MOST 59 ELEMENTS, THE FOLLOWING PERFORMANCE COMPARISON *)
(* IS BASED ON THE CASE N = 50.                                      *)
(* ON THE CDC6400 THIS PROGRAM REQUIRES ON 50 MSEC TO COMPUTE THE ANCESTOR *)
(* MATRIX, COMPARED TO 341 MSEC FOR THE VERSION USING A PACKED ARRAY.      *)
(* tHIS IS A GAIN BY A FACTOR OF 5.9                                       *)

PROGRAM ANCESTOR(OUTPUT);
(*ANCESTOR ALGORITHM USING SETS INSTEAD OF BOOLEAN MATRIX*)
   CONST N = 50;
   VAR I,J,HI,LOW, q, iterations: INTEGER;
      R: ARRAY[1..N] OF SET OF 1..N;

BEGIN (* J IN R[I] = "I IS A PARENT OF J"*)
Writeln;
Writeln ('Ancestor matrix  (sets, R-)');
Writeln;
Write ('Iterations ?  (<cr> starts benchmark) ');
Readln (iterations);

for q := 1 to iterations do begin
   (* 
   Page (output);
   *)
   FOR I := 1 TO N DO
         IF I MOD 10 <> 0 THEN R[I] := [I+1] ELSE R[I] := [];
      
      FOR I := 1 TO N DO
         FOR J := 1 TO N DO
            IF I IN R[J] THEN R[J] := R[I]+R[J];
      
      (*
      FOR I := 1 TO N DO
      BEGIN WRITE(' ');
         FOR J := 1 TO N DO
            IF J IN R[I] THEN WRITE('1') ELSE WRITE('.');
         WRITELN
      END;
      *)
      
   end {for q};
WRITELN('DONE',CHR(7));

END.
   

========================================================================================
DOCUMENT :usus Folder:VOL18:bench.usus.text
========================================================================================

  program benchusus;
  (* Self timed version of Jon Bondy's benchmark
     See USUS News #4*)
  
  type
    rec2_type = record
      next : ^rec2_type;
      end;
  var
    num_loops : integer;
    i,j,k,l, test : integer;
    r,s,t : real;
    starth,startl,endh,endl : integer;
    a : array[1..100] of integer;
    b : array[1..100] of real;
    ch : char;
    rec1 : record
        firsti, secondi : integer;
        firstr, secondr : real;
      end;
    root, ptr : ^rec2_type;
    cset : set of char;
    overhead,xt,xs,xe : real;
    fudge_loop : boolean;
    (* printr : interactive; *)
    
    procedure prompt;
      procedure prompt1; { too big for 1200 bytes otherwise... }
        var line:integer;
        begin
        gotoxy(0,23);
        for line:=1 to 24 do writeln;
        gotoxy(0,0);
        writeln('Select a test or enter "0" for all tests.');
        writeln('Enter a negative number to quit.');
        writeln;
        end;
      begin
      prompt1;
      writeln(' 1. null for loops (to).           2. null for loops (downto).');
      writeln(' 3. integer increments (for loop). 4. null while loops.');
      writeln(' 5. null repeat loops.             6. integer adds.');
      writeln(' 7. integer multiplys.             8. integer divides.');
      writeln(' 9. real increments.              10. real adds.');
      writeln('11. real multiplies.              12. real divides.');
      writeln('13. integer transfers.            14. integer array transfers.');
      writeln('15. real transfers.               16. real array transfers.');
      writeln('17. integer record transfers.     18. real record transfers.');
      writeln('19. integer if comparisons.       20. real if comparisons.');
      writeln('21. case statements.              22. procedure calls.');
      writeln('23. proc calls with integer param.24. proc calls with real param.');
      writeln('25. proc calls with a local var.  26. set unions.');
      writeln('27. set differences.              28. set IN''s.');
      writeln('29. pointer transfers.            30. NOOP''s.');
      write('Test:');
      end; { prompt }
      
  procedure doneit;
  
  begin
    writeln( chr ( 7 ), 'Done.');
    xs:=ABS(startl);
    xe:=ABS(endl);
    xt:=ABS(xe-xs)/60;
    if xt <> 0.0 then 
      begin
         write('Time = ',xt:5:2,' seconds  ' );
         if fudge_loop then  
         writeln ((((xt/numloops ) * 1000 ) - ( overhead )):7:3,' ms per loop ')
         else writeln ((( xt/numloops ) * 1000 ):7:3, ' ms per loop' );
      end;
    (*writeln(printr,t);*)
  end;

  procedure dummy1;
    begin
    end;
    
  procedure dummy2(i : integer);
    begin
    end;
    
  procedure dummy3(r: real);
    begin
    end;
  
  procedure dummy4;
    var
      i : integer;
    begin
    end;
    
  procedure test1;
    begin
    fudge_loop := false;
    write('1 . ',numloops,' null for loops (to).');
    time(starth,startl);
    for i := 1 to num_loops do begin end;
    time(endh,endl);
    end;
   
  procedure test2;
    begin
    fudge_loop := false;
    write('2.  ',numloops,
      ' null for loops (downto).');
    time(starth,startl);
    for i := num_loops downto 1 do begin end;
    time(endh,endl);
    doneit;
    end;
   
  procedure test3;
    begin
    fudge_loop := false;
    write('3.  ',numloops,
      ' integer increments (for loop).');
    time(starth,startl);
    for i := 1 to num_loops do begin j := j + 1; end;
    time(endh,endl);
    doneit;
    end;
   
  procedure test4;
    begin
    fudge_loop := false;
    write('4.  ',numloops,' null while loops.');
    j := 0;
    time(starth,startl);
    while (j < num_loops) do begin j := j + 1; end;
    time(endh,endl);
    doneit;
    end;
   
  procedure test5;
    begin
    fudge_loop := false;
    write('5.  ',numloops,' null repeat loops.');
    j := 0;
    time(starth,startl);
    repeat j := j + 1 until (j = num_loops);
    time(endh,endl);
    doneit;
    end;
   
  procedure test6;
    begin
    fudge_loop := true;
    write('6.  ',numloops,' integer adds.');
    time(starth,startl);
    for i := 1 to num_loops do begin j := j + k; end;
    time(endh,endl);
    doneit;
    end;
   
  procedure test7;
    begin
    fudge_loop := true;
    write('7.  ',numloops,' integer multiplys.');
    time(starth,startl);
    for i := 1 to num_loops do begin j := k * l; end;
    time(endh,endl);
    doneit;
    end;
  
  procedure test8;
    begin
    fudge_loop := true;
    write('8.  ',numloops,' integer divides.');
    time(starth,startl);
    for i := 1 to num_loops do begin j := k div l; end;
    time(endh,endl);
    doneit;
    end;
   
  procedure test9;
    begin
    fudge_loop := true;
    write('9.  ',numloops,' real increments.');
    time(starth,startl);
    for i := 1 to num_loops do begin r := r + 1.0 end;
    time(endh,endl);
    doneit;
    end;
   
  procedure test10;
    begin
    fudge_loop := true;
    write('10.  ',numloops,' real adds.');
    time(starth,startl);
    for i := 1 to num_loops do begin r := r + s; end;
    time(endh,endl);
    doneit;
    end;
   
  procedure test11;
    begin
    fudge_loop := true;
    write('11.  ',numloops,' real multiplies.');
    time(starth,startl);
    for i := 1 to num_loops do begin r := s * t; end;
    time(endh,endl);
    doneit;
    end;
   
  procedure test12;
    begin
    fudge_loop := true;
    write('12.  ',numloops,' real divides.');
    time(starth,startl);
    for i := 1 to num_loops do begin r := s / t; end;
    time(endh,endl);
    doneit;
    end;
   
  procedure test13;
    begin
    fudge_loop := true;
    write('13.  ',numloops,' integer transfers.');
    time(starth,startl);
    for i := 1 to num_loops do begin j := k; end;
    time(endh,endl);
    doneit;
    end;
   
  procedure test14;
    begin
    fudge_loop := true;
    j := 5; k := 12;
    write('14.  ',numloops,
      ' integer array transfers.');
    time(starth,startl);
    for i := 1 to num_loops do begin a[j] := a[k]; end;
    time(endh,endl);
    doneit;
    end;
   
  procedure test15;
    begin
    fudge_loop := true;
    write('15.  ',numloops,' real transfers.');
    time(starth,startl);
    for i := 1 to num_loops do begin r := s; end;
    time(endh,endl);
    doneit;
    end;
   
  procedure test16;
    begin
    fudge_loop := true;
    j := 5; k := 12;
    write('16.  ',numloops,' real array transfers.');
    time(starth,startl);
    for i := 1 to num_loops do begin b[j] := b[k]; end;
    time(endh,endl);
    doneit;
    end;
   
  procedure test17;
    begin
    fudge_loop := true;
    write('17.  ',numloops,
      ' integer record transfers.');
    time(starth,startl);
    for i := 1 to num_loops do begin rec1.firsti := rec1.secondi; end;
    time(endh,endl);
    doneit;
    end;
   
  procedure test18;
    begin
    fudge_loop := true;
    write('18.  ',numloops,
      ' real record transfers.');
    time(starth,startl);
    for i := 1 to num_loops do begin rec1.firstr := rec1.secondr; end;
    time(endh,endl);
    doneit;
    end;
   
  procedure test19;
    begin
    fudge_loop := true;
    j := 5; k := 12;
    write('19.  ',numloops,
      ' integer if comparisons.');
    time(starth,startl);
    for i := 1 to num_loops do if (j < k) then begin end;
    time(endh,endl);
    doneit;
    end;
   
  procedure test20;
    begin
    fudge_loop := true;
    r := 5.0; s := 12.0;
    write('20.  ',numloops,' real if comparisons.');
    time(starth,startl);
    for i := 1 to num_loops do if (r < s) then begin end;
    time(endh,endl);
    doneit;
    end;
   
  procedure test21;
    begin
    fudge_loop := true;
    j := 2;
    write('21.  ',numloops,' case statements.');
    time(starth,startl);
    for i := 1 to num_loops do
      case j of
        1 : begin end;
        2 : begin end;
        3 : begin end;
        4 : begin end;
        end;
    time(endh,endl);
    doneit;
    end;
   
  procedure test22;
    begin
    fudge_loop := true;
    write('22.  ',numloops,' procedure calls.');
    time(starth,startl);
    for i := 1 to num_loops do dummy1;
    time(endh,endl);
    doneit;
    end;
   
  procedure test23;
    begin
    fudge_loop := true;
    write('23.  ',numloops,
      ' procedure calls with integer parameter.');
    time(starth,startl);
    for i := 1 to num_loops do dummy2(i);
    time(endh,endl);
    doneit;
    end;
   
  procedure test24;
    begin
    fudge_loop := true;
    write('24.  ',numloops,
      ' procedure calls with real parameter.');
    time(starth,startl);
    for i := 1 to num_loops do dummy3(r);
    time(endh,endl);
    doneit;
    end;
   
  procedure test25;
    begin
    fudge_loop := true;
    write('25.  ',numloops,
      ' procedure calls with a local variable.');
    time(starth,startl);
    for i := 1 to num_loops do dummy4;
    time(endh,endl);
    doneit;
    end;
   
  procedure test26;
    begin
    fudge_loop := true;
    write('26.  ',numloops,' set unions.');
    time(starth,startl);
    for i := 1 to num_loops do cset := cset + ['a','b'];
    time(endh,endl);
    doneit;
    end;

  procedure test27;
    begin
    fudge_loop := true;
    write('27.  ',numloops,' set differences.');
    time(starth,startl);
    for i := 1 to num_loops do cset := cset - ['a','b'];
    time(endh,endl);
    doneit;
    end;
   
  procedure test28;
    begin
    fudge_loop := true;
    write('28.  ',numloops,' set IN''s.');
    time(starth,startl);
    for i := 1 to num_loops do if (ch in cset) then begin end;
    time(endh,endl);
    doneit;
    end;
   
  procedure test29;
    begin
    fudge_loop := true;
    new(root); { create a loop of list elements }
    new(root^.next);
    root^.next^.next := root;
    ptr := root;
    write('29.  ',numloops,' pointer transfers.');
    time(starth,startl);
    for i := 1 to num_loops do ptr := ptr^.next;
    time(endh,endl);
    doneit;
    end;
   
  procedure test30;
    begin
    fudge_loop := true;
    write('30. ',numloops,' NOOP''s.');
    time(starth,startl);
    for i := 1 to num_loops do begin
      pmachine(156);
    end;
    time(endh,endl);
    doneit;
    end;
   
  begin { main }
   
  j := 100; k := 200; l := 300; r := 400; s := 500; t := 600;
  (*rewrite(printr,'printer:');*)
  write('Enter number of loops per test : ');
  readln(num_loops);
  test1;
  xs:=ABS(startl);
  xe:=ABS(endl);
  xt:=ABS(xe-xs)/60;
  overhead := (xt/numloops) * 1000;
  repeat
    prompt; 
    readln(test);
    if (test >= 0) then 
      case test of
        0 : begin
            test1; doneit; test2; test3; test4; test5; test6; test7; test8;
            test9; test10; test11; test12; test13; test14; test15;
            test16; test17; test18; test19; test20; test21; test22;
            test23; test24; test25; test26; test27; test28; test29;
            test30; end;
        1 : begin test1; doneit end; 2 : test2; 3 : test3; 4 : test4;
        5 : test5; 6 : test6; 7 : test7; 8 : test8;
        9 : test9; 10 : test10; 11 : test11; 12 : test12;
        13 : test13; 14 : test14; 15 : test15; 16 : test16;
        17 : test17; 18 : test18; 19 : test19; 20 : test20;
        21 : test21; 22 : test22; 23 : test23; 24 : test24;
        25 : test25; 26 : test26; 27 : test27; 28 : test28;
        29 : test29; 30 : test30;
        end;
        if test>=0 then
          begin
            write('Type <return> to continue');
            readln;
          end;
    until (test < 0);
  end.

========================================================================================
DOCUMENT :usus Folder:VOL18:benchmarks.text
========================================================================================


     Benchmarks

     There are a bunch of benchmarks on this disk.  They serve various
purposes and some overlap in what they are designed to test.  Some (such as
the Byte benchmark) are included only because there is an existing database of 
results already so that you can get an immediate (although rough) idea of the 
performance of your iron in comparison to other popular types.

     If you should feel so inclined, you may run some or all of the benchmarks 
and report (on the forms provided, please) the results to me (preferably by US
Mail).

     George Schreyer
     412 North Maria Avenue
     Redondo Beach, Ca.
     90277

     I will try to condense the results that I receive into some form of 
digestable format.  Presenting tables of performance numbers will be too 
cumbersome, so I will probably rank the speed of various computers based on a 
few of the pertanent benchmarks and note any hardware which is particularly
fast or slow at some particular operation, such as reals or somesuch.

     I will describe the purpose of each of them (if I know it) and what it is
primarily designed to test.  

     PWROF2. This benchmark test integer arithmetic exclusively.  It computes
the first 90 powers of 2.

     QUICKSORT.  This is the conventional recursive quicksort algorithm which 
sorts 10000 integers.  It tests integer arithmetic and it uses recursion 
and array indexing heavily.

     NUMBERIO.  This one writes a file of 25,000 real numbers and then reads 
them back.  It tests file I/O speed but is not particularly sensitive to
disk access time as only a few blocks are read and written, and no long head 
seeks are involved.  UCSD Pascal I/O is generally slow.

     8QUEENS.  This benchmark is another test of recursion and iterive 
constructs such as IF-THEN and FOR loops.

     PRIMES.  This one finds the first 1000 primes.  It is more 
computationally intensive than PWROF2.

     ANCEST.S.  This one manipulates sets.

     WHETSTONE.  This is a pascal implementation (from the original ALGOL) of 
the "magic" WHETSTONE benchmark.  It is a collection of weighted procedures 
which exercise the numerical capabilities of a machine.  It is often quoted in 
performance comparisons of various mainframes.  It is written to foil 
optimizing compilers and force execution of all of its constructs.  It is 
rather heavily biased to test real numbers.

     SIEVE.  This is the infamous Byte Benchmark, modified to compile under 
UCSD.  It is NOT modified to run the fastest under UCSD as a considerable 
database has been accumlated with the version supplied.  Within the file, you 
will find the results of several types of computers.

     BENCH.USUS.  This is the benchmark published in NL#4 by Jon Bondy.  It is 
a series of short loops which test specific constructs of UCSD Pascal.  This 
one (and the similar following ones) will probably be my best basis for 
machine and UCSD version comparison.

     LONG_INT.  This is similar to BENCH.USUS except that it specifically 
tests the performance of long interger operations.  Long integers are
implemented differently in different UCSD implementations, and I am interested 
if there are any significant differences in the performance between versions.

     INTRINSICS.  This one tests the results of several of the system 
intrinsics such as SIN and COS.  Again, I expect a wide variance of results 
from different UCSD systems.

     QUR.  This simple test indicates the general response of the operating 
system and disk system.  Its result changes radically for different disk 
systems and very radically between versions II.0 and IV.0.

     COMPKILLER.  This one is designed to crash your computer.  It indicates,
in a simple minded way, how big a program your system can compile by 
measuring the available size of the compiler symbol table.  Version IV.0 isn't 
nice enough to tell you this.

     STARS.  This one measures the speed of single character I/O.  It produced 
some suprising results under the LSI-11 extended memory implementation of 
IV.1.

     SEGMASHER.  Segmasher tests the speed of segment swaps.  Further 
instructions are given in the file.

     If this is all too much work to consider, then please just run two of the 
easist, SIEVE and QUR and submit just that data ALONG WITH YOUR SYSTEM 
CONFIGURATION AND p-SYSTEM VERSION!  SIEVE will more or less indicate your
system's processor speed and QUR will evaluate (among other things) your disk
system speed.

     regards - gws


========================================================================================
DOCUMENT :usus Folder:VOL18:black.doc1.text
========================================================================================

     Blackbox is aa game where one or more players guess the position of
marbles inside an 8 * 8 grid.  Information about the position of marbles in 
the grid is deduced by the player firing raays at any row or column in the 
grid.

     A ray fired at the black box can cause one of three possible outcomes.  
The outcome is indicated by a marker where the ray was fired.  A '*' marker 
means a ray fired from this location has hit a marble in the grid ( i.e. the 
ray hits a marble straight on and is absorbed and does not exit the board).  A 
'^' marker means a ray has been reflected ( the ray has approached two marbles
one grid apart and has bounced back and emerged from the grid at its entry
point).  A special case for reflection occurs at the grid boundary.  If a ray 
hits the corner of a marble at the ray entering boundary, it is reflected back 
without entering the grid.  A ray that passes through the grid without
absorption or reflection is marked by a lower case letter.  The first ray to
pass through is marked 'a', the second 'b', each subsequent marble labelled
by an ascending letter.  A ray turns 90 degrees if it does not hit a marble
straight on, but hits the marble at a corner.  One ray fired at the grid may
undergo zero or more 90 degree turns while in the black box, so that a
straight forward analysis of the marble path may not indicate the true path.

     Type <return> to continue.

========================================================================================
DOCUMENT :usus Folder:VOL18:black.doc2.text
========================================================================================

     
     The Blackbox program may be played in two modes.  In mode 1, the program 
places the hidden marbles in the 8 * 8 grid using a random number generator. 
In mode 2, a player may place marbles for an opponent to guess in the 8 * 8
grid.  In either mode, the player may select either 4 or 5 marbles to be
hidden in the grid.  The score of the game is the sum of the markers denoting
the number of rays needed to deduce the position of the marbles in the board.

     The commands to Blackbox are S(hoot, which fires a ray from a player 
selected row or column; M(anipulate Marbles, where the player may place
marbles to indicate a tentative guess; and G(uess when a player decides that 
his tentatively placed marbles represent a correct guess.  If the guess is 
correct, the game ends and the score is displayed.  The score is the sum of 
the markers '*','^', and 'a','b',etc.  If a guess is incorrect, a 5 marker 
penalty is added  and the game continues.

     Type <return> to start the game.

     

========================================================================================
DOCUMENT :usus Folder:VOL18:blackbox.text
========================================================================================

program blackbox;

     {  (C) Copyright 1980  Robert C. Hutchins   }
         
{screen control is "universal" although somewhat slow.  change it if you
wish - gws}

const 
    Version = '[x4]';
    xboardbase = 21;
    yboardbase = 3;
    xmarkerbase = 24;
    ymarkerbase = 4;
    debug = false;   
    
type 
    direction = (toeast,towest,tonorth,tosouth); 
    okset = set of char;

var 
    occupied: packed array[9..16,1..8] of boolean;    
    table: array[17..32] of integer;
    opposite,left,right: array[direction] of direction;
    startpos,endpos: array[direction] of integer;
    onboard,raydead: boolean;
    guesspenalty: integer;
    numguessed,numberballs,nummarkers: integer;  
    raypos,rayline,startrayline: integer; 
    letter: char;
    inc: -1..1;
    dir,startdir: direction; 
    turned90: boolean;   
    guess: array[1..5] of record
                            xpos,
                            ypos: integer;
                            aguessmade: boolean;
                          end;        
    markers: packed array[1..32] of char; 
    
procedure cleartopline;   
var line : packed array [ 1..79 ] of char;
begin        
  fillchar ( line, sizeof ( line ) , ' ' );
  gotoxy(0,0);
  unitwrite ( 2, line, sizeof ( line ) );
  gotoxy ( 0, 0 );
end;       
        
procedure clearscreen;
var buf : packed array [ 1 .. 24 ] of char;
begin  
   gotoxy ( 0, 23 );
   fillchar ( buf, sizeof ( buf ), chr ( 10 ) );
   unitwrite ( 2, buf, sizeof ( buf ) );
   gotoxy ( 0, 0 );
end;
        
function getcommand(ok: okset): char;
var tempch: char;
begin
  repeat
    read(keyboard,tempch);  
    if tempch in ['a'..'z'] then
      tempch := chr(ord(tempch) - ord('a') + ord('A'));
  until tempch in ok;  
  getcommand := tempch;
  writeln;
end;   

procedure needhelp; 
var ch: char; 
    f: text;
    s: string; 

procedure printhelp;
begin
  while not eof(f) do
    begin
      (*while not eoln(f) do
        begin  read(f,ch);  write(ch); end;
      readln(f); writeln;
      *)
      readln(f,s); writeln(s);
    end;
end;

begin
  write('Need help (Y or N) '); read(ch);
  clearscreen;
  if ch in ['Y','y'] then
    begin
      reset(f,'black.doc1.text'); 
      printhelp;
      close(f);
      readln;
      reset(f,'black.doc2.text');
      printhelp;
      readln;
      clearscreen;
    end;
end;

procedure initialize;    
var i: integer;
begin
  table[17] := 8;  table[18] := 7;  table[19] := 6;  
  table[20] := 5;  table[21] := 4;  table[22] := 3; 
  table[23] := 2;  table[24] := 1;  table[25] := 16;   
  table[26] := 15; table[27] := 14; table[28] := 13; 
  table[29] := 12; table[30] := 11; table[31] := 10;
  table[32] := 9;     
  opposite[toeast] := towest; opposite[towest] := toeast;
  opposite[tonorth] := tosouth; opposite[tosouth] := tonorth;    
  right[toeast] := tosouth; right[towest] := tonorth;  
  right[tonorth] := toeast; right[tosouth] := towest;      
  left[toeast] := tonorth; left[towest] := tosouth;  
  left[tonorth] := towest; left[tosouth] := toeast;      
  startpos[toeast] := 8; startpos[towest] := 17; 
  startpos[tonorth] := 9; startpos[tosouth] := 0;        
  endpos[toeast] := 17; endpos[towest] := 8; 
  endpos[tonorth] := 0; endpos[tosouth] := 9;        
  for i := 1 to 32 do markers[i] := ' ';   
  for i := 1 to 5 do guess[i].aguessmade := false;
  raydead := false; numguessed := 0; nummarkers := 0;                         
  letter := 'a';
  guesspenalty := 0; 
  clearscreen;
  needhelp;
end;         

function convert(coord: integer): integer;      
begin
  if coord <= 16 then convert := coord 
    else convert := -table[coord];
end;  
 
function unconvert(internal: integer): integer;
var i: integer;
begin
  if internal >= 17 then unconvert := internal  
  else                                  
    begin
      i := 16;
      repeat
        i := i + 1;
      until table[i] = internal;
      unconvert := i;
    end;
  if debug then
    begin
      gotoxy(0,0); writeln('unconvert i = ',i,' table[i] = ',table[i]); 
    end;
end;  

procedure getcoord(var xcoord,ycoord: integer);          
var error: boolean;
    coord1,coord2:  integer;
begin 
  {$I-}
  repeat
    cleartopline;
    write('Enter first coordinate (1..32) ');          
    readln(coord1);
  until (ioresult = 0) and (coord1 in [1..32]);                              
  repeat    
    repeat
      cleartopline; 
      write('Enter second coordinate (1..32) ');
      readln(coord2);  
    until (ioresult = 0) and (coord2 in [1..32]); 
    coord1 := abs(convert(coord1));  coord2 := abs(convert(coord2));       
    {Check if legal}
    error := ((abs(coord1) in [9..16]) and not(abs(coord2) in [1..8]))
                                       or
             ((abs(coord1) in [1..8]) and not(abs(coord2) in [9..16])); 
  until (ioresult = 0) and not error and (coord1 in [1..32]);   
  {$I+}
  if coord1 in [1..8] then
    begin  xcoord := coord2;  ycoord := coord1 end                          
  else 
    begin xcoord := coord1;   ycoord := coord2 end;
end;

function poccupied(x,y: integer): boolean;
begin
  if not(x in [9..16]) then poccupied := false else                        
  if not(y in [1..8] ) then poccupied := false else          
    poccupied := occupied[x,y];      
end;

procedure markerdisplay;      
var i: integer;
begin
  { Display top markers }  
  for i := 32 downto 25 do 
    begin
      gotoxy(xmarkerbase + (33 - i) * 4,ymarkerbase);        
      write(markers[i]); 
    end;
  { Display bottom markers }   
  for i := 9 to 16 do  
    begin
      gotoxy(xmarkerbase + (i - 8)* 4,ymarkerbase + 18);
      write(markers[i]);
    end;
  { Display left side markers }                         
  for i := 1 to 8 do    
    begin
      gotoxy(xmarkerbase,ymarkerbase + i * 2);
      write(markers[i]);
    end;
  { Display right side markers }          
  for i := 17 to 24 do  
    begin
      gotoxy(xmarkerbase + 9*4,ymarkerbase + (25 - i) * 2);                       
      write(markers[i]);
    end;    
end;   

procedure boarddisplay;  
begin
      
                   {12345678901234567890123456789012345678901234567890}
    
  gotoxy(xboardbase,yboardbase);
  write('      32  31  30  29  28  27  26  25      ',nummarkers,' Markers');   
  gotoxy(xboardbase,yboardbase + 1); 
  if guesspenalty > 0 then
    write('     |   |   |   |   |   |   |   |   |    ',guesspenalty * 5,' as Penalty')  
  else 
    write('     |   |   |   |   |   |   |   |   |    ');    
  gotoxy(xboardbase,yboardbase + 2);
  write('-----+---+---+---+---+---+---+---+---+------  '); 
  gotoxy(xboardbase,yboardbase + 3);
  write('1    |   |   |   |   |   |   |   |   |    24  ');       
  gotoxy(xboardbase,yboardbase + 4); 
  write('-----+---+---+---+---+---+---+---+---+------  ');
  gotoxy(xboardbase,yboardbase + 5); 
  write('2    |   |   |   |   |   |   |   |   |    23  ');
  gotoxy(xboardbase,yboardbase + 6); 
  write('-----+---+---+---+---+---+---+---+---+------  ');
  gotoxy(xboardbase,yboardbase + 7); 
  write('3    |   |   |   |   |   |   |   |   |    22  ');
  gotoxy(xboardbase,yboardbase + 8); 
  write('-----+---+---+---+---+---+---+---+---+------  ');
  gotoxy(xboardbase,yboardbase + 9); 
  write('4    |   |   |   |   |   |   |   |   |    21  ');
  gotoxy(xboardbase,yboardbase +10); 
  write('-----+---+---+---+---+---+---+---+---+------  '); 
  gotoxy(xboardbase,yboardbase +11); 
  write('5    |   |   |   |   |   |   |   |   |    20  ');
  gotoxy(xboardbase,yboardbase +12); 
  write('-----+---+---+---+---+---+---+---+---+------  ');
  gotoxy(xboardbase,yboardbase +13); 
  write('6    |   |   |   |   |   |   |   |   |    19  '); 
  gotoxy(xboardbase,yboardbase +14); 
  write('-----+---+---+---+---+---+---+---+---+------  ');
  gotoxy(xboardbase,yboardbase +15); 
  write('7    |   |   |   |   |   |   |   |   |    18  ');  
  gotoxy(xboardbase,yboardbase +16); 
  write('-----+---+---+---+---+---+---+---+---+------  ');                
  gotoxy(xboardbase,yboardbase +17); 
  write('8    |   |   |   |   |   |   |   |   |    17  ');
  gotoxy(xboardbase,yboardbase +18); 
  write('-----+---+---+---+---+---+---+---+---+------  ');      
  gotoxy(xboardbase,yboardbase +19); 
  write('     |   |   |   |   |   |   |   |   |        ');
  gotoxy(xboardbase,yboardbase +20); 
  write('       9  10  11  12  13  14  15  16          ');
  gotoxy(0,4);  write('''*'' =  hit');
  gotoxy(0,5);  write('''^'' =  reflection'); 
  gotoxy(0,6);  write('''a'',''b'' ...'); 
  gotoxy(0,7);  write('  pass through grid');
end;  

procedure marbledisplay(x,y: integer; mark: char);
begin
  gotoxy(xmarkerbase + (x - 8) * 4,ymarkerbase + y * 2);   
  write(mark);     
end;

procedure removemarble(x,y: integer);                    
begin
  gotoxy(xmarkerbase + (x - 8) * 4,ymarkerbase + y * 2);                  
  write(' ');
end;
    
procedure displayall;
var i,x,y: integer;
begin
  clearscreen;
  boarddisplay;     
  markerdisplay; 
  if debug then 
    for y := 1 to 8 do
      for x := 9 to 16 do
        if occupied[x,y] then marbledisplay(x,y,'O') ;    
  if not debug then                  
    for i := 1 to numberballs do
      with guess[i] do
        if aguessmade then marbledisplay(xpos,ypos,'O');
end;     

procedure setupmarbles;            
var xcoord, ycoord: integer;      
    i,j: integer;
    seed: integer;
    tempch: char; 

  function random(var fseed: integer; range: integer): integer;  
  begin
    fseed := (fseed * 25 + 1009) mod 1048;
    random := (fseed div 100) mod range;   
   end; 

begin  
  for i := 9 to 16 do 
    for j := 1 to 8 do occupied[i,j] := false;         
  {$I-}       
  repeat
    cleartopline;  
    write('Enter number of balls (4 or 5) ');          
    readln(numberballs); 
  until (ioresult = 0) and (numberballs in [4,5]);       
  {$I+}
  cleartopline;  
  write('Do you want to place the balls? (Y or N)');                        
  read(keyboard,tempch); writeln;
  if tempch in ['n','N'] then
    begin
      repeat 
        cleartopline;
        write('Enter random number seed (0..999) ');
        readln(seed);      
      until (seed >= 0) and (seed <= 999);  
      i := 0;
      repeat
        i := i + 1;
        xcoord := random(seed,8) + 1 + 8;   ycoord := random(seed,8) + 1;
        if occupied[xcoord,ycoord] then i := i -1   
        else
          occupied[xcoord,ycoord] := true;             
      until i >= numberballs;
    end
  else
    begin
      i := 0;
      repeat
        i := i + 1;
        getcoord(xcoord,ycoord);      
        if occupied[xcoord,ycoord] then i := i -1 
        else
          occupied[xcoord,ycoord] := true;             
      until i >= numberballs;
    end; 
end;   
        
procedure UserRayShot; 
var tempch: char;
begin      
  {$I-}      
  repeat
    cleartopline;
    write('Enter ray start column ');  
    readln(startrayline);
  until (ioresult = 0) and (startrayline in [1..32]);       
  rayline := convert(startrayline);  
  if rayline in [1..8] then dir := toeast else  
  if rayline in [9..16] then dir := tonorth else 
  if -rayline in [1..8] then dir := towest else       
  if -rayline in [9..16] then dir := tosouth;       
  rayline := abs(rayline);  
  if dir in [toeast,tosouth] then inc := 1 else inc := -1;    
  raypos := startpos[dir];                  
  startdir := dir;      
  turned90 := false; onboard := false;                
end;  

function marble: boolean;
begin
  if dir in [toeast,towest] then   
    marble := poccupied(raypos+inc,rayline) 
  else marble := poccupied(rayline,raypos+inc);
end; 
  
procedure hit;
begin
  raydead := true;      
  markers[startrayline] := '*';   
  nummarkers := nummarkers + 1;
end;  

function corner: boolean;    
begin
  if dir in [toeast,towest] then 
    corner := (poccupied(raypos+inc,rayline-1) or           
               poccupied(raypos+inc,rayline+1))
  else 
    corner := (poccupied(rayline-1,raypos+inc) or             
               poccupied(rayline+1,raypos+inc));    
end;

function  bothcorners: boolean;  
begin
  if dir in [toeast,towest] then         
    bothcorners := (poccupied(raypos+inc,rayline-1) and          
                    poccupied(raypos+inc,rayline+1))    
  else
    bothcorners := (poccupied(rayline-1,raypos+inc) and                  
                    poccupied(rayline+1,raypos+inc));                    
end;

procedure turn90;                
var temp: integer;    
begin      
  if dir in [toeast,towest] then  
    begin
      if poccupied(raypos+inc,rayline-1) then dir := tosouth 
        else dir := tonorth
    end
  else { dir in [tonorth,tosouth] }
    begin
      if poccupied(rayline-1,raypos+inc) then dir := toeast
        else dir := towest
    end;
  if dir in [toeast,tosouth] then inc := 1 else inc := -1;          
  temp := rayline;  
  rayline := raypos;
  raypos := temp;
  turned90 := true;    
end;

procedure reflect;      
begin
  dir := opposite[dir];  
  inc := -inc;
end; 

procedure terminateray;        
var reflection: boolean;
    realcolumn: integer;    
begin
  reflection := false;      
  if startdir <> dir then 
    reflection := (rayline = abs(convert(startrayline))) 
                  and (dir = opposite[startdir]);             
  if reflection then
    begin
      markers[startrayline] := '^';  
      nummarkers := nummarkers + 1;            
    end
  else
    begin { pass thru }        
      markers[startrayline] := letter;  
      if (rayline in [1..8]) and (dir = toeast) then      
        rayline := unconvert(rayline)
      else if (rayline in [9..16]) and (dir = tonorth) then    
        rayline := unconvert(rayline);
      markers[rayline] := letter;   
      nummarkers := nummarkers + 2;  
      letter := succ(letter);
    end;  
end;

procedure raydisplay;
begin  
  if debug then
    begin
      if dir in [toeast,towest] then
        gotoxy(xmarkerbase + (raypos - 8) * 4, ymarkerbase + rayline * 2)     
      else    
        gotoxy(xmarkerbase + (rayline - 8) * 4, ymarkerbase + raypos * 2);    
      write('.');  
    end;
end;   

procedure moveray;   
var reflection : boolean;
begin
  if debug then
    begin
      gotoxy(0,1); writeln('  raypos = ',raypos,' rayline = ',rayline,' dir = ',        
                       ord(dir));  
    end;
  if turned90 then turned90 := false 
  else
    begin
      raypos := raypos + inc;
      raydisplay; 
      raydead := ((inc > 0) and (raypos >= endpos[dir])) or 
                 ((inc < 0) and (raypos <= endpos[dir])); 
      if raydead then terminateray;  
    end;
  onboard := true;  
end; 

procedure endgame;          
var ch: char;
    i,x,y: integer;
begin
  cleartopline;
  write('Do you want to end the game? (Y or N)');         
  ch := getcommand(['Y','N']);
  if ch = 'Y' then 
    begin
      displayall;
      for y := 1 to 8 do 
        for x := 9 to 16 do
          if occupied[x,y] then marbledisplay(x,y,'X') ; 
      for i := 1 to numberballs do  
        with guess[i] do
          if aguessmade then 
            if occupied[xpos,ypos] then marbledisplay(xpos,ypos,'C')  
              else marbledisplay(xpos,ypos,'O');  
      exit(program);                
    end;
end;     

procedure AskIfaGuess;    
var ch: char;
    i: integer;  
    ok: boolean;
begin 
  cleartopline;
  write('Does this represent your guess? (Y or N)');      
  ch := getcommand(['Y','N']);
  if ch = 'N' then endgame;
  ok := true;     
  for i := 1 to numberballs do  
    if not poccupied(guess[i].xpos,guess[i].ypos) then         
      ok := false;
  if not ok then  
    begin  
      nummarkers := nummarkers + 5;       
      guesspenalty := guesspenalty + 1;        
      displayall; 
      endgame;  
    end 
  else 
    begin
      displayall;  
      cleartopline;
      gotoxy(2,2);
      writeln('You are correct ',nummarkers, ' used.');              
      exit(program);   
    end;
end;  
  
procedure insert;    
var i, guessindex: integer;  
begin
  if numguessed < numberballs then      
    begin  
      numguessed := numguessed + 1;
      guessindex := 0;       
      for i := 1 to numberballs do
        if not guess[i].aguessmade then
          guessindex := i;
      with guess[guessindex] do      
        begin
          getcoord(xpos,ypos);
          aguessmade := true;          
        end;
    end;
end;    

procedure delete;
var i: integer;
    x,y: integer;    
    found: boolean;  
begin
  if numguessed > 0 then
    begin
      i := 0; 
      getcoord(x,y);
      repeat 
        i := i + 1;
        with guess[i] do
          begin
            if aguessmade then
              found := (xpos = x) and (ypos = y) ;  
          end;
      until found or (i = numberballs);             
      if found then     
        begin
          guess[i].aguessmade := false;        
          numguessed := numguessed - 1;
        end;
    end;     
end;  

procedure marblemanipulate;  
var mchar: char;  
    x,y: integer;
    endmanipulating : boolean;
begin  
  endmanipulating := false;  
  cleartopline;
  write('P(lace a marble  D(elete a marble  N(o move ');
  mchar := getcommand(['P','D','N']);
  case mchar of
    'P','p': 
        insert;  
    'D','d': 
        delete; 
    'n','N':   
      endmanipulating := true;     
    end;  
  displayall;
end;  

function Command: boolean;       
var mchar : char;
    endmoving : boolean; 
begin { placeaball } 
  displayall;       
  command := true; 
  endmoving := false;  
  repeat
    cleartopline;
    write('M(arble manipulate  S(hoot ray  G(uess game');            
    mchar := getcommand(['M','S','G']);    
    case mchar of  
      'M','m':
        marblemanipulate;
      'S','s':      
        begin 
          endmoving := true;
          UserRayShot; 
        end;
      'G','g':       
        AskIfaGuess;  
      end;    
  until endmoving; 
end { placeaball }; 
 

begin  {outerblock}   
  initialize;   
  setupmarbles;       
  clearscreen;
  while command do      
    begin
      repeat
        if marble then hit
        else 
          begin
            if corner then 
              if onboard then    
                begin
                  if bothcorners then reflect  
                  else turn90
                end
              else  { Not on the board so } reflect;  
            moveray;  
          end;
      until raydead;
    end; 
end.


========================================================================================
DOCUMENT :usus Folder:VOL18:bondy_form.text
========================================================================================

                         Bondy's Benchmark Report Form

Use this form to report on the result of Jon Bondy's benchmark from USUS
NewsLetter #4.  There is a version of it on this disk, called BENCH.USUS.TEXT.
It is self timing if you have a clock.  

Tests with real operations should be benchmarked with 2 and 4 word reals
when they are available.  Test 30 is for version IV.x only.  

Please report on the compilation time of the program.  If you use version II.0
it is important that you specify if you used S+ or S-.

Please report in milli-seconds per loop with the loop overhead of test 1 
removed for tests 6 thru 30.

Test                                    time ( ms/loop )

1       for loop ( to )                 __________
2       for loop ( downto )             __________
3       integer increment               __________
4       while loop                      __________
5       repeat loop                     __________

remember to subtract the result of test 1 from the following results

6       integer add                     __________
7       integer multiply                __________
8       integer divide                  __________
9       real increment        (2 word)  __________      (4 word)  _________
10      read add              (2 word)  __________      (4 word)  _________
11      real multiply         (2 word)  __________      (4 word)  _________
12      real divide           (2 word)  __________      (4 word)  _________
13      integer transfer                __________
14      integer array transfer          __________
15      real transfer         (2 word)  __________      (4 word)  _________
16      real array transfer   (2 word)  __________      (4 word)  _________
17      integer record transfer         __________
18      real record transfer  (2 word)  __________      (4 word)  _________
19      integer if compare              __________
20      real if compare       (2 word)  __________      (4 word)  _________
21      case statement                  __________
22      procedure call                  __________
23      procedure w/integer             __________
24      procedure w/real      (2 word)  __________      (4 word)  _________
25      procedure w/local var           __________
26      set union                       __________
27      set difference                  __________
28      set "in"                        __________
29      pointer transfer                __________
30      call to pmachine ( IV.x only )  __________

Compilation time  _____________   lines per minute _____________


========================================================================================
DOCUMENT :usus Folder:VOL18:compkiller.text
========================================================================================

program stack_death;

     {this program writes a file with a bunch of declarations, so many in fact
that the resultant file should not compile, it will crash of a stack
overflow.  If it does, make 'big_number' even bigger so that the program will
just compile.  When the program becomes too large, it is easist to comment out
lines until it does compile.  Then remove any commented-out lines and re-run
it, time it if you wish.  Please note the number of lines displayed by the
compiler.

     This indicates the actual amount of symbol table space which you have
available, with enough room for the compiler to still continue to operate.
Version II.0 kept you nicely informed about how much room was available in the
symbol table, but not so IV.x, it just goes slower and slower until it dies. 
If you are using something earlier than IV.0, try it both with $S- and $S+.

     II.0 will compile the declarations at a fairly constant rate.  If there
are too many declarations, the compiler will crash with a stack overflow.  The 
compiler may still crash when it tries to compile the main body if there is
not enough room to swap into memory a new code segment.  When it finally 
displays the program name, you may have to eliminate several hundered lines
of declarations before will finished.

     IV.x will compile at a greatly fluctuating rate.  It will go for a while
and then stop for a while, go a little further and stop again.  What is 
happening is that the system is suffering heap faults as a bigger and bigger 
symbol table is generated.  The code pool is then moved halfway between the 
stack and the heap, and the system can go again until it suffers another heap 
fault and must manage memory again.  This happens a shorter and shorter 
intervals until the code pool can no longer be moved.  The system will then
throw out a segment, and go through the same sequence until it has to throw
out another segment.  Finally, when the compiler gets really desperate, it
begins swapping code segments in and out of memory for every line! At this
point, you are scraping the bottom of the bucket.  In the case of this test
program, certain death is not far away, as when the main body is reached, a
large segment must be loaded, and there is no room.  A stack overflow
results, and the system will require rebooting.  As in II.0, reduce the
number of lines of declarations until the compilation completes and record
the number of lines and the elapsed time from envoking the compiler to
returning to the system prompt.

     IV.1 systems with extended memory will behave differently.  Code segments
do not reside between the stack and the heap so movement of the code pool is
not necessary.  Segment references are all to memory, so they happen very
fast.  The compiler will continue at a fairly constant, if not leasurely, rate
until the main body is reached.  The segment load here is not deadly, as it
does not affect the heap space.  As before, note the time and number of lines
for the run.  With a hard disk, IV.1 will be just a little faster than IV.0
on large programs.  With floppy, the difference should be significant.  On 
most extended memory systems, the size of the compilable file will be much 
larger in IV.1.  On the PDP-11 and probably the 9900, the size will be about 
the same.

     - gws }

const big_number = 1500;
var i : integer;
    disk : text;
    
begin
   rewrite ( disk, 'stackdeath.text' );
   writeln ( disk, 'program stackdeath;' );
   writeln ( disk, 'var' );
   for i := 1 to big_number do 
      begin
         write ( '.' );
         if ( i mod 50 ) = 0 then writeln;
         writeln ( disk, 'a', i, ',' );
      end;
   writeln ( disk, 'b : integer;' );
   writeln ( disk, 'begin' );
   writeln ( disk, 'end.' );
   close ( disk, lock );
end.


========================================================================================
DOCUMENT :usus Folder:VOL18:debug.a.text
========================================================================================

(*$U-*)
PROGRAM PASCALSYSTEM;

(************************************************)
(*                                              *)
(*    UCSD PASCAL OPERATING SYSTEM              *)
(*                                              *)
(*    RELEASE LEVEL:  I.3			*)
(*						*)
(*    WRITTEN BY ROGER T. SUMNER                *)
(*    WINTER 1977                               *)
(*                                              *)
(*    INSTITUTE FOR INFORMATION SYSTEMS         *)
(*    UC SAN DIEGO, LA JOLLA, CA                *)
(*                                              *)
(*    KENNETH L. BOWLES, DIRECTOR               *)
(*                                              *)
(*    THIS SOFTWARE IS THE PROPERTY OF THE      *)
(*  REGENTS OF THE UNIVERSITY OF CALIFORNIA.    *)
(*                                              *)
(************************************************)

CONST
     MAXUNIT = 8;	(*MAXIMUM PHYSICAL UNIT # FOR UREAD*)
     MAXDIR = 77;	(*MAX NUMBER OF ENTRIES IN A DIRECTORY*)
     VIDLENG = 7;	(*NUMBER OF CHARS IN A VOLUME ID*)
     TIDLENG = 15;	(*NUMBER OF CHARS IN TITLE ID*)
     MAXSEG = 15;	(*MAX CODE SEGMENT NUMBER*)
     FBLKSIZE = 512;	(*STANDARD DISK BLOCK LENGTH*)
     DIRBLK = 2;	(*DISK ADDR OF DIRECTORY*)
     AGELIMIT = 600;	(*MAX AGE FOR GDIRP...IN TICKS*)
     EOL = 13;		(*END-OF-LINE...ASCII CR*)

TYPE

     IORSLTWD = INTEGER;

					(*ARCHIVAL INFO...THE DATE*)

     DATEREC = INTEGER;

					(*VOLUME TABLES*)
     UNITNUM = 0..MAXUNIT;
     VID = STRING[VIDLENG];

					(*DISK DIRECTORIES*)
     DIRRANGE = 0..MAXDIR;
     TID = STRING[TIDLENG];

     FILEKIND = INTEGER;

     DIRENTRY = INTEGER;
     DIRP = ^DIRECTORY;

     DIRECTORY = ARRAY [DIRRANGE] OF DIRENTRY;

					(*FILE INFORMATION*)

     CLOSETYPE = INTEGER;
     WINDOWP = ^WINDOW;
     WINDOW = PACKED ARRAY [0..0] OF CHAR;
     FIBP = ^FIB;

     FIB = INTEGER;

					(*USER WORKFILE STUFF*)

					(*CODE SEGMENT LAYOUTS*)

     SEGRANGE = 0..MAXSEG;
     SEGDESC = INTEGER;

					(*DEBUGGER STUFF*)

     BYTERANGE = 0..255;
     MSCWP = ^ MSCW;		(*MARK STACK RECORD POINTER*)
     MSCW = INTEGER;

					(*SYSTEM COMMUNICATION AREA*)
					(*SEE INTERPRETERS...NOTE  *)
					(*THAT WE ASSUME BACKWARD  *)
					(*FIELD ALLOCATION IS DONE *)
     SYSCOMREC = RECORD
		   IORSLT: IORSLTWD;	(*RESULT OF LAST IO CALL*)
		   XEQERR: INTEGER;	(*REASON FOR EXECERROR CALL*)
		   SYSUNIT: UNITNUM;	(*PHYSICAL UNIT OF BOOTLOAD*)
		   BUGSTATE: INTEGER;(*DEBUGGER INFO*)
		   GDIRP: DIRP;		(*GLOBAL DIR POINTER,SEE VOLSEARCH*)
		   LASTMP,STKBASE,BOMBP: MSCWP;
		   MEMTOP,SEG,JTAB: INTEGER;
		   BOMBIPC: INTEGER;	(*WHERE XEQERR BLOWUP WAS*)
		   EXPANSION: ARRAY [0..14] OF INTEGER;
		   HIGHTIME,LOWTIME: INTEGER;
		   MISCINFO: PACKED RECORD
			       NOBREAK,STUPID,SLOWTERM,
			       HASXYCRT,HASLCCRT,HAS8510A,HASCLOCK: BOOLEAN
			     END;
		   CRTTYPE: INTEGER;
		   CRTCTRL: PACKED RECORD
			      RLF,NDFS,ERASEEOL,ERASEEOS,HOME,ESCAPE: CHAR;
			      BACKSPACE: CHAR;
			      FILLCOUNT: 0..255;
			      EXPANSION: PACKED ARRAY [0..3] OF CHAR
			    END;
		   CRTINFO: PACKED RECORD
			      WIDTH,HEIGHT: INTEGER;
			      RIGHT,LEFT,DOWN,UP: CHAR;
			      BADCH,CHARDEL,STOP,BREAK,FLUSH,EOF: CHAR;
			      ALTMODE,LINEDEL: CHAR;
			      EXPANSION: PACKED ARRAY [0..5] OF CHAR
			    END;
		   SEGTABLE: ARRAY [SEGRANGE] OF
			       RECORD
				 CODEUNIT: UNITNUM;
				 CODEDESC: SEGDESC
			       END
		 END (*SYSCOM*);

VAR
    SYSCOM: ^SYSCOMREC;			(*MAGIC PARAM...SET UP IN BOOT*)
    GFILES: ARRAY [0..5] OF FIBP;	(*GLOBAL FILES, 0=INPUT, 1=OUTPUT*)
    EMPTYHEAP: ^INTEGER;		(*HEAP MARK FOR MEM MANAGING*)
    INPUTFIB,OUTPUTFIB,SYSTERM: FIBP;	(*ACTUAL FILES...GFILES ARE COPIES*)
    SYVID,DKVID: VID;			(*SYSUNIT VOLID & DEFAULT VOLID*)
    THEDATE: DATEREC;			(*TODAY...SET IN FILER OR SIGN ON*)
    DEBUGINFO: ^INTEGER;		(*DEBUGGERS GLOBAL INFO WHILE RUNIN*)
    PL: STRING;				(*PROMPTLINE STRING...SEE PROMPT*)
(*-------------------------------------------------------------------------*)
(* SYSTEM PROCEDURE FORWARD DECLARATIONS *)
(* THESE ARE ADDRESSED BY OBJECT CODE... *)
(*  DO NOT MOVE WITHOUT CAREFUL THOUGHT  *)

PROCEDURE EXECERROR;
  FORWARD;
PROCEDURE FINIT(VAR F: FIB; WINDOW: WINDOWP; RECWORDS: INTEGER);
  FORWARD;
PROCEDURE FRESET(VAR F: FIB);
  FORWARD;
PROCEDURE FOPEN(VAR F: FIB; VAR FTITLE: STRING;
		FOPENOLD: BOOLEAN; JUNK: FIBP);
  FORWARD;
PROCEDURE FCLOSE(VAR F: FIB; FTYPE: CLOSETYPE);
  FORWARD;
PROCEDURE FGET(VAR F: FIB);
  FORWARD;
PROCEDURE FPUT(VAR F: FIB);
  FORWARD;
PROCEDURE FSEEK(VAR F: FIB);
  FORWARD;
FUNCTION FEOF(VAR F: FIB): BOOLEAN;
  FORWARD;
FUNCTION FEOLN(VAR F: FIB): BOOLEAN;
  FORWARD;
PROCEDURE FREADINT(VAR F: FIB; VAR I: INTEGER);
  FORWARD;
PROCEDURE FWRITEINT(VAR F: FIB; I,RLENG: INTEGER);
  FORWARD;
PROCEDURE FREADREAL(VAR F: FIB; VAR X: REAL);
  FORWARD;
PROCEDURE FWRITEREAL(VAR F: FIB; X: REAL; W,D: INTEGER);
  FORWARD;
PROCEDURE FREADCHAR(VAR F: FIB; VAR CH: CHAR);
  FORWARD;
PROCEDURE FWRITECHAR(VAR F: FIB; CH: CHAR; RLENG: INTEGER);
  FORWARD;
PROCEDURE FREADSTRING(VAR F: FIB; VAR S: STRING; SLENG: INTEGER);
  FORWARD;
PROCEDURE FWRITESTRING(VAR F: FIB; VAR S: STRING; RLENG: INTEGER);
  FORWARD;
PROCEDURE FWRITEBYTES(VAR F: FIB; VAR A: WINDOW; RLENG,ALENG: INTEGER);
  FORWARD;
PROCEDURE FREADLN(VAR F: FIB);
  FORWARD;
PROCEDURE FWRITELN(VAR F: FIB);
  FORWARD;
PROCEDURE SCONCAT(VAR DEST,SRC: STRING; DESTLENG: INTEGER);
  FORWARD;
PROCEDURE SINSERT(VAR SRC,DEST: STRING; DESTLENG,INSINX: INTEGER);
  FORWARD;
PROCEDURE SCOPY(VAR SRC,DEST: STRING; SRCINX,COPYLENG: INTEGER);
  FORWARD;
PROCEDURE SDELETE(VAR DEST: STRING; DELINX,DELLENG: INTEGER);
  FORWARD;
FUNCTION SPOS(VAR TARGET,SRC: STRING): INTEGER;
  FORWARD;
FUNCTION FBLOCKIO(VAR F: FIB; VAR A: WINDOW;
		  NBLOCKS,RBLOCK: INTEGER; DOREAD: BOOLEAN): INTEGER;
  FORWARD;

(* NON FIXED FORWARD DECLARATIONS *)

FUNCTION VOLSEARCH(VAR FVID: VID; LOOKHARD: BOOLEAN;
		   VAR FDIR: DIRP): UNITNUM;
  FORWARD;
PROCEDURE WRITEDIR(FUNIT: UNITNUM; FDIR: DIRP);
  FORWARD;
FUNCTION DIRSEARCH(VAR FTID: TID; FINDPERM: BOOLEAN; FDIR: DIRP): DIRRANGE;
  FORWARD;
FUNCTION SCANTITLE(FTITLE: STRING; VAR FVID: VID; VAR FTID: TID;
		   VAR FSEGS: INTEGER; VAR FKIND: FILEKIND): BOOLEAN;
  FORWARD;
PROCEDURE DELENTRY(FINX: DIRRANGE; FDIR: DIRP);
  FORWARD;
PROCEDURE INSENTRY(VAR FENTRY: DIRENTRY; FINX: DIRRANGE; FDIR: DIRP);
  FORWARD;
PROCEDURE CLEARSCREEN;
  FORWARD;
PROCEDURE PROMPT;
  FORWARD;
FUNCTION SPACEWAIT: BOOLEAN;
  FORWARD;
FUNCTION GETCHAR(FLUSH: BOOLEAN): CHAR;
  FORWARD;
PROCEDURE EXECUTE(RUNWORKFILE: BOOLEAN);
  FORWARD;
PROCEDURE COMMAND;
  FORWARD;

(* Interactive Pascal Debugger*)
(* Version I.3  Released 7/21/77 *)

(* Written Summer 1977 *)
(* Author  Joel McCormack *)
(* Assistant authors Dave Wollner, Chip Chapin, Lucia Bennett *)

SEGMENT PROCEDURE USERPROGRAM(VAR INPUT, OUTPUT: TEXT);
BEGIN END; (* USERPROGRAM *)

SEGMENT PROCEDURE COMPILER;
  SEGMENT PROCEDURE COMPINIT;
  BEGIN END; (* COMPINIT *)
BEGIN END; (* COMPILER *)

SEGMENT PROCEDURE EDITOR;
BEGIN END; (* EDITOR *)

SEGMENT PROCEDURE FILEHANDLER;
BEGIN END; (* FILEHANDLER *)




SEGMENT PROCEDURE DEBUGGER;

CONST
  (* Special Characters *)
  ORDALT = 27;
  ORDCR = 13;
  ORD0 = 48;

  (* Positioning of info on screen *)
  PROMPTLINE = 0;
  INFOLINE = 3;
  HEADINGLINE = 7;
  FIRSTDATALINE = 8;
  LINKCOLUMN = 54;

  (* Information about the hardware and implementation *)
  DELTAMSCW = 12;
  DATAOFFSET = 1; (* The first data offset *)
  WORDSZ = 2;
  BYTESPERWORD = 2;
  LOBYTE = 1;
  HIBYTE = 2;
  HEXPERWORD = 4;
  MAXBREAKPNTS = 9;
  JTABPROCANDLL = 0; (* The offsets by words in the JUMPTABLE.  Indexed off of
			@JTAB *)
  JTABENTRIC = -1;
  JTABEXITIC = -2;
  JTABPARMSZ = -3;
  JTABDATASZ = -4;

  (* BUGSTATES *)
  ASLEEP = 0;   WAKINGUP = 1;   CRAWLING = 2;
  WALKING = 3;  RUNNING = 4;    EXAMINING = 5;

TYPE
     DEBUGLINE = (EMPTYLINE,DATALINE,STACKLINE,POINTERLINE);
     BUGINFOREC = RECORD
		      BUFFEREMPTY: BOOLEAN;
		      DATAPLACE: INTEGER;
		      SCREENINFO: ARRAY [8..22] OF
				    RECORD
					CASE LINETYPE: DEBUGLINE OF
					  DATALINE,STACKLINE:
					    (SEG: SEGRANGE;
					     PROC: BYTERANGE;
					     DISP: INTEGER);
					  POINTERLINE:
					    (HEAPPOINTER: INTEGER)
				    END
		    END (*BUGINFOREC*) ;
  OCTRANGE = 0..7;
  HEXRANGE = 0..15;
  MEMTYPE = RECORD CASE INTEGER OF  (* Used to get at memory in various
				     and convenient ways *)
	      0: (INTVAL: INTEGER);
	      1: (HEXVAL: PACKED ARRAY[1..HEXPERWORD] OF HEXRANGE);
	      2: (BYTEVAL: PACKED ARRAY[1..BYTESPERWORD] OF BYTERANGE);
	      3: (CHARVAL: PACKED ARRAY[1..BYTESPERWORD] OF CHAR);
	      4: (OCTVAL: PACKED RECORD
			    FD0, FD1, FD2, FD3, FD4: OCTRANGE;
			    FIRSTDIGIT: 0..1
			  END);
	      5: (BYTEOCTVAL: PACKED RECORD
				LD1, LD2: OCTRANGE;
				LD0: 0..3;
				HD1, HD2: OCTRANGE;
				HD0: 0..3
			      END);
	      6: (PTVAL: ^MEMTYPE)
	    END;(* RECORD MEMTYPE *)
  MEMARRAY = ARRAY [0..0] OF MEMTYPE;

  DMSCWP = ^DMSCW;
  DMSCW = RECORD  (* MSCW in convenient format *)
	    MSSTAT: DMSCWP;
	    MSDYN: DMSCWP;
	    MSJTAB: ^MEMARRAY;
	    MSSEG: ^MEMTYPE;
	    MSIPC: INTEGER;
	    MSSP: ^MEMARRAY;
	    MSDATA:  ARRAY [DATAOFFSET..DATAOFFSET] OF MEMTYPE
	  END; (* Debug Mark Stack Control Word *)

  DIRECTYPE = (UP,DOWN);
  LINKTYPE = (STATIC,DYNAMIC);


VAR
  LASTDATALINE, COMLINE: INTEGER;

  BUGDEBUGINFO: ^BUGINFOREC;
  JEXERRP: DMSCWP;  (*Pointer to EXECERROR *)
  PPROCINFO, PLINKINFO: DMSCWP; (* Pointers to current proc *)

  DATOFF, STOFF,  (* Default offsets for stack and data *)
  LNGTH,  (* Default length to use *)
  SEGNUM, PROCNUM,  (* Info about current proc *)
  LINKLEVEL: INTEGER;  (* Number of DYNAMIC links above bombed proc *)
  LINKDEFAULT: LINKTYPE;
  DIRECTION: DIRECTYPE;

  DELAYCNT,  (* Used to wait while in WALKING mode *)

  DIGITSET: SET OF '0'..'9';
  DOWNCHARS: STRING[31];
  ACROSSCHARS: STRING[79];

========================================================================================
DOCUMENT :usus Folder:VOL18:debug.b.text
========================================================================================

FUNCTION INTREAD(VAR N: INTEGER): BOOLEAN;
VAR CH: CHAR;
BEGIN
  REPEAT  READ(KEYBOARD, CH)  UNTIL  (CH <> ' ') OR EOLN(KEYBOARD);
  IF CH IN DIGITSET THEN
    BEGIN
      N := 0;  INTREAD := TRUE;
      REPEAT
	N := 10*N+ORD(CH)-ORD0;  WRITE(OUTPUT, CH);  READ(KEYBOARD, CH);
      UNTIL (NOT (CH IN DIGITSET)) OR (N >= 3276);
    END
  ELSE  INTREAD := FALSE;
END; (* INTREAD *)


FUNCTION FINDPROC(SEGNUM, PROCNUM: BYTERANGE; STRTPLACE: DMSCWP;
		  VAR PPROCINFO, PLINKINFO: DMSCWP;
		  VAR LEVELSUP: INTEGER): BOOLEAN;
VAR FOUND: BOOLEAN;
BEGIN
  LEVELSUP := 0;
  PPROCINFO := STRTPLACE;
  PLINKINFO := PPROCINFO^.MSDYN;
  FOUND := (PPROCINFO^.MSJTAB^[JTABPROCANDLL].BYTEVAL[LOBYTE] = PROCNUM) AND
	   (PPROCINFO^.MSSEG^.BYTEVAL[LOBYTE] = SEGNUM);
  WHILE (NOT FOUND) AND (PLINKINFO^.MSDYN <> PLINKINFO) DO
    BEGIN
      LEVELSUP := LEVELSUP + 1;
      PPROCINFO := PLINKINFO;
      PLINKINFO := PPROCINFO^.MSDYN;
      FOUND := (PPROCINFO^.MSJTAB^[JTABPROCANDLL].BYTEVAL[LOBYTE] = PROCNUM) AND
	       (PPROCINFO^.MSSEG^.BYTEVAL[LOBYTE] = SEGNUM);
    END;
  FINDPROC := FOUND;
END; (* FINDPROC *)


PROCEDURE PUTCURSOR(LINE, COLUMN: INTEGER);
VAR I: INTEGER;
BEGIN
  WITH SYSCOM^, CRTCTRL, CRTINFO DO
    BEGIN
      IF ESCAPE = CHR(0) THEN WRITE(OUTPUT, HOME)
			 ELSE WRITE(OUTPUT, ESCAPE, HOME);
      WRITE(OUTPUT, COPY(ACROSSCHARS, 1, COLUMN), COPY(DOWNCHARS, 1, LINE));
    END
END; (*PUTCURSOR*)


PROCEDURE CLEARLINE(LINE: INTEGER);
BEGIN
  PUTCURSOR(LINE, 0);
  WITH SYSCOM^.CRTCTRL DO
    IF ESCAPE = CHR(0) THEN WRITE(OUTPUT, ERASEEOL)
		       ELSE WRITE(OUTPUT, ESCAPE, ERASEEOL)
END; (* CLEARLINE *)


PROCEDURE CLEARTHISLINE;
BEGIN
  WITH SYSCOM^.CRTCTRL DO
    IF ESCAPE =CHR(0) THEN WRITELN(OUTPUT, ERASEEOL)
		      ELSE WRITELN(OUTPUT, ESCAPE, ERASEEOL);
END;


PROCEDURE SPACEWAIT;
VAR CH: CHAR;
BEGIN
  REPEAT
    CLEARLINE(COMLINE);
    WRITE(OUTPUT, '......Hit [space] to continue......');
    READ(KEYBOARD, CH);
  UNTIL CH = ' ';
END;


PROCEDURE ERRORINDEBUGGER;
BEGIN
  CLEARLINE(PROMPTLINE+1);
  WRITELN(OUTPUT, 'I seem to have made a serious error and if you don''t mind,');
  WRITELN(OUTPUT, 'I am going to die peacefully.  .....AARGHHHHHH !!!!!!');
  EXIT(USERPROGRAM);
END; (* ERRORINDEBUGGER *)


FUNCTION GETPARAMS(VAR DSEGNUM: SEGRANGE; VAR DPROCNUM: BYTERANGE;
		   VAR OFFSET, DLNGTH: INTEGER;
		   VAR TPPROCINFO, TPLINKINFO: DMSCWP): BOOLEAN;
VAR JUNK: INTEGER;
BEGIN
  GETPARAMS := TRUE;
  DSEGNUM := SEGNUM;
  DPROCNUM := PROCNUM;
  OFFSET := -1;
  DLNGTH := LNGTH;
  TPPROCINFO := PPROCINFO;
  TPLINKINFO := PPROCINFO^.MSDYN;
  CLEARLINE(PROMPTLINE);
  WRITE(OUTPUT, 'Offset: ');
  IF INTREAD(OFFSET) THEN
      IF NOT EOLN(KEYBOARD) THEN
	BEGIN
	  WRITE(OUTPUT, '  Length: ');
	  IF INTREAD(DLNGTH) THEN
	    BEGIN
	      LNGTH := DLNGTH;
	      IF NOT EOLN(KEYBOARD) THEN
		BEGIN
		  WRITE(OUTPUT, '  Proc: ');
		  IF INTREAD(DPROCNUM) THEN
		    BEGIN
		      IF NOT EOLN(KEYBOARD) THEN
			BEGIN
			  WRITE(OUTPUT, '  Seg: ');
			  IF INTREAD(DSEGNUM) THEN;
			END;
		      IF NOT FINDPROC(DSEGNUM, DPROCNUM, PPROCINFO,
				      TPPROCINFO, TPLINKINFO, JUNK) THEN
			BEGIN
			  CLEARLINE(COMLINE);
			  WRITE(OUTPUT, 'Proc not found');
			  GETPARAMS := FALSE
			END
		    END
		END
	    END
	END
 END; (* GETPARAMS *)


PROCEDURE INITDEBUG;
VAR I: INTEGER;
    BUGTOSYS: RECORD CASE INTEGER OF
                0: (SYSDEBUG: ^INTEGER);
                1: (BUGDEBUG: ^BUGINFOREC)
              END;
BEGIN
  IF DEBUGINFO = NIL THEN  NEW(BUGDEBUGINFO);
  BUGTOSYS.BUGDEBUG := BUGDEBUGINFO;
  DEBUGINFO := BUGTOSYS.SYSDEBUG;
  FOR I := FIRSTDATALINE TO SYSCOM^.CRTINFO.HEIGHT-2 DO
    BUGDEBUGINFO^.SCREENINFO[I].LINETYPE := EMPTYLINE;
  BUGDEBUGINFO^.DATAPLACE := FIRSTDATALINE;
  BUGDEBUGINFO^.BUFFEREMPTY := TRUE;
  SYSCOM^.BUGSTATE := RUNNING;
  WRITELN(OUTPUT, 'PASCAL INTERACTIVE DEBUGGER - July 21, 1977');
END; (* INITDEBUG *)


PROCEDURE DISPLYSYSERROR;
VAR MSGNUM: INTEGER; MSG: STRING;
BEGIN
  MSGNUM := 0;
  PUTCURSOR(COMLINE, 0);
  CASE SYSCOM^.XEQERR OF
     1: MSG := 'INVALID INDEX - Subrange limits exceeded';
     3: MSG := 'Exitting from procedure never called';
     5: MSG := 'INTEGER OVERFLOW - ABS(<integer variable>) > maxint';
     6: MSG := 'DIVIDE BY ZERO'; 
     7: MSG := 'BAD MEMORY ADDRESS - Attempted access to a nil pointer';
     8: MSG := 'USER BREAK - Break character received';
     9: MSG := 'SYSTEM I/O ERROR';
    10: BEGIN
	       MSGNUM := ORD(SYSCOM^.IORSLT);
	       MSG := 'USER I/O ERROR - IORESULT =';
	       END;
    11: MSG := 'INTERPRETER ERROR - Instruction not implemented';
    12: MSG :=
'FLOATING POINT ERROR - Overflow, underflow, or divide by zero';
    13: MSG := 'STRING TOO LONG';
    14: MSG := 'USER BREAK POINT OR HALT - Unconditional HALT executed'
    END; (* CASE *)
  WRITE(OUTPUT, MSG);
  IF MSGNUM > 0 THEN WRITE(OUTPUT, MSGNUM);
END; (* DISPLYSYSERROR *)

PROCEDURE DISPLYMEM(WHAT: MEMTYPE; ADDR: INTEGER);
VAR I: INTEGER;  OUTSTRING: PACKED ARRAY [0..27] OF CHAR;
    TRICKSTUFF: MEMTYPE;  ADDRSTRING: PACKED ARRAY [0..8] OF CHAR;
BEGIN
  WITH TRICKSTUFF, OCTVAL DO
    BEGIN
      INTVAL := ADDR;
      FILLCHAR(ADDRSTRING, 3, ' ');
      ADDRSTRING[3+0] := CHR(FIRSTDIGIT+ORD0);
      ADDRSTRING[3+1] := CHR(FD0+ORD0);
      ADDRSTRING[3+2] := CHR(FD1+ORD0);
      ADDRSTRING[3+3] := CHR(FD2+ORD0);
      ADDRSTRING[3+4] := CHR(FD3+ORD0);
      ADDRSTRING[3+5] := CHR(FD4+ORD0);
    END;
  WITH WHAT DO
    BEGIN
      WRITE(OUTPUT, ADDRSTRING, INTVAL: 9);

      FILLCHAR(OUTSTRING, 28, ' ');
      WITH OCTVAL DO
	BEGIN
	  OUTSTRING[2+0] := CHR(FIRSTDIGIT+ORD0);
	  OUTSTRING[2+1] := CHR(FD0+ORD0);
	  OUTSTRING[2+2] := CHR(FD1+ORD0);
	  OUTSTRING[2+3] := CHR(FD2+ORD0);
	  OUTSTRING[2+4] := CHR(FD3+ORD0);
	  OUTSTRING[2+5] := CHR(FD4+ORD0);
	END;

      FOR I := HEXPERWORD DOWNTO 1 DO
	IF HEXVAL[I] < 10 THEN OUTSTRING[9+I] := CHR(HEXVAL[I]+ORD0)
	ELSE OUTSTRING[9+I] := CHR(HEXVAL[I]-10+ORD('A'));

      WITH BYTEOCTVAL DO
	BEGIN
	  OUTSTRING[15+1] := CHR(LD0+ORD0);
	  OUTSTRING[15+2] := CHR(LD1+ORD0);
	  OUTSTRING[15+3] := CHR(LD2+ORD0);
	  OUTSTRING[15+5] := CHR(HD0+ORD0);
	  OUTSTRING[15+6] := CHR(HD1+ORD0);
	  OUTSTRING[15+7] := CHR(HD2+ORD0);
	END;

      FOR I := 1 TO BYTESPERWORD DO
	IF CHARVAL[I] IN [' '..'~', ''..''] THEN
	  OUTSTRING[25+I] := CHARVAL[I]
	ELSE OUTSTRING[25+I] := SYSCOM^.CRTINFO.BADCH;

      WRITELN(OUTPUT, OUTSTRING);
    END
END; (* DISPLYMEM *)


PROCEDURE DISPLYHEADING;
BEGIN
  PUTCURSOR(HEADINGLINE, 0);
  WRITE(OUTPUT, 'TYPE     ID    PROC# OFFSET   ADDR   INTEGER');
  WRITE(OUTPUT, '   OCTAL   HEX   LO  HI  CHAR');
END; (* DISPLYHEADING *)


PROCEDURE DISPLYINFO;
VAR DATASZ, PARMSZ, STACKSZ, LL, IPC,
    PARENTNUM, PARENTLL, PARENTSEG,
    CALLER, CALLERLL, CALLSEG: INTEGER;
    TPPROCINFO, TPLINKINFO: DMSCWP;
BEGIN
  (* Info about current proc *)
  PROCNUM := PPROCINFO^.MSJTAB^[JTABPROCANDLL].BYTEVAL[LOBYTE];
  LL := PPROCINFO^.MSJTAB^[JTABPROCANDLL].BYTEVAL[HIBYTE];
  SEGNUM := PPROCINFO^.MSSEG^.BYTEVAL[LOBYTE];

  (* Info about parent *)
  TPLINKINFO := PLINKINFO^.MSSTAT;
  TPPROCINFO := PPROCINFO;
  WHILE TPPROCINFO^.MSDYN <> TPLINKINFO DO
    TPPROCINFO := TPPROCINFO^.MSDYN;
  PARENTNUM := TPPROCINFO^.MSJTAB^[JTABPROCANDLL].BYTEVAL[LOBYTE];
  PARENTLL := TPPROCINFO^.MSJTAB^[JTABPROCANDLL].BYTEVAL[HIBYTE];
  PARENTSEG := TPPROCINFO^.MSSEG^.BYTEVAL[LOBYTE];

  (* Info about caller *)
  CALLER := PLINKINFO^.MSJTAB^[JTABPROCANDLL].BYTEVAL[LOBYTE];
  CALLERLL := PLINKINFO^.MSJTAB^[JTABPROCANDLL].BYTEVAL[HIBYTE];
  CALLSEG := PLINKINFO^.MSSEG^.BYTEVAL[LOBYTE];

  (* More info on current proc *)
  STACKSZ := (ORD(PLINKINFO)-ORD(PPROCINFO^.MSSP)) DIV WORDSZ;
  DATASZ := (PPROCINFO^.MSJTAB^[JTABDATASZ].INTVAL) DIV BYTESPERWORD;
  PARMSZ := (PPROCINFO^.MSJTAB^[JTABPARMSZ].INTVAL) DIV BYTESPERWORD;
  IPC := PPROCINFO^.MSIPC - (ORD(PPROCINFO^.MSJTAB)+WORDSZ*JTABENTRIC
	 -PPROCINFO^.MSJTAB^[JTABENTRIC].INTVAL);
  PUTCURSOR(INFOLINE, 0);
  WRITELN(OUTPUT, 'PROC', PROCNUM: 4, '    CALLER', CALLER: 4, '    PARENT',
		PARENTNUM: 4, '    PARAM', PARMSZ: 4, '    DATA',
		DATASZ: 6);
  WRITELN(OUTPUT, ' SEG', SEGNUM: 4, '       SEG', CALLSEG: 4, '       SEG',
	       PARENTSEG: 4, '    STACK', STACKSZ: 4, '    IPC', IPC: 6,
	       '    DEPTH', LINKLEVEL: 3);
  WRITE(OUTPUT, '  LL', LL: 4, '        LL', CALLERLL: 4, '        LL',
	       PARENTLL: 4, '    DEFAULTLINK = ');
  PUTCURSOR(INFOLINE+2, LINKCOLUMN);
  IF LINKDEFAULT = DYNAMIC THEN WRITE(OUTPUT, 'DYNAMIC')
			   ELSE WRITE(OUTPUT, 'STATIC');
END; (* DISPLYINFO *)


PROCEDURE UPDATE;
VAR I, JUNK: INTEGER;
    TRICKSTUFF: MEMTYPE;
    TPPROCINFO, TPLINKINFO: DMSCWP;
BEGIN
  CLEARSCREEN;
  DISPLYSYSERROR;
  DISPLYINFO;
  DISPLYHEADING;
  PUTCURSOR(FIRSTDATALINE, 0);
  FOR I := FIRSTDATALINE TO LASTDATALINE DO
    WITH BUGDEBUGINFO^.SCREENINFO[I] DO
      BEGIN
	CASE LINETYPE OF
	    EMPTYLINE: WRITELN(OUTPUT);
	     DATALINE:  BEGIN
			  WRITE(OUTPUT, 'Data', PROC: 15, DISP: 7);
			  IF FINDPROC(SEG, PROC, PPROCINFO, TPPROCINFO,
				      TPLINKINFO, JUNK) THEN
			    DISPLYMEM(TPLINKINFO^.MSDATA[DISP],
				      ORD(TPLINKINFO)+DELTAMSCW
				      +(DISP-DATAOFFSET)*WORDSZ)
			  ELSE WRITELN(OUTPUT, '     Proc not found')
			END;
	    STACKLINE:  BEGIN
			  WRITE(OUTPUT, 'Stack', PROC: 14, DISP: 7);
			  IF FINDPROC(SEG, PROC, PPROCINFO, TPPROCINFO,
				      TPLINKINFO, JUNK) THEN
			    DISPLYMEM(TPPROCINFO^.MSSP^[DISP],
				      ORD(TPPROCINFO^.MSSP)+DISP*WORDSZ)
			  ELSE WRITELN(OUTPUT, '    Proc not found')
			END;
	  POINTERLINE:  BEGIN
			  WRITE(OUTPUT, 'Pntr', ' ': 22);
			  TRICKSTUFF.INTVAL := HEAPPOINTER;
			  DISPLYMEM(TRICKSTUFF.PTVAL^, HEAPPOINTER)
			END
	  END; (*CASE*)
      END; (*WITH*)
END; (*UPDATE*)


PROCEDURE DISPLYSTEPPINGINFO;
BEGIN
  UPDATE;
END;(* DISPLYSTEPPINGINFO *)

PROCEDURE DOEXAMINING;
VAR
  ENDCOMMAND: BOOLEAN;
  CH: CHAR;

  PROCEDURE TRAVERSELINKS(LINK: LINKTYPE; NLINKS: INTEGER;
			  DIRECTION: DIRECTYPE);
  BEGIN
    IF LINKDEFAULT = STATIC THEN
      IF DIRECTION = DOWN THEN
	BEGIN
	  CLEARLINE(COMLINE);
	  WRITE(OUTPUT,'Can only traverse UP Static links');
	END
      ELSE
	BEGIN (* So lets travel up the static links *)
	  WHILE (NLINKS>0) AND (PLINKINFO^.MSDYN<>PLINKINFO) DO
	    BEGIN
	      NLINKS := NLINKS-1;
	      PLINKINFO := PLINKINFO^.MSSTAT;
	    END;
	  IF PLINKINFO^.MSDYN = PLINKINFO THEN
	    BEGIN
	      CLEARLINE(COMLINE);
	      WRITE(OUTPUT,'Top of link chain');
	    END;
	  LINKLEVEL := 0;
	  PPROCINFO := JEXERRP;
	  WHILE PPROCINFO^.MSDYN <> PLINKINFO DO
	    BEGIN
	      PPROCINFO := PPROCINFO^.MSDYN;
	      LINKLEVEL := LINKLEVEL+1;
	    END;
	END (* of traveling up the Static links *)
    ELSE
      IF DIRECTION = DOWN THEN
	BEGIN  (* traveling down the Dynamic links *)
	  PPROCINFO := JEXERRP;
	  PLINKINFO := PPROCINFO^.MSDYN;
	  NLINKS := LINKLEVEL-NLINKS;
	  LINKLEVEL := 0;
	  IF NLINKS<=0 THEN
	    BEGIN
	      CLEARLINE(COMLINE);
	      WRITE(OUTPUT,'Bottom of link chain');
	    END
	  ELSE
	    TRAVERSELINKS(DYNAMIC, NLINKS, UP); (* We have now made it
		    look like it is going up the Dynamic links *)
	END  (*of going down the Dynamic links *)
      ELSE
	BEGIN  (* going up the Dynamic links *)
	  WHILE (NLINKS>0) AND (PLINKINFO^.MSDYN<>PLINKINFO) DO
	    BEGIN
	      LINKLEVEL := LINKLEVEL+1;
	      NLINKS := NLINKS-1;
	      PPROCINFO := PLINKINFO;
	      PLINKINFO := PPROCINFO^.MSDYN;
	    END;
	  IF PLINKINFO^.MSDYN = PLINKINFO THEN
	    BEGIN
	      CLEARLINE(COMLINE);
	      WRITE(OUTPUT, 'Top of link chain');
	    END;
	END; (*of traveling up the dynamic links *)
  END;(*TRAVERSELINKS*)


  PROCEDURE COMD;
  VAR DSEG, DPROC, OFFSET, LEN,
      DATANDPARMSZ, I, LINE: INTEGER;
      TPPROCINFO, TPLINKINFO: DMSCWP;
  BEGIN
    IF GETPARAMS (DSEG, DPROC, OFFSET, LEN, TPPROCINFO, TPLINKINFO) THEN
      BEGIN
	DATANDPARMSZ := (TPPROCINFO^.MSJTAB^[JTABDATASZ].INTVAL
			 + TPPROCINFO^.MSJTAB^[JTABPARMSZ].INTVAL)
			 DIV BYTESPERWORD;
	IF OFFSET = -1 THEN OFFSET := DATOFF;
	DATOFF := OFFSET + LEN;
	IF OFFSET-DATAOFFSET+1 > DATANDPARMSZ THEN
	  BEGIN
	    CLEARLINE(COMLINE);
	    WRITE(OUTPUT, 'Warning - offset too large');
	  END
	ELSE
	  IF OFFSET-DATAOFFSET+LEN > DATANDPARMSZ THEN
	    BEGIN
	      CLEARLINE(COMLINE);
	      WRITE(OUTPUT, 'Warning - length too large');
	    END;
      BUGDEBUGINFO^.BUFFEREMPTY := FALSE;
	LINE := BUGDEBUGINFO^.DATAPLACE;
	PUTCURSOR(LINE, 0);
	FOR I := OFFSET TO DATOFF-1 DO
	  WITH BUGDEBUGINFO^.SCREENINFO[LINE] DO
	    BEGIN
	      LINETYPE := DATALINE;
	      SEG := DSEG;
	      PROC := DPROC;
	      DISP := I;
	      WRITE(OUTPUT, 'Data', DPROC: 15, I: 7);
	      DISPLYMEM(TPLINKINFO^.MSDATA[I],
			ORD(TPLINKINFO)+DELTAMSCW+(I-DATAOFFSET)*WORDSZ);
	      IF LINE=LASTDATALINE THEN
		BEGIN LINE := FIRSTDATALINE; PUTCURSOR(LINE, 0) END
	      ELSE LINE := LINE + 1;
	    END;
	BUGDEBUGINFO^.DATAPLACE := LINE;
    END
  END; (* PROCEDURE COMD *)


  PROCEDURE COMS;
  VAR DSEG, DPROC, OFFSET, LEN,
      STACKSZ, I, LINE: INTEGER;
      TPPROCINFO, TPLINKINFO: DMSCWP;
  BEGIN
    IF GETPARAMS (DSEG, DPROC, OFFSET, LEN, TPPROCINFO, TPLINKINFO) THEN
      BEGIN
	STACKSZ := (ORD(TPLINKINFO) - ORD(TPPROCINFO^.MSSP)) DIV WORDSZ;
	IF OFFSET = -1 THEN OFFSET := STOFF;
	STOFF := OFFSET + LEN;
	IF OFFSET + 1 > STACKSZ THEN
	  BEGIN
	    CLEARLINE(COMLINE);
	    WRITE(OUTPUT, 'Warning - offset too large');
	  END
	ELSE
	  IF OFFSET + LEN > STACKSZ THEN
	    BEGIN
	      CLEARLINE(COMLINE);
	      WRITE(OUTPUT, 'Warning - length too large');
	    END;
	BUGDEBUGINFO^.BUFFEREMPTY := FALSE;
	LINE := BUGDEBUGINFO^.DATAPLACE;
	PUTCURSOR(LINE, 0);
	FOR I := OFFSET TO STOFF-1 DO
	  WITH BUGDEBUGINFO^.SCREENINFO[LINE] DO
	    BEGIN
	      LINETYPE := STACKLINE;
	      SEG := DSEG;
	      PROC := DPROC;
	      DISP := I;
	      WRITE(OUTPUT, 'Stack', DPROC:  14, I: 7);
	      DISPLYMEM(TPPROCINFO^.MSSP^[I], ORD(TPPROCINFO^.MSSP)+I*WORDSZ);
	      IF LINE = LASTDATALINE THEN
		BEGIN LINE := FIRSTDATALINE; PUTCURSOR(FIRSTDATALINE, 0) END
		ELSE LINE := LINE + 1;
	    END;
	BUGDEBUGINFO^.DATAPLACE := LINE;
    END
  END; (* PROCEDURE COMS *)


  PROCEDURE COMT;
  BEGIN
  END; (*COMT*)


  PROCEDURE COMB;
  BEGIN
  END; (*COMB*)


  PROCEDURE COME;
  VAR I: INTEGER;
  BEGIN
    BUGDEBUGINFO^.BUFFEREMPTY := TRUE;
    PUTCURSOR(FIRSTDATALINE, 0);
    FOR I := FIRSTDATALINE TO LASTDATALINE DO
      BEGIN  BUGDEBUGINFO^.SCREENINFO[I].LINETYPE := EMPTYLINE;  CLEARTHISLINE END;
    BUGDEBUGINFO^.DATAPLACE := FIRSTDATALINE;
  END; (* COME *)


  PROCEDURE COMH;
    BEGIN END;


  PROCEDURE MOVETOPROC;
  VAR PROC, SEG, LEVELS: INTEGER;
      CH: CHAR;
      TPLINKINFO, TPPROCINFO: DMSCWP;
  BEGIN
    SEG := SEGNUM;
    CLEARLINE(PROMPTLINE);
    WRITE(OUTPUT, 'Proc: ');
    IF NOT INTREAD(PROC) THEN
      BEGIN
	PPROCINFO := JEXERRP;
	PLINKINFO := PPROCINFO^.MSDYN;
	LINKLEVEL := 0;
	DISPLYINFO
      END
    ELSE
      BEGIN
	IF NOT EOLN(KEYBOARD) THEN
	  BEGIN
	    WRITE(OUTPUT, '  Seg: ');
	    IF INTREAD(SEG) THEN;
	  END;
	IF FINDPROC(SEG, PROC, PLINKINFO, TPPROCINFO, TPLINKINFO, LEVELS) THEN
	  BEGIN
	    LINKLEVEL := LINKLEVEL + LEVELS +1;
	    PPROCINFO := TPPROCINFO;
	    PLINKINFO := TPLINKINFO;
	    DISPLYINFO
	  END
	ELSE
	  BEGIN  CLEARLINE(COMLINE); WRITE(OUTPUT, 'Proc not found')  END;
      END;
  END;(*MOVETOPROC*)


  PROCEDURE INITEXAMINE;
VAR CH: CHAR;
  BEGIN
    SYSCOM^.BUGSTATE := EXAMINING;
    DIRECTION := UP;
    STOFF := 0;
    LNGTH := LASTDATALINE-FIRSTDATALINE+1;
    ENDCOMMAND := FALSE;
    WRITE(OUTPUT, 'Hit [space] when ready'); CH := GETCHAR(TRUE);
    UPDATE;
  END; (* INITEXAMINE *)

BEGIN (* DOEXAMINING *)
  INITEXAMINE;
  REPEAT
    CLEARLINE(PROMPTLINE);
    IF DIRECTION = DOWN THEN WRITE(OUTPUT, '<') ELSE WRITE(OUTPUT, '>');
    WRITELN(OUTPUT,
'EXAMINE: # links, <esc>, L(ink, D(ata, S(tack, M(ove, R(esume, C(rawl, W(alk');
    WRITE(OUTPUT,
'U(pdate, E(rase, <, >, H(eap ');
    CH := GETCHAR(FALSE);
    CLEARLINE(COMLINE);
    IF CH IN  ['<', '>', ',', '.', '0'..'9',
	       'B', 'C', 'D', 'E', 'H', 'L',
	       'M', 'R', 'S', 'T', 'U'] THEN
      CASE CH OF
      '>', '.': DIRECTION := UP;
      '<', ',': DIRECTION := DOWN;
	'0','1','2','3','4','5','6','7','8','9':
		BEGIN
		  TRAVERSELINKS(LINKDEFAULT,ORD(CH)-ORD0,DIRECTION);
		  DISPLYINFO;
		END;
	   'L':  BEGIN
		   PUTCURSOR(INFOLINE+2, LINKCOLUMN);
		   IF LINKDEFAULT = DYNAMIC THEN
		     BEGIN
		       LINKDEFAULT := STATIC;
		       WRITE(OUTPUT, 'STATIC ')
		     END
		   ELSE
		     BEGIN
		       LINKDEFAULT := DYNAMIC;
		       WRITE(OUTPUT, 'DYNAMIC')
		     END;
		 END;
	   'D': COMD;
	   'H': COMH;
	   'S': COMS;
	   'T': COMT;
	   'W': BEGIN
		  SYSCOM^.BUGSTATE := WALKING;
		  ENDCOMMAND := TRUE;
		END;
	   'C':  BEGIN
		   SYSCOM^.BUGSTATE := CRAWLING;
		   ENDCOMMAND := TRUE;
		 END;
	   'B': COMB;
	   'U': UPDATE;(*  Display *)
	   'R': BEGIN
		  SYSCOM^.BUGSTATE := RUNNING;
		  ENDCOMMAND:=TRUE;(* Resume Program *)
		END;
	   'M': MOVETOPROC;
	   'E': COME  (* Erase *)
      END (*CASE*)
    ELSE
      IF ORD(CH)  = ORDALT THEN  BEGIN CLEARSCREEN;  EXIT(USERPROGRAM) END
      ELSE
	IF EOLN(KEYBOARD) THEN
	  WITH BUGDEBUGINFO^ DO
	    BEGIN
	      CLEARLINE(DATAPLACE);
	      IF DATAPLACE = LASTDATALINE THEN DATAPLACE := FIRSTDATALINE
	      ELSE DATAPLACE := DATAPLACE + 1;
	    END
	ELSE BEGIN PUTCURSOR(COMLINE, 0); WRITE(OUTPUT, 'Not a command')  END;
  UNTIL ENDCOMMAND;
  CLEARSCREEN;
END; (* DOEXAMINE *)


PROCEDURE HANDLESTEPPING;
BEGIN
  IF SYSCOM^.XEQERR = 14 THEN  (* A HALT WAS EXECUTED *)
    DISPLYSTEPPINGINFO
  ELSE
    DOEXAMINING;
END;

PROCEDURE INITIALIZE;
VAR SYSTOBUG: RECORD CASE INTEGER OF
		0: (SYSMSCWP: MSCWP);
		1: (BUGMSCWP: DMSCWP);
  2: (SYSDEBUGINFO: ^INTEGER);
  3: (BUGDEBUGINFO: ^BUGINFOREC)
	      END; (* OLD TO NEW POINTER CONVERSION *)
    I, SIZE, DPROC, DSEG: INTEGER;
BEGIN
  DIGITSET := ['0'..'9'];
  SYSTOBUG.SYSMSCWP := SYSCOM^.BOMBP;
  JEXERRP := SYSTOBUG.BUGMSCWP;
  SYSTOBUG.SYSDEBUGINFO := DEBUGINFO;
  BUGDEBUGINFO := SYSTOBUG.BUGDEBUGINFO;
  PPROCINFO := JEXERRP;
  PLINKINFO := PPROCINFO^.MSDYN;
  LINKLEVEL := 0;
  LINKDEFAULT := DYNAMIC;

  COMLINE := SYSCOM^.CRTINFO.HEIGHT-1;
  LASTDATALINE := COMLINE-1;
  DATOFF := FIRSTDATAOFFSET;
  DOWNCHARS[0] := CHR(31);  ACROSSCHARS[0] := CHR(79); (* SET STRING LENGTHS *)
  FILLCHAR(DOWNCHARS[1], 31, CHR(10));
  FILLCHAR(ACROSSCHARS[1], 79, SYSCOM^.CRTCTRL.NDFS);

  IF BUGDEBUGINFO^.BUFFEREMPTY THEN
    BEGIN
      DPROC := PPROCINFO^.MSJTAB^[JTABPROCANDLL].BYTEVAL[LOBYTE];
      DSEG := PPROCINFO^.MSSEG^.BYTEVAL[LOBYTE];
      SIZE := (PPROCINFO^.MSJTAB^[JTABDATASZ].INTVAL
	       +PPROCINFO^.MSJTAB^[JTABPARMSZ].INTVAL) DIV BYTESPERWORD;
      IF SIZE > LASTDATALINE-FIRSTDATALINE+1 THEN
	SIZE := LASTDATALINE-FIRSTDATALINE+1;
      DATOFF := SIZE+DATAOFFSET;
      BUGDEBUGINFO^.DATAPLACE := FIRSTDATALINE+SIZE;
      IF BUGDEBUGINFO^.DATAPLACE>LASTDATALINE THEN
	BUGDEBUGINFO^.DATAPLACE := FIRSTDATALINE;
      FOR I := 0 TO SIZE-1 DO
	WITH BUGDEBUGINFO^.SCREENINFO[I+FIRSTDATALINE] DO
	  BEGIN
	    LINETYPE := DATALINE;
	    PROC := DPROC;
	    SEG := DSEG;
	    DISP := I+DATAOFFSET;
	  END;
      FOR I := SIZE+FIRSTDATALINE TO LASTDATALINE DO
	BUGDEBUGINFO^.SCREENINFO[I].LINETYPE := EMPTYLINE;
    END;
END; (* INITIALIZE *)

BEGIN (*SEGMENT PROCEDURE DEBUGGER *)
  IF SYSCOM^.BUGSTATE = ASLEEP THEN (*Lets wake up *)
    BEGIN
      INITDEBUG;
      EXECUTE(TRUE);
      SYSCOM^.BUGSTATE := ASLEEP
    END
  ELSE
    BEGIN
      INITIALIZE;
      IF SYSCOM^.XEQERR = 8 THEN (* he hit a break *)
	  CASE SYSCOM^.BUGSTATE OF
	    EXAMINING: BEGIN
			 CLEARLINE(COMLINE);
			 WRITE(OUTPUT,
'The <brk> key does not accomplish anything while in EXAMINE mode');
		       END;
	    CRAWLING, WALKING, RUNNING: DOEXAMINING
	  END (* CASE *)
      ELSE
	IF SYSCOM^.BUGSTATE = EXAMINING THEN ERRORINDEBUGGER
	ELSE
	    CASE SYSCOM^.BUGSTATE OF
	      CRAWLING: BEGIN
			  HANDLESTEPPING;
			  SPACEWAIT;
			END;
	       WALKING: HANDLESTEPPING;
	       RUNNING: DOEXAMING
	    END; (* CASE *)
      CLEARSCREEN;
    END; (* IF *)
END; (* SEGMENT PROCEDURE DEBUGGER *)



BEGIN (* PASCAL SYSTEM *) END.

========================================================================================
DOCUMENT :usus Folder:VOL18:intrinsics.text
========================================================================================

  program benchusus;
  (* a benchmark of system intrinsics using the structure of
     bench.usus from volume 12   - gws *)
  
  (* If you have a real time clock, the program will time itself.  If you
     don't, than don't fret, just get a stopwatch.  The timer code will 
     detect the lack of a clock and not do anything.  *)
     
  var
    i, j, k, l, test : integer;
    starth,startl,endh,endl : integer;
    num_loops : integer;
    arg, result,overhead,t,s,e : real;
    fudge_loop : boolean;
    
    procedure prompt;
      procedure prompt1; { too big for 1200 bytes otherwise... }
        var line:integer;
        begin
        gotoxy(0,23);
        for line:=1 to 24 do writeln;
        gotoxy(0,0);
        writeln('Select a test or enter "0" for all tests.');
        writeln('Enter a negative number to quit.');
        writeln;
        end;
      begin
      prompt1;
      writeln(' 1. null for loops (to).           2. sin');
      writeln(' 3. cos                            4. exp');
      writeln(' 5. atan                           6. ln');
      writeln(' 7. log                            8. pwroften');
      writeln(' 9. trunc                         10. round');
      writeln('11. fillchar a small array        12. fillchar a large array');
      writeln('13. moveleft a small array        14. moveleft a large array');
      writeln('15. scan a small array            16. scan a large array');
      writeln('17. sizeof');
      writeln;
      write('Test number ? ');
      end; { prompt }
      
  procedure doneit;
  
  
  begin
    writeln( chr ( 7 ), 'Done.');
    s:=ABS(startl);
    e:=ABS(endl);
    t:=ABS(e-s)/60;
    if t <> 0.0 then 
      begin
         write('Time = ',t:5:2,' seconds  ' );
         if fudge_loop then  
         writeln ((((t/numloops ) * 1000 ) - ( overhead )):7:3,' ms per loop ')
         else writeln ((( t/numloops ) * 1000 ):7:3, ' ms per loop' );
      end;
  end;

  procedure test1;
    begin
    fudge_loop := false;
    write('1 . ',numloops,' null for loops (to).');
    time(starth,startl);
    for i := 1 to num_loops do begin end;
    time(endh,endl);
    doneit;
    end;
  
  procedure test2;
    begin
    arg := 45.0;
    fudge_loop := true;
    write('2 . ',numloops,' sin.');
    time(starth,startl);
    for i := 1 to num_loops do begin result := sin ( arg ) end;
    time(endh,endl);
    doneit;
    end;

  procedure test3;
    begin
    fudge_loop := true;
    arg := 45.0;
    write('3 . ',numloops,' cos.');
    time(starth,startl);
    for i := 1 to num_loops do begin result := cos ( arg ) end;
    time(endh,endl);
    doneit;
    end;


procedure test4;
    begin
    fudge_loop := true;
    arg := 3.14159;
    write('4 . ',numloops,' exp.');
    time(starth,startl);
    for i := 1 to num_loops do begin result := exp ( arg ); end;
    time(endh,endl);
    doneit;
    end;

procedure test5;
    begin
    fudge_loop := true;
    arg := 0.0;
    write('5 . ',numloops,' atan' );
    time(starth,startl);
    for i := 1 to num_loops do begin result := atan ( arg ) end;
    time(endh,endl);
    doneit;
    end;

procedure test6;
    begin
    fudge_loop := true;
    arg := 5.0;
    write('6 . ',numloops,' ln.');
    time(starth,startl);
    for i := 1 to num_loops do begin result := ln ( arg ) end;
    time(endh,endl);
    doneit;
    end;

procedure test7;
    begin
    fudge_loop := true;
    arg := 5.0;
    write('7 . ',numloops,' log.');
    time(starth,startl);
    for i := 1 to num_loops do begin result := log ( arg ) end;
    time(endh,endl);
    doneit;
    end;

procedure test8;
    begin
    fudge_loop := true;
    l := 5;
    write('8 . ',numloops,' pwroften.');
    time(starth,startl);
    for i := 1 to num_loops do begin result := pwroften ( l ) end;
    time(endh,endl);
    doneit;
    end;

procedure test9;
    begin
    fudge_loop := true;
    arg := 5.6;
    write('9 . ',numloops,' trunc.');
    time(starth,startl);
    for i := 1 to num_loops do begin j := trunc ( arg ) end;
    time(endh,endl);
    doneit;
    end;

procedure test10;
    begin
    fudge_loop := true;
    arg := 5.6;
    write('10. ',numloops,' round.');
    time(starth,startl);
    for i := 1 to num_loops do begin j := round ( arg ) end;
    time(endh,endl);
    doneit;
    end;

procedure test11;
var ary : packed array [ 0..1 ] of char;
    begin
    fudge_loop := true;
    write('11. ',numloops,' fillchar a small array.');
    time(starth,startl);
    for i := 1 to num_loops do begin 
                             fillchar ( ary, sizeof ( ary ), chr ( 0 ) ) end;
    time(endh,endl);
    doneit;
    end;
  
procedure test12;
var ary : packed array [ 0..10000 ] of char;
    begin
    fudge_loop := true;
    write('12. ',numloops,' fillchar a large array.');
    time(starth,startl);
    for i := 1 to num_loops do begin 
                             fillchar ( ary, sizeof ( ary ), chr ( 0 ) ) end;
    time(endh,endl);
    doneit;
    end;
  
  procedure test13;
    var ary,ary1 : packed array [ 0..1 ] of char;
    begin
    fudge_loop := true;
    write('13. ',numloops,' moveleft a small array.');
    time(starth,startl);
    for i := 1 to num_loops do begin 
                             moveleft ( ary, ary1, sizeof ( ary ) ) end;
    time(endh,endl);
    doneit;
    end;
  
  procedure test14;
    var ary,ary1 : packed array [ 0..10000 ] of char;
    begin
    fudge_loop := true;
    write('14. ',numloops,' moveleft a large array.');
    time(starth,startl);
    for i := 1 to num_loops do begin 
                             moveleft ( ary, ary1, sizeof ( ary ) ) end;
    time(endh,endl);
    doneit;
    end;
  
  procedure test15;
    var ary : packed array [ 0..1 ] of char;
        j : integer;
    begin
    fillchar ( ary, sizeof ( ary ), chr ( 0 ) );
    fudge_loop := true;
    write('15. ',numloops,' scan a small array');
    time(starth,startl);
    for i := 1 to num_loops do begin 
                           j := scan ( sizeof ( ary ), =chr(1), ary ) end;
    time(endh,endl);
    doneit;
    end;
  
  procedure test16;
    var ary : packed array [ 0..10000 ] of char;
        j : integer;
    begin
    fillchar ( ary, sizeof ( ary ), chr ( 0 ) );
    fudge_loop := true;
    write('16. ',numloops,' scan a large array');
    time(starth,startl);
    for i := 1 to num_loops do begin 
                           j := scan ( sizeof ( ary ), =chr(1), ary ) end;
    time(endh,endl);
    doneit;
    end;
  
  procedure test17;
    var ary : packed array [ 0..10000 ] of char;
        j : integer;
    begin
    fudge_loop := true;
    write('17. ',numloops,' sizeofs.');
    time(starth,startl);
    for i := 1 to num_loops do begin j := sizeof ( ary ) end;
    time(endh,endl);
    doneit;
    end;
  
  
  
  begin { main }
  writeln ( 'initializing ... ' );
  numloops := 10000;
  test1;
  s:=ABS(startl);
  e:=ABS(endl);
  t:=ABS(e-s)/60;
  overhead := ( t/numloops ) * 1000;
  writeln;
  write('Enter number of loops per test : ');
  readln(num_loops);
  repeat
    prompt; 
    readln(test);
    if (test >= 0) then 
      case test of
          0 : begin
              test1; test2; test3; test4; test5; test6; test7; test8;
              test9; test10; test11; test12; test13; test14; test15; test16;
              test17;
              end;
          1 : test1;  
          2 : test2; 
          3 : test3; 
          4 : test4;
          5 : test5; 
          6 : test6; 
          7 : test7; 
          8 : test8;
          9 : test9; 
         10 : test10; 
         11 : test11;
         12 : test12;
         13 : test13;
         14 : test14;
         15 : test15;
         16 : test16;
         17 : test17;
        end;
        if test>=0 then
          begin
            write('Type <return> to continue');
            readln;
          end;
    until (test < 0);
  end.



========================================================================================
DOCUMENT :usus Folder:VOL18:life.inc.text
========================================================================================

procedure write_prompt(prompt:string);
begin      
  gotoxy(2,0);            
  clear_line;
  write(prompt,' ',copy(border,1,76-length(prompt)),'+');
  gotoxy(length(prompt)+2,0)
end {write_prompt};  

function read_int(low_lim,hi_lim,digits_allowed:integer):integer;  
var
  ch:char;
  result,digits,i:integer;
  ok:boolean;
begin  
  ok:=FALSE; 
  repeat
    result := 0; digits := 0;
    repeat         
      read(keyboard,ch);                  
      while not(ch in ['0'..'9',chr(SP),chr(BS)]) do read(keyboard,ch);    
      if ch=chr(BS)
        then begin 
          if digits>0
            then begin  {erase last character}
              write(chr(BS),chr(SP),chr(BS));         
              result := result div 10;
              digits := digits-1
              end
          end
        else if ch<>chr(SP)
          then if digits<digits_allowed 
            then begin  {accept a digit}
              write(ch);
              result := result*10+ord(ch)-ord('0'); 
              digits := digits+1
              end
      until ch=chr(SP); 
    if (low_lim<=result) and (result<=hi_lim)
      then begin  {result in acceptable range}
        read_int := result;
        ok := TRUE
        end
      else  {result not in range - start over}
        for i:=1 to digits do write(chr(BS),chr(SP),chr(BS));
    until ok
end {read_int};
      
      procedure dummy;
      begin
      writeln('To set pattern:'); 
      writeln('  Cursor movement commands: left, right, up, down');
      writeln('    Plain, i.e. lower case: writes and then moves');  
      writeln('    Caps, i.e. upper case: erases and then moves');      
      writeln('    CNTL, i.e. with CONTROL key held: just moves');
      writeln('  Cursor movement command: CR');
      writeln('    Moves to beginning of next line');
      writeln('  All cursor movement is performed with full wraparound');
      writeln('  ESC - Aborts');          
      writeln('  ETX - Accepts initial pattern as displayed.');     
      writeln;     
      end;
              
procedure print_intro; 
begin              
  clear_screen;                  
  gotoxy(32,0);
  writeln('THE GAME OF LIFE');
  write('Do you want instructions? (''y'' or ''n''):');            
  read(ch);
  if (ch='y') or (ch='Y')
    then begin
      gotoxy(0,1); clear_line;
      writeln('....more stuff about the game....');    
      writeln('Options available during game:');
      writeln('  n(ext - display next generation according to i(nterval');
      writeln('  r(un - repeatedly display generations according to ',      
              'i(nterval');
      writeln('         When ''run''ning, hit any key to stop');  
      writeln('  i(nterval - set number of generations to compute ',
              'between displays');
      writeln('  c(hange - change pattern');  
      writeln('  s(ave - save (part of) pattern in a file');
      writeln('    File name is suffixed ''.LIFE''');
      writeln('  g(et - get (part of) pattern from a file');             
      writeln('  ESC - quit'); 
      writeln;
      writeln;
      dummy;
      write('Type anything to begin entering initial pattern:');         
      read(ch)             
      end
end {print_intro};  


========================================================================================
DOCUMENT :usus Folder:VOL18:life.text
========================================================================================

{12:09 6 Jun 81}                       
program life;
const
  maxx=79; maxy=23; middlex=39; middley=11;
  screen_char='*';
  prompt='n(ext r(un i(nterval c(hange s(ave g(et (ESC quits):';
  border=
'---------------------------------------------------------------------------';
  ESC=27; FF=12; BS=8; SP=32; CR=13; ETX=3;
  LT=1; RT=19; UP=23; DN=26;
  WRITE_LT=97; WRITE_RT=115; WRITE_UP=119; WRITE_DN=122;
  ERASE_LT=65; ERASE_RT=83; ERASE_UP=87; ERASE_DN=90;
type
  row=0..maxy;
  col=0..maxx;
var
  alive,prev_alive:array[col,row] of boolean;
  cur_neighbors,next_neighbors:array[col,row] of 0..8;
  i,population,generation:integer;
  interval:1..99;
  x:col;
  y:row;
  ch:char;
  zeros: array[col,row] of integer;
  life_file:file of char;
   

procedure clear_line;
begin 
  write(chr(ESC),'K')  {H-19 specific}
  end {clear_line};
  
procedure clear_screen;
begin
  gotoxy ( 0, 0 );
  write ( chr (  ESC ) , chr ( 69 ) ); {H-19 specific}
  end {clear_screen};
  
(*$I life.inc.text*)

procedure set_cell(x:col; y:row; live:boolean);   
var
  amnt:integer;
begin  
  if live   
    then begin
      write(screen_char);
      amnt := 1  
      end
    else begin
      write(' ');
      amnt := -1
      end;     
  if live<>alive[x,y]   
    then begin  {change cell at x,y}
      alive[x,y] := live; 
      population := population+amnt;  
      cur_neighbors[x-1,y-1]:=cur_neighbors[x-1,y-1]+amnt;     
      cur_neighbors[x-1,y]:=cur_neighbors[x-1,y]+amnt;
      cur_neighbors[x-1,y+1]:=cur_neighbors[x-1,y+1]+amnt;  
      cur_neighbors[x,y-1]:=cur_neighbors[x,y-1]+amnt;
      cur_neighbors[x,y+1]:=cur_neighbors[x,y+1]+amnt;        
      cur_neighbors[x+1,y-1]:=cur_neighbors[x+1,y-1]+amnt;
      cur_neighbors[x+1,y]:=cur_neighbors[x+1,y]+amnt;
      cur_neighbors[x+1,y+1]:=cur_neighbors[x+1,y+1]+amnt
      end  {change cell at x,y} 
end {set_cell}; 

procedure change_pattern;  
const 
  change_prompt=  
'arrows (plain writes, caps erases, CNTL moves) CR (ESC aborts, ETX accepts)';
var       
  x:col; y:row;      
begin {change_pattern} 
  write_prompt(change_prompt);      
  x := middlex; y := middley; gotoxy(x,y);   
  repeat
    read(keyboard,ch);
    if EOF(keyboard)
      then ch := chr(ETX)      
      else if EOLN(keyboard) then ch := chr(CR);     
    if ord(ch) in [ESC,ETX,RT,LT,UP,DN,WRITE_RT,WRITE_LT,WRITE_UP,WRITE_DN,
                   ERASE_RT,ERASE_LT,ERASE_UP,ERASE_DN,CR]   
      then begin
        if ch>='a' 
          then begin {write}
            set_cell(x,y,TRUE);  
            gotoxy(36,23); write(population:4);
            ch := chr(ord(ch)-ord('a')+1)  
            end {write}
          else if ch>='A' 
            then begin {erase}
              set_cell(x,y,FALSE);  
              gotoxy(36,23); write(population:4);       
              ch := chr(ord(ch)-ord('A')+1)
              end {erase};
        case ord(ch) of 
          ESC: exit(change_pattern);        
          ETX: ;
          RT: x := x+1;
          LT: x := x-1; 
          UP: y := y-1;
          DN: y := y+1;
          CR: begin y := y+1; x := 1 end;
          end {case};
    
        {perform wraparound} 
        if x=0 then begin x := 78; y := y-1 end      
                else if x=79 then begin x := 1; y := y+1 end;
        if y=0 then y := 22
                else if y=23 then y :=1;
        
        {move cursor}    
        gotoxy(x,y)
    
        end
    
    until ord(ch)=ETX; 
     
  {set up regular prompt}
  write_prompt(prompt);
  
  {set ch to indicate we just did a "change_pattern"} 
  ch := 'c'     
end {change_pattern}; 
              
function key_pressed:boolean;          
var status_rec : array [ 1..30 ] of integer;
begin
   unitstatus ( 2, status_rec, 1 );
   key_pressed := status_rec [ 1 ] > 0;
end {key_pressed};

function read_title(var title:string):boolean; 
var
  ch:char;
  chstr:string[1];
begin
  chstr := ' ';
  title := '';
  repeat 
    read(keyboard,ch);
    if ord(ch)=BS
      then begin
        if length(title)>0
          then begin {erase last character}
            write(chr(BS),chr(SP),chr(BS));
            delete(title,length(title),1)
            end {erase last character} 
        end
      else if not (ord(ch) in [ESC,SP])
        then begin {add character to title}
          write(ch);
          if (ch>='a') and (ch<='z')   
            then ch := chr(ord(ch)+ord('A')-ord('a'));  
          chstr[1] := ch;
          title := concat(title,chstr)    
          end {add character to title}   
    until (ord(ch) in [ESC,SP]);
  read_title := ord(ch)=SP;
  if ord(ch)=SP  
    then if length(title)<5  
      then title := concat(title,'.LIFE')
      else if copy(title,length(title)-4,5)<>'.LIFE'   
        then title := concat(title,'.LIFE')
end {read_title};    

function move_cursor(var x:col; var y:row):boolean;    
var
  ch:char;
begin
  repeat
    gotoxy(x,y);
    read(keyboard,ch);
    if EOF(keyboard)
      then ch := chr(ETX)
      else if EOLN(keyboard) then ch := chr(CR);
    case ord(ch) of
      RT: x := x+1;
      LT: x := x-1;
      UP: y := y-1;
      DN: y := y+1;
      CR: begin x:=1; y:=y+1 end
      end {case};
    {perform wraparound} 
    if x=0 then begin x := 78; y := y-1 end          
           else if x=79 then begin x := 1; y := y+1 end;    
    if y=0 then y := 22  
           else if y=23 then y :=1;
    until (ord(ch) in [ESC,ETX]);
  move_cursor := ord(ch)=ETX 
end {move_cursor};
  
procedure ioerror(n:integer);      
var
  ch:char;
begin
  write_prompt('I/O ERROR ');
  write(n,'.  Type anything to continue:'); 
  read(ch)
end {ioerror};

procedure save_pattern;        
const
  prompt1=
'Move cursor=>upper left corner of area to be saved(ESC aborts,ETX accepts)'; 
  prompt2= 
'Move cursor=>lower right corner of area to be saved(ESC aborts,ETX accepts)';
var
  title:string;
  startx,endx:col;
  starty,endy:row;
  ch:char;
  ok:boolean;
begin
  ok := FALSE;
  write_prompt('Save as what file? (ESC escapes):');  
  if read_title(title)  
    then begin {got title}
      {$I-} rewrite(life_file,title); {$I+}
      if IORESULT=0
        then begin {file opened OK}
          write_prompt(prompt1);
          startx:=middlex; starty:=middley;
          if move_cursor(startx,starty)
            then begin {first move cursor ok}          
              write_prompt(prompt2);    
              endx:=startx; endy:=starty;
              repeat
                gotoxy(endx,endy);
                read(keyboard,ch);
                case ord(ch) of
                  RT: endx:=endx+1;
                  LT: endx := endx-1;  
                  UP: endy := endy-1;    
                  DN: endy := endy+1;
                  CR: begin endx:=1; endy:=endy+1 end
                  end {case};
                if endx<startx then endx:=startx;
                if endx=maxx then endx:=maxx-1;
                if endy<starty then endy:=starty;
                if endy=maxy then endy:=maxy-1 
                until (ord(ch)=ETX) or (ord(ch)=ESC);   
              if ord(ch)=ETX  
                then begin {second move cursor ok}
                  write_prompt('Writing');
                  write(life_file,chr(endy-starty+1),chr(endx-startx+1));
                  for y:=starty to endy do
                    begin  {write a row}
                      for x:=startx to endx do 
                        if alive[x,y]
                          then write(life_file,'1')
                          else write(life_file,'0');  
                      write('.')
                      end  {write a row}; 
                  ok := TRUE
                  end {second move cursor ok} 
              end {first move cursor ok};
          if ok   
            then close(life_file,lock)
            else close(life_file,normal)
          end {file opened ok}  
        else {file didn't open ok}
          ioerror(IORESULT)
      end {got title};  
  write_prompt(prompt) {restore prompt}
end {save_pattern};
           
procedure get_pattern;
const
  move_prompt=
'Move cursor=>upper left corner of area for pattern(ESC aborts,ETX accepts):';
  room_prompt=  
'Not enough room for pattern - try again (ESC aborts, ETX accepts):';   
var   
  title:string;
  startx,cols:col;      
  starty,rows:row;               
  ch:char;
  ok:boolean;
begin 
  write_prompt('Get what file? (ESC escapes):');
  if read_title(title)    
    then begin {got title}
      {$I-} reset(life_file,title); {$I+}
      if IORESULT=0
        then begin {file opened ok}
          read(life_file,ch); rows := ord(ch);  
          read(life_file,ch); cols := ord(ch);  
          write_prompt(move_prompt);
          startx:=middlex; starty:=middley;  
          repeat
            if move_cursor(startx,starty)
              then if (maxy-starty>=rows) and (maxx-startx>=cols)
                then begin {enough room - read in pattern}
                  ok := TRUE;
                  write_prompt('Reading');
                  for y:=starty to starty+rows-1 do 
                    begin  {do a row} 
                      gotoxy(startx,y);
                      for x:=startx to startx+cols-1 do
                        begin  {set cell at x,y}  
                          read(life_file,ch);
                          if ch='1'
                            then set_cell(x,y,TRUE)
                            else set_cell(x,y,FALSE)
                          end  {set cell at x,y}           
                      end  {do a row};
                  gotoxy(36,23); write(population:4)
                  end {enough room}
                else begin {not enough room allowed for pattern}  
                  ok := FALSE;
                  write_prompt(room_prompt)     
                  end {not enough room}  
              else ok := TRUE  {didn't move cursor -ESCape}
            until ok;  
          close(life_file,normal)
          end {file opened ok}  
        else  {file didn't open ok}
          ioerror(IORESULT)
      end {got title}; 
  write_prompt(prompt)  {restore prompt} 
end {get_pattern};
            
procedure read_key;        
var
  title:string;
begin   
  if ch<>'r'
    then begin  {not 'run'ning - read from keyboard}               
      repeat        
        gotoxy(length(prompt)+2,0);              
        read(keyboard,ch);         
        {map to lower case}  
        if ('A'<=ch) and (ch<='Z')
          then ch := chr(ord(ch)+ord('a')-ord('A'));
        case ch of 
          'i': begin  {handle i(nterval}                    
                 gotoxy(50,23);
                 write('  ',chr(BS),chr(BS));
                 interval := read_int(1,99,2)  
                 end;   
          'c': change_pattern;
          's': save_pattern;
          'g': get_pattern;
          end {case}
        until not (ch in ['i','c','s','g']);       
      if ch='r'
        then begin  {got a 'run' request}
          gotoxy(2,0);
          clear_line;
          write(chr(ESC),'RD','Running: hit any key to stop.',       
                chr(ESC),'R@',copy(border,1,46),'+')    
          end  {'run' request}     
      end  {not 'run'ning}
    else  {'run'ning - see if a key has been pressed}
      if key_pressed
        then begin  {a key was pressed - cancel 'run' request}       
          read(keyboard,ch);       {read the character}    
          ch := 'x';               {and throw it away }
          gotoxy(1,0);
          write(chr(ESC),'S',chr(ESC),'S');  {restore prompt}      
          write_prompt(prompt);
          read_key                 {see what user wants to do now} 
          end  {a key was pressed}         
end {read_key};   

procedure initialize;                                 
var
  line:integer;  
begin     
  generation :=0; population :=0; interval :=1;
  for x:=0 to maxx do for y:=0 to maxy do alive[x,y]:=FALSE;
  cur_neighbors:=zeros;      
  next_neighbors:=zeros;
  
  {set up screen} 
  clear_screen;    
  write(chr(ESC),'W');  {disable scrolling}
  gotoxy(79,22);  {last position of next to last line}  
  write('|+---------generation ',generation:3,' population=',       
        population:4,' interval=',interval:2,copy(border,1,27),'+');  
  write(chr(ESC),'X');  {reenable scrolling}
  write('+-');           
  gotoxy(0,1); write('|');
  for line:=1 to 21 do  
    begin
      gotoxy(79,line); 
      write('||')
      end;
   
  {get initial pattern} 
  change_pattern;
  
  {allow for initial option setting}
  if ch<>chr(ESC)
    then begin
      ch := 'x';                  
      read_key
      end
end {initialize};  
       
procedure get_next_gen;      
begin
  population := 0;
  next_neighbors := zeros;        
  for x:=1 to maxx-1 do for y:=1 to maxy-1 do   
    begin  {calculate new alive[x,y] & next_neighbors[x,y]} 
      if (cur_neighbors[x,y]=3) or 
         (alive[x,y] and (cur_neighbors[x,y]=2))  
        then begin      
          alive[x,y] := TRUE;    
          population := population+1;  
          next_neighbors[x-1,y-1]:=next_neighbors[x-1,y-1]+1; 
          next_neighbors[x-1,y]:=next_neighbors[x-1,y]+1;      
          next_neighbors[x-1,y+1]:=next_neighbors[x-1,y+1]+1;  
          next_neighbors[x,y-1]:=next_neighbors[x,y-1]+1;       
          next_neighbors[x,y+1]:=next_neighbors[x,y+1]+1;        
          next_neighbors[x+1,y-1]:=next_neighbors[x+1,y-1]+1;  
          next_neighbors[x+1,y]:=next_neighbors[x+1,y]+1;  
          next_neighbors[x+1,y+1]:=next_neighbors[x+1,y+1]+1      
          end 
        else alive[x,y] := FALSE
      end  {calculate}; 
  cur_neighbors := next_neighbors; 
  generation := generation+1 
end {get_next_gen};
                  
procedure print_gen;    
begin
  for y:=1 to 22 do
    for x:=1 to 78 do      
      if alive[x,y]<>prev_alive[x,y]  
        then begin 
          gotoxy(x,y);
          if alive[x,y]
            then write(screen_char)      
            else write(' ')
          end;
  gotoxy(21,23); write(generation:3);     
  gotoxy(36,23); write(population:4)
end {print_gen};

begin {life}
  fillchar(zeros,sizeof(zeros),chr(0)); 
  print_intro;      
  repeat 
    initialize;  
      while ch<>chr(ESC) do
        begin 
          gotoxy(0,0);  {give some indication that something is happening}   
          prev_alive := alive;      
          for i:=1 to interval do get_next_gen;         
          print_gen;    
          if population=0
            then begin
              gotoxy(30,12);
              write('In generation ',generation,' population=0');
              ch := chr(ESC)
              end
            else begin
              if prev_alive=alive
                then begin
                  gotoxy(55,23); write('PATTERN IS REPEATING') 
                  end;
              read_key
              end
          end;
    gotoxy(0,0);  
    clear_line;
    write('Type ''r'' to repeat, anything else to quit:');     
    read(keyboard,ch)
    until not(ch='r')

end. {life}


========================================================================================
DOCUMENT :usus Folder:VOL18:long_int.text
========================================================================================

  program benchusus;
  (* a long integer benchmark using the structure of
     bench.usus from volume 12   - gws *)
  
  (* I suggest that you run test 1 with 10,000 loops and the
     rest of the tests with 100 or 1000 loops *)
  
  (* There appears to be some sort of problem with divides on my H-89.  If
     I run with more than about 250 loops on the 12 and 36 digit divied, 
     the processor hangs.  If you run into
     similar trouble, PLEASE let me know.  This might be a general Z-80 
     system problem.*)
     
  (* If you have a real time clock, the program will time itself.  If you
     don't, then fret not, just get a stopwatch.  The timer code will 
     detect the lack of a clock and not do anything.  *)
     
  type int4  = integer [ 4 ];
       int12 = integer [ 12 ];
       int36 = integer [ 36 ];
       
  var
    i, j, k, l, test : integer;
    starth,startl,endh,endl : integer;
    num_loops : integer;
    long_a4, long_b4, long_c4 : int4;
    long_a12, long_b12, long_c12 : int12;
    long_a36, long_b36, long_c36 : int36;
    overhead,t,s,e : real;
    fudge_loop : boolean;
    
    procedure prompt;
      procedure prompt1; 
        var line:integer;
        begin
        gotoxy(0,23);
        for line:=1 to 24 do writeln;
        gotoxy(0,0);
        writeln('Select a test or enter "0" for all tests.');
        writeln('Enter a negative number to quit.');
        writeln;
        end;
      begin
      prompt1;
      writeln(' 1. null for loops (to).           2. integer [ 4 ] adds.');
      writeln(' 3. integer [ 12 ] adds            4. integer [ 36 ] adds.');
      writeln(' 5. integer [ 12 ] multiplies.     6. integer [ 12 ] divides.');
      writeln(' 7. integer [ 36 ] multiplies.     8. integer [ 36 ] divides.');
      writeln;
      write('Test number ? ');
      end; { prompt }
      
  procedure doneit;
  
  
  begin
    writeln( chr ( 7 ), 'Done.');
    s:=ABS(startl);
    e:=ABS(endl);
    t:=ABS(e-s)/60;
    if t <> 0.0 then 
      begin
         write('Time = ',t:5:2,' seconds  ' );
         if fudge_loop then  
         writeln ((((t/numloops ) * 1000 ) - ( overhead )):7:3,' ms per loop ')
         else writeln ((( t/numloops ) * 1000 ):7:3, ' ms per loop' );
      end;
  end;

  procedure test1;
    begin
    fudge_loop := false;
    write('1 . ',numloops,' null for loops (to).');
    time(starth,startl);
    for i := 1 to num_loops do begin end;
    time(endh,endl);
    doneit;
    end;
  
procedure test2;
    begin
    fudge_loop := true;
    long_a4 := 1234;
    long_b4 := 5678;
    write('2 . ',numloops,' integer [ 4 ] adds.');
    time(starth,startl);
    for i := 1 to num_loops do begin long_c4 := long_a4 + long_b4 end;
    time(endh,endl);
    doneit;
    end;

procedure test3;
    begin
    fudge_loop := true;
    long_a12 := 123456789012;
    long_b12 := 012345678901;
    write('3 . ',numloops,' integer [ 12 ] adds.');
    time(starth,startl);
    for i := 1 to num_loops do begin long_c12 := long_a12 + long_b12 end;
    time(endh,endl);
    doneit;
    end;

procedure test4;
    begin
    fudge_loop := true;
    long_a36 := 123456789012345678901234567890123456;
    long_b36 := long_a36;
    write('4 . ',numloops,' integer [ 36 ] adds.');
    time(starth,startl);
    for i := 1 to num_loops do begin long_c36 := long_a36 + long_b36 end;
    time(endh,endl);
    doneit;
    end;

procedure test5;
    begin
    fudge_loop := true;
    long_a12 := 100000;
    long_b12 := 100000;
    write('5 . ',numloops,' integer [ 12 ] multiplies.');
    time(starth,startl);
    for i := 1 to num_loops do begin long_c12 := long_a12 * long_b12 end;
    time(endh,endl);
    doneit;
    end;

procedure test6;
    begin
    fudge_loop := true;
    long_a12 := 300000000000;
    long_b12 := 100000000000;
    write('6 . ',numloops,' integer [ 12 ] divides.');
    time(starth,startl);
    for i := 1 to num_loops do begin long_c12 := long_a12 div long_b12 end;
    time(endh,endl);
    doneit;
    end;

procedure test7;
    begin
    fudge_loop := true;
    long_a36 := 10000000000000000;
    long_b36 := long_a36;
    write('7 . ',numloops,' integer [ 36 ] multiplies.');
    time(starth,startl);
    for i := 1 to num_loops do begin long_c36 := long_a36 * long_b36 end;
    time(endh,endl);
    doneit;
    end;

  procedure test8;
    begin
    fudge_loop := true;
    long_a36 := 300000000000000000000000000000000000;
    long_b36 := 100000000000000000000000000000000000;
    write('8 . ',numloops,' integer [ 36 ] divides.');
    time(starth,startl);
    for i := 1 to num_loops do begin long_c36 := long_a36 div long_b36 end;
    time(endh,endl);
    doneit;
    end;


  begin { main }
  writeln ( 'initializing ... ' );
  numloops := 10000;
  test1;
  s:=ABS(startl);
  e:=ABS(endl);
  t:=ABS(e-s)/60;
  overhead := ( t/numloops ) * 1000;
  writeln;
  write('Enter number of loops per test : ');
  readln(num_loops);
  repeat
    prompt;
    readln(test);
    if (test >= 0) then
      case test of
          0 : begin
              test1; test2; test3; test4; test5; test6; test7; test8;
              end;
          1 : test1;  
          2 : test2; 
          3 : test3; 
          4 : test4;
          5 : test5; 
          6 : test6; 
          7 : test7; 
          8 : test8;
        end;
        if test>=0 then
          begin
            write('Type <return> to continue');
            readln;
          end;
    until (test < 0);
  end.



========================================================================================
DOCUMENT :usus Folder:VOL18:numberio.text
========================================================================================

{$R-,$F-}(* GENERATES A FILE OF 25000 REAL NUMBERS, AND COMPUTES THEIR    *)
(* SUM S.  THEN THE FILE IS RESET AND READ, AND A CHECKSUM IS COMPUTED.   *)

(* IT TOOK 1230 MSEC (ON THE CDC 6400) TO GENERATE THE FILE, AND 980 MSEC *)
(* TO READ IT.  THIS CORRESPONDS TO 49 USEC TO WRITE AND 39 USEC TO READ  *)
(* PER NUMBER.                                                            *)
(* THE AMOUNT OF TIME INCREASES DRASTICALLY, IF A DECIMAL REPRESENTATION  *)
(* OF THE NUMBERS ON THE FILE IS REQUESTED.  THIS IS EASILY ACCOMPLISHED, *)
(* NAMELY BY DECLARING THE FILE TO CONSIST OF CHARACTERS INSTEAD OF REAL  *)
(* NUMBERS:                                                               *)
(*             F: FILE OF CHAR                                            *)
(* IN THIS CASE, THE READ AND WRITE STATEMENTS INCLUDE A CONVERSION       *)
(* OPERATION FROM DECIMAL TO BINARY AND VICE-VERSA.  GENERATING THE FILE  *)
(* THEN TAKES 28185 MSEC (ON THE CDC 6400), READING TAKES 30313 MSEC (ON  *)
(* CDC 6400).  THIS CORRESPONDS TO AN INCREASE BY A FACTOR OF 23 IN       *)
(* WRITING AND 31 IN READING.  (EACH NUMBER IS REPRESENTED BY 22          *)
(* CHARACTERS ON THE FILE).                                               *)

(* THE ORIGINAL PROGRAM HAS BEEN MODIFIED TO BE UCSD PASCAL COMPATIBLE,   *)
(* INCLUDING THE USE OF GET/PUT INSTEAD OF READ/WRITE FOR FILES OF REALS. *)

PROGRAM NUMERICIO(F,OUTPUT);
   (*  INPUT AND OUTPUT OF NUMBERS *)
   CONST N = 25000;  D = 0.12345;
   VAR I: INTEGER;  X,S: REAL;
       F: FILE OF REAL;

    BEGIN  
    Writeln;
    Writeln ('Write and read reals  (R-)');
    Writeln;
    Write ('<cr> starts benchmark  (create file part)');
    Readln;

X := 1.0;  S := 0;  REWRITE(F, 'REALTEMP' );
   FOR I := 1 TO N DO
      BEGIN  F^ := X; PUT(F); S := S+X;  X := X+D
      END;
   
   WRITELN('DONE',CHR(7));

WRITELN('CHECKSUM= ', S );
   
   CLOSE(F,LOCK);
   
   WRITELN('<cr> continues benchmark (read part)');
   READLN;
   
   RESET(F, 'REALTEMP');  S := 0;
   WHILE NOT EOF(F) DO
      BEGIN  X:= F^; GET(F); S := S+X;
      END;
   
   WRITELN('DONE',CHR(7));

   WRITELN('CHECKSUM = ',S);
   CLOSE(F, PURGE);
END.

========================================================================================
DOCUMENT :usus Folder:VOL18:odmscu.text
========================================================================================

{ One D****d More Screen Control Unit   24 Dec 82       }
{|xjm$d0|nx|f8|ejm$d1|nx|f8|ejf|.}

{$S++} { Enable as much swapping as you need }

UNIT ScreenUnit ;

{$C Copyright 1982, Volition Systems.  All rights reserved.}

{--- change log
21 Dec 82 [acd] Had to move var Disk to interface, no private files in II.x
}

INTERFACE

  CONST
    SCU_Version   = '0.0a' ;
    SCU_Date      = '24 Dec 82' ;
    
  TYPE 
    Phyle      = FILE ;
    
    CrtCommand = (ClrToEos, ClrToEoL , Up, Down, Right, Left ) ;
  
  VAR 
    Disk     : Phyle ;
  
  FUNCTION InitSCU : BOOLEAN ;
  FUNCTION ScrWidth : INTEGER ;
  FUNCTION ScrHeight: INTEGER ;
  PROCEDURE CrtControl( C : CrtCommand );
  
IMPLEMENTATION
  
  TYPE
    CrtRec         = RECORD
      Unused0      : PACKED ARRAY [0..61] OF CHAR ;
      CrtCtrl      : PACKED RECORD
        Escape     : CHAR;
        Home       : CHAR;
        EraseEoS   : CHAR;
        EraseEoL   : CHAR;
        NDFS       : CHAR;
        RLF        : CHAR;
        BackSpace  : CHAR;
        FillCount  : 0..11;
        ClearLine  : CHAR;
        ClearScreen: CHAR;
        Prefixed   : PACKED ARRAY [0..8] OF BOOLEAN
        END;
      CrtInfo      : PACKED RECORD
        Height     : INTEGER;
        Width      : INTEGER;
        Up         : CHAR;
        Down       : CHAR;
        Left       : CHAR;
        Right      : CHAR;
        EoF        : CHAR;
        Flush      : CHAR;
        Break      : CHAR;
        Stop       : CHAR;
        CharDel    : CHAR;
        BadCh      : CHAR;
        LineDel    : CHAR;
        AltMode    : CHAR;
        Prefix     : CHAR;
        ETx        : CHAR;
        BackSpace  : CHAR;
        Prefixed   : PACKED ARRAY [0..13] OF BOOLEAN
        END;
      Unused1      : ARRAY [0..47] OF INTEGER ;
      Unused2      : ARRAY [0..31] OF INTEGER ;
      Block2       : ARRAY [0..127] OF INTEGER ;
      END ; { CrtRec }
  
  VAR
    InfoRec  : CrtRec ;
    Filler   : STRING[12] ;
    
  FUNCTION InitSCU ; 

  { Use blockread because using a structured file would require putting  }
  { the record declaration in the interface, since private files are not }
  { allowed in II.x units.                                               }

    CONST
      MiscInfoName = '*SYSTEM.MISCINFO' ;
      
    VAR 
      k : INTEGER ;
    
  BEGIN { InitSCU } 
    
    {$I-}
    RESET( Disk, MiscInfoName ) ;
    IF IORESULT = 0 THEN BEGIN
      k := BLOCKREAD( Disk, InfoRec, 1 ) ;
      IF (IORESULT = 0) AND (k = 1) THEN BEGIN
        {$R-}
        FILLCHAR( Filler[1], InfoRec.CrtCtrl.FillCount, CHR(0) ) ;
        Filler[0] := CHR( InfoRec.CrtCtrl.FillCount ) ;
        {$R+}
        InitSCU := TRUE
        END
      ELSE
        InitSCU := FALSE
      END
    ELSE 
      InitSCU := FALSE ;
    CLOSE( Disk )
    {$I+}
  
    END { InitSCU } ;
  
  
  FUNCTION ScrWidth {: INTEGER} ;
  
  BEGIN { ScrWidth }
    
    ScrWidth := InfoRec.CrtInfo.Width
    
    END { ScrWidth } ;
    
    
  FUNCTION ScrHeight {: INTEGER} ;
  
  BEGIN { ScrHeight }
    
    ScrHeight := InfoRec.CrtInfo.Height
    
    END { ScrHeight } ;
    
    
  PROCEDURE CrtControl
    {     c : CrtCommand } ; 
    
  { Call InitSCU before using this procedure.             }
  
    CONST
      CrtUnit   =  1 ;
      NoSpec    = 12 ;
      LineFeed  = 10 ;
      
    VAR
      ca        : PACKED ARRAY [0..0] OF CHAR ;
    
    
    PROCEDURE PutCrt 
      (     Inx : INTEGER ;
            Ch  : CHAR ) ;

      VAR
        i : INTEGER ;
        c : PACKED ARRAY [0..0] OF CHAR ;

    BEGIN { PutCrt }

      IF Ch <> CHR(0) THEN WITH InfoRec.CrtCtrl DO BEGIN
        IF Prefixed[Inx] THEN
          WRITE( Escape ) ;
        c[0] := Ch ;
        UNITWRITE( CrtUnit, c[0], 1, 0, NoSpec ) ;
        IF LENGTH( Filler ) > 0 THEN 
          WRITE( Filler )
        END
      
      END { PutCrt } ;


  BEGIN { CrtControl }
  
    WITH InfoRec DO CASE c OF
      ClrToEoS: BEGIN
        PutCrt( 2, CrtCtrl.EraseEoS ) ;
        END ;
      ClrToEoL: BEGIN
        PutCrt( 3, CrtCtrl.EraseEoL ) ;
        END ;
      Up: BEGIN
        PutCrt( 5, CrtCtrl.RLF ) ;
        END ;
      Down: BEGIN
        ca[0] := CHR(LineFeed) ;
        UNITWRITE( CrtUnit, ca[0], 1, 0, NoSpec )
        END ;
      Left: BEGIN
        PutCrt( 6, CrtCtrl.BackSpace ) ;
        END ;
      Right: BEGIN
        PutCrt( 4, CrtCtrl.NDFS ) ;
        END ;
      END ; { case }

    END { CrtControl } ;
  
BEGIN { ScreenUnit }
  
  { remove the BEGIN above if you are running II.0.  If you are running II.1 }
  { or later you may place a call to InitSCU here, relieving your program of }
  { that burden.                                                             }
  
  END. { One D****d More Screen Control Unit }

========================================================================================
DOCUMENT :usus Folder:VOL18:primes.text
========================================================================================

{$R-,F-} (* Program "primes" computes the first 1000 prime numbers, and *)
(* writes them in a table with 20 numbers per line.  This takes 1347 *)
(* msec. on the CDC 6400 (1061 msec. without the range checking)     *)

(* Modified to 10 numbers per line. *)

PROGRAM PRIMES(OUTPUT);
CONST N = 1000;  N1 = 33;  (*N1 = SQUARE ROOT OF N*)
VAR I,K,X,INC,LIM,SQUARE,L,HI,LOW, q, iterations: INTEGER;
   PRIM: BOOLEAN;
   P,V: ARRAY[1..N1] OF INTEGER;
      
    SHITIME ,SLOWTIME, EHITIME, ELOWTIME: INTEGER;

BEGIN   
Writeln;
Writeln ('First 1000 primes.  No IO.  (R-)');
Writeln;
Write ('Iterations ?  (<cr> starts benchmark)');
Readln (iterations);

for q := 1 to iterations do begin
   (*
   WRITE(2:6, 3:6);
   *)
     L := 2;
      X := 1;  INC := 4;  LIM := 1;  SQUARE := 9;
      FOR I := 3 TO N DO
      BEGIN  (*FIND NEXT PRIME*)
         REPEAT X := X+INC;  INC := 6-INC;
            IF SQUARE <=X THEN
               BEGIN LIM := LIM +1;
                  V[LIM] := SQUARE;  SQUARE := SQR(P[LIM+1])
               END;
            K := 2;  PRIM := TRUE;
            WHILE PRIM AND (K<LIM) DO
            BEGIN K := K+1;
               IF V[K] < X THEN V[K] := V[K] + 2*P[K];
               PRIM := X <> V[K]
            END
         UNTIL PRIM;
         IF I <= N1 THEN P[I] := X;
         (*
         WRITE(X:6); 
         *)
         L := L+1;
         IF L = 10 THEN
            BEGIN (*
                   WRITELN;  
                   *)
                   L := 0;
            END
      END;
      (*
      WRITELN;  
      *)
   end {for q};

   WRITELN('DONE', CHR (7));

END.

========================================================================================
DOCUMENT :usus Folder:VOL18:pwrof2.text
========================================================================================

{$R-,F-}(* This program computes the exact values of 2^k and 2^(-k) for *)
(* k=1...n, and prints them in the form                              *)
(*             2    1  .5                                            *)
(*             4    2  .25                                           *)
(*             8    3  .125                                          *)
(*            16    4  .0625                                         *)
(*            ..............                                         *)
(*                                                                   *)
(* This program uses integer arithmetic exclusively.  Execution time *)
(* for computing the powers of 2 (n=90) was measured as 916 (813)    *)
(* msec.  The figure in parentheses is obtained when run-time index  *)
(* bound checks are disabled.                                        *)

PROGRAM POWERSOFTWO(OUTPUT);
  (*GENERATE A TABLE OF POWERS OF 2 *)
CONST M = 30; N = 90;   (* M >= N*LOG(2) *)
VAR EXP,I,J,L: INTEGER;
    C,R,T, q, iterations: INTEGER;
    D: ARRAY[0..M] OF INTEGER;  (*POSITIVE POWERS*)
    F: ARRAY[1..N] OF INTEGER;  (*NEGATIVE POWERS*)
    
    SHITIME ,SLOWTIME, EHITIME, ELOWTIME: INTEGER;
    
    
BEGIN  
   Writeln;
   Writeln ('Powers of two.  No IO.  (R-)');
   Writeln;
   WRITE('Iterations ?  (test starts with <cr>) ');
   READLN (iterations);

   for q := 1 to iterations do begin
      (*
      Page (output);
      *)
      L := 0;   R := 1;  D[0] := 1;
      FOR EXP := 1 TO N DO
      BEGIN   (*COMPUTE AND PRINT 2**EXP  *)  C := 0;
         FOR I := 0 TO L DO
         BEGIN T := 2*D[I] + C;
            IF T >= 10 THEN
               BEGIN D[I] := T-10;  C := 1;
               END
            ELSE
               BEGIN  D[I] := T;  C := 0;
               END
         END;
         IF C > 0 THEN
            BEGIN L := L + 1;  D[L] := 1;
            END;
         FOR I := M DOWNTO L DO (*
                                 WRITE(' ')
                                 *);
         FOR I := L DOWNTO 0 DO (*WRITE(D[I]:1);
         WRITE(EXP:5, '  .')
         *);
         (* COMPUTE AND PRINT 2**(-EXP) *)
         FOR J := 1 TO EXP-1 DO
         BEGIN R := 10*R + F[J];
            F[J] := R DIV 2;  R := R - 2*F[J];  (*
                                                WRITE(F[J]:1) *)
         END;
         F[EXP] := 5;  (*
         WRITELN('5');  
         *)
         R := 0
         END;
      end {for q};
   WRITELN('DONE',CHR(7));

END.

========================================================================================
DOCUMENT :usus Folder:VOL18:quicksort.text
========================================================================================

{$R-,$F-}(* THIS PROGRAM SORTS AN ARRAY OF 10000 INTEGERS ACCORDING TO THE *)
(* METHOD CALLED QUICKSORT.  IT USES A RECURSIVE PROCEDURE.  THE  *)
(* THE MAXIMUM DEPTH OF RECURSION IS LN(10000).                   *)

(* EXECUTION TIME ON THE CDC 6400 WAS 4098 MSEC. (2861 MSEC WITHOUT *)
(* RANGE CHECKING).                                                 *)
{  Note CDC times did not include initializing array. }


(* THE TEXT OF THIS PROGRAM WAS MODIFIED TO ACCOMODATE 16 BIT MACHINES *)

PROGRAM QUICKSORT(OUTPUT);
   CONST N = 10000;
   VAR I,Z, q, iterations: INTEGER;
       A: ARRAY[1..N] OF INTEGER;
       
    SHITIME ,SLOWTIME, EHITIME, ELOWTIME: INTEGER;

   PROCEDURE SORT(L,R: INTEGER);
      VAR I,J,X,W: INTEGER; 
   BEGIN (*QUICKSORT WITH RECURSION ON BOTH PARTITIONS*)
      I := L;  J := R;  X := A[ (I+J) DIV 2];
      REPEAT
         WHILE A[I] < X DO I := I+1;
         WHILE X < A[J] DO J := J-1;
         IF I <= J THEN
            BEGIN W := A[I];  A[I] := A[J];  A[J] := W;
               I := I+1;  J := J-1;
            END
      UNTIL I > J;
      IF L < J THEN SORT(L,J);
      IF I < R THEN SORT(I,R)
   END; (*SORT*)
      
BEGIN  
   Writeln;
   Writeln ('Quicksort 10000 integers  (R-)');
   Writeln;
   WRITE('Iterations?  (<cr> starts benchmark) ');
   READLN (iterations);

   for q := 1 to iterations do begin
      {$R-}
      Z := 257;  (*GENERATE RANDOM SEQUENCE*)
      FOR I := 1 TO N DO
         BEGIN  
         Z := (251*Z) MOD 255;  A[I] := Z
         END;
      {$R+}
      
      SORT(1,N);
      end {for};
   
   WRITELN('DONE',CHR(7));

END.

========================================================================================
DOCUMENT :usus Folder:VOL18:qur.text
========================================================================================

program qur;

     {This may seem to be a fairly trivial benchmark, but it actually has a
fair amount of significance.  It indicates the minimal response time of the
system to update, compile and execute a trivial program.  

     The preferred test method is to load this program into the editor using
the G(et command.  Update the file once to place it on your system disk as
*SYSTEM.WRK.TEXT, and then re-enter the E(ditor. The compiler should be on
your system disk.  Start timing when your type the "Q" of the "QUR" command
sequence to update the workfile and run the program.  Stop timing when the 
'hi there' message appears on the screen.

     The actual performance being measured is the system's ability to shuffle
around data in a often used sequence.  This test will not show much
sensitivity to faster processors, and will be very much influenced by both the
speed of your disk system and the type of software that you are using.
Version II.0 type systems will respond much faster than IV.0 systems.  ASE
will hurt a little. Extended memory will help, as the system won't have to
mash memory as much.

     If you wish to contribute your results, please include all of the
information on the data collection form on this disk.  It is very important to
know which version of the p-system you are running and what type of disk
subsystem that you use.

regards - gws}


begin
   writeln ( 'hi there' );
end.


========================================================================================
DOCUMENT :usus Folder:VOL18:report.doc.text
========================================================================================


     Use the form in the file REPORTFORM.TEXT to report the results of the
benchmarks on this disk for your particular iron.  If you run the tests under
different versions of the p-system, or with different hardware configurations,
fill out the pertanent parts on a new form and attach it to the first one.

     You should not modify the sources of any of the benchmarks to optimize
performance, it is realized that there may be faster ( or slower ) ways to
do whatever the benchmarks do, but the goal is to obtain comparative data
on many different types of computers to see which has the better or worse
performance.  We also wish to see if particular computers do particular things
especially poorly or well.  For example, the IV.03 release for the IBM PC is
unusually slow when working with reals.

     When you are given an option on the number of loops to run, please pick a
number which causes the benchmark to run at least 60 seconds.  This will allow
reasonable accuracy when timing with a stopwatch or wall clock.

     Please provide some sort of information on your hardware in the space
provided.  It is important that we know the processor type, the clock speed, and
the version of the p-system that you use.  It would also be helpful if you could
supply information on the speed of your disks and whether or not that you have
some sort of floating point hardware or perpherial data processor installed.

     regards - gws


========================================================================================
DOCUMENT :usus Folder:VOL18:reportform.text
========================================================================================

                             Benchmark Report Form

           ---> PLEASE READ THE INSTRUCTIONS IN REPORT.DOC.TEXT <---
           
Your Name ( optional ) __________________________________________________

Processor type ________________________________________  Clock ___________

RAM Available _________________   Speed if known ______________

P-System version ________________  Floating Point Hardware _______________

Floppy Disk    Model _______________ Capacity _______________ DMA ? ____

Hard disk      Model _______________ Capacity _______________ DMA ? ____

+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

                           Timing results ( seconds )

PWROF2.TEXT  _____   8QUEENS.TEXT  _______  NUMBERIO.TEXT   _______/________ 

QUICKSORT.TEXT  _____  ANCEST.S.TEXT  ______  SIEVE.TEXT _____ QUR.TEXT _______

COMPKILLER  number of lines compiled _________  elapsed time  __________

STARS ______(ms/loop)  SEGMASHER  large seg _____ small seg ____ (ms/swap)

LONG_INT.TEXT ( please normalize results to milli-seconds per loop with
                the overhead of test 1 subtracted from result )

Test 1  null for loop          ______   Test 2  integer [ 4 ] adds       _______

Test 3  integer [12] adds      ______   Test 4  integer [ 36 ] adds      _______

Test 5  integer [12] multiplies______   Test 6  integer [ 12 ] divides   _______

Test 7  integer [36] multiplies______   Test 8  integer [ 36 ] divides   _______

INTRINSICS.TEXT ( please normalize results to milli-seconds per loop with
                  the overhead of test 1 subtracted from result )
 
Test 1  null for loop          ______   Test 2  sin                      _______

Test 3  cos                    ______   Test 4  exp                      _______

Test 5  atan                   ______   Test 6  ln                       _______

Test 7  log                    ______   Test 8  pwroften                 _______

Test 9  trunc                  ______   Test 10 round                    _______

Test 11 fillchar a small array ______   Test 12 fillchar a large array   _______

Test 13 moveleft a small array ______   Test 14 moveleft a large array   _______

Test 15 scan a small array     ______   Test 16 scan a large array       _______

Test 17 sizeof                 ______


========================================================================================
DOCUMENT :usus Folder:VOL18:segmap.1.text
========================================================================================

{ SegMap: A quick & dirty segment map utility 17 Apr 83 }

{ L PRINTER: }{$L-}
{$S++} { enable as much swapping as you need }
{$V-}  { turn off var string length verification on Apples }

PROGRAM SegMap ;

{========================================================================}
{ File    : SegMap            Author: Arley C. Dealey                    }
{ Date    : 14 Dec 82         Time  : 10:00                              }
{------------------------------------------------------------------------}
{ Revision: 0.1f              Author: Arley C. Dealey                    }
{ Date    : 17 Apr 83         Time  : 15:15                              }
{========================================================================}
{                                                                        }
{ SegMap is a quick and dirty utility to display the information found   }
{ the segment dictionary of a UCSD code file.  It was developed hastily  }
{ when a new and undocumented restriction was added to the system (no    }
{ code segment may be over 8192 words long under IV.1 on the DEC - 11    }
{ systems) in the middle of a major project.  The most important         }
{ information it displays is available via the standard LIBRARY utility, }
{ but in a much less convenient form.                                    }
{                                                                        }
{ This program was developed hastily and is not terribly well written.   }
{ Several expedient, but questionable, programming practices are         }
{ evident.  As an example, most functions in this program exhibit one or }
{ more side effects, whether they be modifying the value of parameters   }
{ or writing messages to the console.  Global variables have been used   }
{ rather heavily also.  Be forwarned, it may not be the easiest program  }
{ to modify!                                                             }
{                                                                        }
{ The segment dictionary is, of necessity, kludged together to deal with }
{ all known varieties of the UCSD system.  The program has been compiled }
{ and tested under the II.0 and II.1 compilers and will work with all    }
{ code files (yes, Virginia, even IV.x extended segment dictionaries).   }
{ It is believed that some versions of the II.0 compiler may not have    }
{ zeroed unused fields in the segment dictionary record.  This will lead }
{ to erroneous reports of required intrinsics.  If you are using a II.0  }
{ compiler and experience this, you should probably remove the intrinsic }
{ report code all together (they were not supported under II.0 anyway).  }
{ Apple /// code files have not been tested and may act strangely        }
{ because Apple chose to redefine the MajorVersion field to mean         }
{ AppleVersion.  This also causes Apple ][ release 1.0 segments to be    }
{ reported as II.0 rather than II.1                                      }
{                                                                        }
{ Terminal screen control handling is hard-coded in procedure CrtControl }
{ for a TVI-950.  A screen control unit was not used because the program }
{ was developed using a variant of the I.3 compiler which did not support}
{ units. It was hard-coded because the author is lazy, but it should be  }
{ trivial to adapt it to use a generalized unit.                         }
{                                                                        }
{ This program was inspired by (and, in fact, based on) CodeMap by       }
{ David N. Jones as published in Call-A.P.P.L.E. In Depth #2.            }
{                                                                        }
{========================================================================}
{$C Copyright (C) 1982, Volition Systems.  All rights reserved.          }
{========================================================================}

{=== change log =============================================================
16 Apr 83 gws  broke it into two files for the benefit of non-ASE users
12 Feb 83 [acd] Fixed failure to clear screen reported by Schreyer/Willner 
28 Dec 82 [acd] Added display of screen control unit version & date
28 Dec 82 [acd] SetOutput now clears line before putting status message
28 Dec 82 [acd] Fixed bug in SetPrefix that could bomb if null response
23 Dec 82 [acd] Converted to use One Damn More Screen Control Unit
22 Dec 82 [acd] Flips IntSegSet
21 Dec 82 [acd] Split procedure MapSofTech
21 Dec 82 [acd] Redefined ItIsFlipped (yet again) & hope it works correctly
20 Dec 82 [acd] Added further info to IV.= map
17 Dec 82 [acd] Paranoid double check of file gender & attendant restructuring
16 Dec 82 [acd] New test for ItIsFlipped.  There must be a better way!
15 Dec 82 [acd] Added default capability to code file name prompt
15 Dec 82 [acd] New FlipIt.  Should work correctly now.
15 Dec 82 [acd] Restructured sex-change stuff
14 Dec 82 [acd] Don't write any fields if seg length is zero
14 Dec 82 [acd] Major user interface & code restructuring
14 Dec 82 [acd] Added code to deal with IV.x linked segdicts
14 Dec 82 [acd] Turns off iochecking locally where needed instead of globally
14 Dec 82 [acd] Added code to flip integers if necessary
14 Dec 82 [acd] Added UCSD/SofTech dichotomy stuff
{============================================================================}

{--- profile ----------
|xstjm$d0|nx|f8|ejm$d1|nx|f8|ejm$d2|nx|f8|ejt|n|*|f1|.

|"New Rev"
stjm$r0|n
dg |!
|*c|f7
jm$r1|n
x|f7|e
jm$r2|n
x|f7|e
jt|.
{--- end of profile ---}

USES
  {$U odmscu.code}
  ScreenUnit ;
  
CONST
   Title        = 'SegMap[' ;
   Rev          = '0.1f' ;
   T0 = '                        Volition Systems'' SegMap utility' ;
   T1 = '                            version 0.1f of 17 Apr 83' ;
   T2 = '          Copyright (C) 1982, Volition Systems.  All rights reserved.';
   MaxSeg       =    63 ; { 15 for most, 31 for Apple ][, 63 for Apple /// }
   MaxDicSeg    =    15 ;

TYPE
   SegRange     = 0..MaxSeg ;
   SegDicRange  = 0..MaxDicSeg ;
   SegmentName  = PACKED ARRAY[0..7] OF CHAR ;
   
   { I.x, II.x, III.x, VS }
     SegmentTypes = ( Linked, HostSeg, SegProc, UnitSeg, SeprtSeg,
                      Unlinked_Intrins, Linked_Intrins, DataSeg ) ;
     MachineTypes = ( UnDefined, PCodeMost, PCodeLeast, PDP11, M8080, Z80,
                      GA440, M6502, M6800, TI990 ) ;
   { IV.x }
     SegTypes     = ( NoSeg, ProgSeg, xUnitSeg, ProcSeg, xSeprtSeg ) ;
   
   Versions     = ( Unknown, II, II_1, III, IV, V, VI, VII ) ;
   { note on apples:                                                        }
   {   Versions = ( Unknown, A2_10, A2_11, A3_10, A3_11, Bad1, Bad2, Bad3 ) }
   { therefore                                                              }
   {   II   implies Apple ][ 1.0                                            }
   {   II_1 implies Apple ][ 1.1                                            }
   {   III  implies Apple /// 1.0                                           }
   {   IV   implies Apple /// 1.1                                           }
   { thanks a lot, you guys! sure would have been nice if you had used one  }
   { of the unused words at the end of the record for the Apple version #.  }
   
   SegSet       = SET OF SegRange ;

   SegDict = RECORD
     DiskInfo  : ARRAY[SegDicRange] OF RECORD
                   CodeAddr : INTEGER ;
                   CodeLeng : INTEGER
                   END ;
     SegName   : ARRAY[SegDicRange] OF SegmentName ;
     SegMisc   : PACKED RECORD
                   CASE BOOLEAN OF
                     TRUE  : { UCSD, Apple, WD, VS }
                       ( SegType   : ARRAY[SegDicRange] OF SegmentTypes ) ;
                     FALSE : { SofTech }
                       ( xSegMisc  : ARRAY[SegDicRange] OF PACKED RECORD
                                       SegType     : SegTypes ;
                                       Filler      : 0..31 ;
                                       HasLinkInfo : BOOLEAN ;
                                       Relocatable : BOOLEAN
                                       END ) ;
                   END ;
     SegText   : ARRAY[SegDicRange] OF INTEGER ;
     SegInfo   : ARRAY[SegDicRange] OF PACKED RECORD
                   SegNum        : 0..255 ;
                   MType         : MachineTypes ;       { UCSD }
                   Filler        : 0..1 ;
                   MajorVersion  : Versions ;
                   END ;
     CASE BOOLEAN OF
       TRUE  : { UCSD, Apple, WD, VS }
         ( IntSegSet : SegSet ; { 1 word on most, 2 on A][, 4 on A/// }
           IntChkSum : PACKED ARRAY [0..MaxSeg] OF 0..255 ; {valid on A/// only}
           Filler2   : ARRAY[0..35] OF INTEGER ;
           Comment   : PACKED ARRAY[0..79] OF CHAR 
           ) ;
       FALSE : { SofTech }
         ( SegFamily : ARRAY[SegDicRange] OF RECORD
                         CASE SegTypes OF
                           xUnitSeg, ProgSeg:
                             ( DataSize : INTEGER ;
                               SegRefs  : INTEGER ;
                               MaxSegNum: INTEGER ;
                               TextSize : INTEGER ) ;
                           xSeprtSeg, ProcSeg:
                             ( ProgName : SegmentName ) ;
                         END ;
           NextDict  : INTEGER ;
           Filler    : ARRAY[0..6] OF INTEGER ;
           CopyNote  : STRING[77] ;
           Sex       : INTEGER ) ;
     END ; { SegDict }
     
   SegDicRec    = RECORD
     Flipped    : BOOLEAN ;
     Dict       : SegDict
     END ;

   PathName     = STRING[23] ;
   

VAR
  f             : Phyle ;
  o             : INTERACTIVE ;
  CmdSet        : SET OF CHAR ;
  OFileName     : PathName ;
  CFileName     : PathName ;
  Prefix        : STRING[8] ;
  ConsoleOutput : BOOLEAN ;


PROCEDURE Initialize ;

BEGIN { Initialize }
  
  IF InitSCU = FALSE THEN BEGIN
    WRITE( 'Screen control unit failed initialization.' ) ;
    EXIT( SegMap ) 
    END ;
  IF (ScrHeight < 24) OR (ScrWidth < 80) THEN BEGIN
    WRITE( 'Sorry, you must have at least a 24 x 80 terminal.' ) ;
    EXIT( SegMap )
    END ;
  GOTOXY( 0, 0 ) ;
  CrtControl( ClrToEoS ) ;
  GOTOXY( 0, 8 ) ;
  WRITELN( T0 ) ;  WRITELN ;
  WRITELN( T1 ) ;  WRITELN ;
  WRITELN( T2 ) ;  WRITELN ;
  GOTOXY( 0, 17 ) ;
  WRITE( '':14 ) ;
  WRITE( 'Using screen control unit version ' ) ;
  WRITE( SCU_Version, ' of ', SCU_Date, '.'  ) ;
  CmdSet        := [ 'm', 'M', 'o', 'O', 'p', 'P', 'q', 'Q' ] ;
  OFileName     := 'CONSOLE:' ;
  CFileName     := 'SYSTEM.WRK' ;
  Prefix        := '' ;
  ConsoleOutput := TRUE ;
  REWRITE( o, OFileName ) ;
  
  END { Initialize } ;
  
  
PROCEDURE CleanUp ;

BEGIN { CleanUp }
  
  CLOSE( o, LOCK ) ;
  
  END { CleanUp } ;
  
  
PROCEDURE SpaceWait ;

  CONST
    KbdUnit     =  2 ;
    
  VAR
    JunkCh      : CHAR ;

BEGIN { SpaceWait }
  
  GOTOXY( 0, 0 ) ;
  CrtControl( ClrToEoL ) ;
  WRITE( '<space to continue>' ) ;
  UNITCLEAR( KbdUnit ) ;
  REPEAT
    READ( KEYBOARD, JunkCh )
    UNTIL JunkCh = ' ' ;
  GOTOXY( 0, 0 ) ;
  CrtControl( ClrToEoL ) 
  
  END { SpaceWait } ;
  
  
{ L+}
PROCEDURE Sanitize
  ( VAR FileName : STRING ;
        Prefix   : STRING ;
        Ext      : STRING ) ;

  VAR
    i      : INTEGER ;
    FNLen  : INTEGER ;
    ExtLn  : INTEGER ;
    
BEGIN { Sanitize }
  
  ExtLn := LENGTH( Ext ) ;
  
  FOR i := LENGTH( FileName ) DOWNTO 1 DO 
    IF FileName[i] IN [CHR(0)..CHR(31), ' '] THEN
      DELETE( FileName, i, 1 ) 
    ELSE IF FileName[i] IN ['a'..'z'] THEN
      FileName[i] := CHR(ORD(FileName[i])-32) ;
  
  IF LENGTH( FileName ) > 0 THEN BEGIN
    
    IF (POS( ':', FileName ) = 0) AND
       (FileName[1] <> '*'      )  THEN
      FileName := CONCAT( Prefix, FileName ) ;
  
    FNLen := LENGTH( FileName ) ;
    IF FileName[FNLen] = '.' THEN
      DELETE( FileName, FNLen, 1 )
    ELSE IF COPY( FileName, SUCC(FNLen-ExtLn), ExtLn ) <> Ext THEN
      FileName := CONCAT( FileName, Ext ) ;
    IF LENGTH(FileName) > 23 THEN
      FileName := COPY( FileName, 1, 23 ) ;
    
    END { fnlen > 0 }
  
  END { Sanitize } ;
  
  
PROCEDURE SplitName
  (     Name    : STRING ;
    VAR VolName : STRING ;
    VAR FileName: STRING ) ;

  VAR
    ColonPos    : INTEGER ;

BEGIN { SplitPathName }
  
  IF LENGTH( Name ) > 0 THEN BEGIN
    ColonPos := POS( ':', Name ) ;
    IF ColonPos > 0 THEN BEGIN
      VolName := COPY( Name, 1, ColonPos ) ;
      FileName:= COPY( name, SUCC(ColonPos), LENGTH(name)-ColonPos ) ;
      END
    ELSE IF Name[1] = '*' THEN BEGIN
      VolName := '*' ;
      IF LENGTH( Name ) > 1 THEN
        FileName := COPY( Name, 2, LENGTH(Name)-1 ) 
      ELSE
        FileName := '' ;
      END
    ELSE BEGIN
      VolName := '' ;
      FileName:= Name
      END
    END
  ELSE BEGIN
    VolName := '' ;
    FileName:= '' ;
    END ;
    
  END { SplitPathName } ;
{ L-}
  
FUNCTION Menu
  : BOOLEAN ;

  VAR
    CmdCh       : CHAR ;
    Done        : BOOLEAN ;
    

  PROCEDURE PutPrompt ;
  
  BEGIN { PutPrompt }
    
    GOTOXY( 0, 23 ) ;
    CrtControl( ClrToEoL ) ;
    WRITE( 'Output file is ', OFileName ) ;
    IF (LENGTH( Prefix ) > 0) AND (Prefix <> ':') THEN
      WRITE( ',  prefix volume is ', Prefix ) ;
    GOTOXY( 0, 0 ) ;
    CrtControl( ClrToEoL ) ;
    WRITE( Title, Rev, ']  ' ) ;
    WRITE( 'M(ap,  O(utput file,  P(refix,  Q(uit ' ) ;
    
    END { PutPrompt } ;
    
    
  PROCEDURE SetOutputFile ;
  
    VAR
      OFName    : STRING ;
      
  BEGIN { SetOutputFile }
    
    GOTOXY( 0, 0 ) ;
    CrtControl( ClrToEoL ) ;
    WRITE( '[', OFileName, '] Enter new output file name: ' ) ;
    READLN( OFName ) ;
    Sanitize( OFName, Prefix, '' ) ;
    IF LENGTH( OFName ) > 0 THEN BEGIN
      {$I-}
        CrtControl( ClrToEoL ) ;
        CLOSE( o, LOCK ) ;
        REWRITE( o, OFName ) ;
        IF IORESULT = 0 THEN BEGIN
          WRITELN( 'Output file opened successfully' ) ;
          OFileName := OFName ;
          END
        ELSE BEGIN
          WRITELN( 'Open error on output file ', OFName ) ;
          REWRITE( o, OFileName ) 
        END ;
        {$I+}
      IF (OFName = 'CONSOLE:') OR (OFName = '#1:') THEN
        ConsoleOutput := TRUE
      ELSE
        ConsoleOutput := FALSE
      END ;
    
    END { SetOutputFile } ;
    
    
  PROCEDURE SetPrefix ;
  
    VAR
      pf        : STRING ;
      
  BEGIN { SetPrefix }
    
    GOTOXY( 0, 0 ) ;
    CrtControl( ClrToEoL ) ;
    IF LENGTH( Prefix ) > 0 THEN
      WRITE( '[', Prefix, '] ' ) ;
    WRITE( 'Enter new prefix: ' ) ;
    READLN( pf ) ;
    IF LENGTH( pf ) > 0 THEN
      Prefix := pf ;
    Sanitize( Prefix, '', '' ) ;
    IF LENGTH( Prefix ) > 0 THEN
      IF (Prefix <> '*') AND (Prefix[LENGTH(Prefix)] <> ':') THEN 
        Prefix := CONCAT( Prefix, ':' ) ;
    
    END { SetPrefix } ;
    
    
  FUNCTION OpenCodeFile
    ( VAR CodeFile      : Phyle ;
      VAR CFileName     : PathName )
    : BOOLEAN ;
  
  { Note that this returns the open status as a function result.  This     }
  { method of returning the status results in a function with side-effects }
  { on both of its parameters - questionable programming practice at best! }
    
    VAR
      fn        : STRING ;
      JunkName  : STRING ;
      
  BEGIN { OpenCodeFile }
    
    GOTOXY( 0, 0 ) ;
    CrtControl( ClrToEoL ) ;
    SplitName( CFileName, JunkName, CFileName ) ;
    IF LENGTH( CFileName ) > 0 THEN
      WRITE( '[', CFileName, '] ' ) ;
    WRITE( 'Enter name of file to be mapped: ' ) ;
    READLN( fn ) ;
    IF LENGTH( fn ) = 0 THEN 
      fn  := CFileName ;
    { try it first with no extension }
    Sanitize( fn, Prefix, '' ) ;
    {$I-}
      CLOSE( CodeFile ) ;
      RESET( CodeFile, fn ) ;
      IF IORESULT <> 0 THEN BEGIN
        { now try it with code extension }
        Sanitize( fn, '', '.CODE' ) ;
        RESET( CodeFile, fn ) ;
        END ;
      {$I+}
    IF IORESULT = 0 THEN BEGIN
      CFileName := fn ;
      OpenCodeFile := TRUE ;
      END
    ELSE BEGIN
      CrtControl( ClrToEoS ) ;
      WRITELN( 'Open error on file ', fn ) ;
      OpenCodeFile := FALSE ;
      END ;
    
    END { OpenCodeFile } ;
    
    
    
BEGIN { Menu }
  
  REPEAT
    PutPrompt ;
    REPEAT
      READ( KEYBOARD, CmdCh ) 
      UNTIL CmdCh IN CmdSet ;
    WRITELN ;
    CASE CmdCh OF
      'm', 'M': BEGIN { M(ap }
        Done := OpenCodeFile( f, CFileName ) ;
        Menu := TRUE 
        END ; { M(ap }
      'o', 'O': BEGIN { O(utput }
        Done := FALSE ;
        SetOutputFile 
        END ; { O(utput }
      'p', 'P': BEGIN { P(refix }
        Done := FALSE ;
        SetPrefix
        END ; { P(refix }
      'q', 'Q': BEGIN { Q(uit }
        Done := TRUE ;
        Menu := FALSE 
        END ; { Q(uit }
      END ; { case }
    UNTIL Done
  
  END { Menu } ;

(*$I segmap.2.text*)


========================================================================================
DOCUMENT :usus Folder:VOL18:segmap.2.text
========================================================================================

  
(* included from segmap.1.text*)
  
PROCEDURE Map
  ( VAR f       : Phyle ) ;

  VAR
    SegDic      : SegDicRec ;
    SegDicNum   : INTEGER ;
    BlockNum    : INTEGER ;
  
  
  FUNCTION ReadSegDic
    ( VAR f     : PHYLE ;
          Block : INTEGER ;
      VAR SegDic: SegDicRec ) 
    : BOOLEAN ;

  
    FUNCTION ItIsFlipped
      (     SegDic  : SegDict )
      : BOOLEAN ;
    
    { Note (with some frustration) that we can't use the IV.x Sex byte    }
    { to check for sex even on IV.x code files, because the MajorVersion  }
    { field is in a sex-effected record and so cannot be checked until    }
    { AFTER the sex is already determined!              -acd 17 Dec 82    }

    { The test used is kludgy at best.  We assume that all valid code     }
    { (& library) files must have something beginning at block one.  If   }
    { we find no CodeAddr equal to 1 and no SegText equal to 1 we then    }
    { assume that the file must be of the wrong sex.  If someone can tell }
    { me of a less arbitrary way to test this, I would be very grateful!  }
    {                                                   -acd 18 Dec 82    }

    { We now make the further assumption that if the IV.x sex word seems  }
    { to contain the value <1> in either sex that the file is indeed IV.x }
    { This should be OK, since this word contained the last two bytes of  }
    { the comment in pre-IV.x releases and if you put <ctrl-A><ctrl-@>    }
    { or <ctrl-@><ctrl-A> into your comment you deserve anything you get. }
    { Of course, if your compiler didn't zero these bytes, 1 in every 128 }
    { files you SegMap will be reported erroneously as IV.x files.  Sorry }
    { bout that, maybe someone will write a SegDictFix utility!  All of   }
    { this foolishness is necessary because my kludge test for sex won't  }
    { work on IV.x where the segment that resides at block #1 will often  }
    { be in a later block of the segment dictionary.    -acd 21 Dec 82    }

      CONST
        NotFlipped      =     1 ;
        Flipped         =   256 ;
        
      VAR
        i   : INTEGER ;
        Temp: BOOLEAN ;
        
    BEGIN { ItIsFlipped }
      
      IF SegDic.Sex IN [ Flipped, NotFlipped ] THEN BEGIN
        IF SegDic.Sex = Flipped THEN 
          ItIsFlipped := TRUE
        ELSE
          ItIsFlipped := FALSE
        END
      ELSE BEGIN
        Temp := TRUE ; { assume it to be flipped }
        WITH SegDic DO BEGIN
          FOR i := 0 TO MaxDicSeg DO 
            IF ( DiskInfo[i].CodeAddr = 1 ) OR
               ( SegText[i]           = 1 ) THEN
              Temp := FALSE ; { must be ok (we hope) }
          END ; { with }
        ItIsFlipped := Temp
        END ;
        
      END { ItIsFlipped } ;
  
  
    PROCEDURE FlipSegDic
      ( VAR SegDic : SegDicRec ) ;
    
      VAR
        i       : INTEGER ;
        Transfer: INTEGER ;
        XfrArray: ARRAY [0..3] OF INTEGER ;
        
  
      FUNCTION FlipIt
        (     Num     : INTEGER ) 
        : INTEGER ;
      
        VAR
          a, b  : PACKED ARRAY [0..1] OF 0..255 ;
          
      BEGIN { FlipIt }
        
        MOVELEFT( Num, a[0], 2 ) ;
        b[0] := a[1] ;
        b[1] := a[0] ;
        MOVELEFT( b[0], Num, 2 ) ;
        FlipIt := Num
        
        END { FlipIt } ;
  
  
    BEGIN { FlipSegDic }
      
      IF ItIsFlipped( SegDic.Dict ) THEN BEGIN
        WITH SegDic, Dict DO BEGIN
          FOR i := 0 TO MaxDicSeg DO BEGIN
            { first the easy part... }
            WITH DiskInfo[i] DO BEGIN
              CodeAddr := FlipIt( CodeAddr ) ;
              CodeLeng := FlipIt( CodeLeng ) 
              END ; { with DiskInfo }
            SegText[i] := FlipIt( SegText[i] ) ;
            { and now all the messy junk... }
            MOVELEFT( SegMisc.SegType[i], Transfer, 2 ) ;
            Transfer := FlipIt( Transfer ) ;
            MOVELEFT( Transfer, SegMisc.SegType[i], 2 ) ;
            MOVELEFT( SegInfo[i], Transfer, 2 ) ;
            Transfer := FlipIt( Transfer ) ;
            MOVELEFT( Transfer, SegInfo[i], 2 ) ;
            IF SegInfo[i].MajorVersion > III THEN BEGIN
              IF SegMisc.xSegMisc[I].SegType IN [ xUnitSeg, ProgSeg ] THEN BEGIN
                WITH SegFamily[i] DO BEGIN
                  DataSize  := FlipIt( DataSize ) ;
                  SegRefs   := FlipIt( SegRefs ) ;
                  MaxSegNum := FlipIt( MaxSegNum ) ;
                  TextSize  := FlipIt( TextSize ) 
                  END ; { with segfamily }

                END ; { if }
              END ; { if }
            END ; { for }
          IF SegInfo[0].MajorVersion > III THEN BEGIN
            NextDict := FlipIt( NextDict ) ;
            { in an ideal world we'd leave Sex unflipped, but this thing is, }
            { as I said, quick and dirty so we need to go ahead and flip it. }
            Sex := FlipIt( Sex )
            END { if }
          ELSE BEGIN
            MOVELEFT( IntSegSet, XfrArray[0], SIZEOF(IntSegSet) ) ;
            FOR i := 0 TO 3 DO
              XfrArray[i] := FlipIt( XfrArray[i] ) ;
            MOVELEFT( XfrArray[0], IntSegSet, SIZEOF(IntSegSet) ) ;
            END ; { else }
          END ; { with segdic.dict }
        END { if }
      
      END { FlipSegDic } ;
      
      
  BEGIN { ReadSegDic }

    {$I-}
    IF (BLOCKREAD(f, SegDic.Dict, 1, Block) = 1) AND (IORESULT = 0) THEN BEGIN
    {$I+}
      IF ItIsFlipped( SegDic.Dict ) THEN BEGIN
        SegDic.Flipped := TRUE ;
        FlipSegDic( SegDic )
        END 
      ELSE BEGIN
        SegDic.Flipped := FALSE ;
        END ;
      IF Block = 0 THEN BEGIN { only recheck gender in first seg of dictionary }
        IF ItIsFlipped( SegDic.Dict ) THEN BEGIN
          CrtControl( ClrToEoS ) ;
          WRITE( 'Unable to determine gender of ', CFileName ) ;
          ReadSegDic := FALSE
          END
        ELSE BEGIN
          ReadSegDic := TRUE
          END
        END { if block = 0 }
      ELSE
        ReadSegDic := TRUE { because we already know the gender is OK }
      END { if block read successfully }
    ELSE BEGIN
      CrtControl( ClrToEoS ) ;
      WRITE( 'Error reading segment dictionary of ', CFileName ) ;
      ReadSegDic := FALSE
      END 
    
    END { ReadSegDic } ;
    
    
  PROCEDURE MapUCSD 
    (     SegDic : SegDicRec ) ;
    
    VAR
      i                 : INTEGER ;
      j                 : SegRange ;
      IntrinsNeeded     : BOOLEAN ;
  
  BEGIN { MapUCSD }
    
    IntrinsNeeded := FALSE ;
    
    WRITE( o, '  #  Name      Addr    Len  ' ) ;
    WRITE( o, 'Version   Machine  Kind                ' ) ;
    WRITE( o, 'Seg   Text' ) ;
    WRITELN( o ) ;
    
    WITH SegDic, Dict DO BEGIN
      
      FOR i := 0 TO MaxDicSeg DO BEGIN
        WRITE( o, i:3 ) ;
        IF SegDic.Dict.DiskInfo[i].CodeLeng <> 0 THEN BEGIN
          WRITE( o, '  ', SegName[i] ) ;
          WITH DiskInfo[i] DO BEGIN
            WRITE( o, CodeAddr:6 ) ;
            WRITE( o, CodeLeng DIV 2:7 ) ;
            END ;
          WITH SegInfo[i] DO BEGIN
            WRITE( o, '  ' ) ;
            CASE MajorVersion OF 
              Unknown  : WRITE( o, 'Volition' ) ;
              II       : WRITE( o, 'II.0    ' ) ;
              II_1     : WRITE( o, 'II.1    ' ) ;
              III      : WRITE( o, 'III.0   ' )
              END ; { case }
            IF MajorVersion <> Unknown THEN BEGIN
              WRITE( o, '  ' ) ;
              CASE MType OF
                UnDefined  : WRITE( o, 'Unknown' ) ;
                PCodeMost  : WRITE( o, 'PCode+ ' ) ;
                PCodeLeast : WRITE( o, 'PCode- ' ) ;
                PDP11      : WRITE( o, 'PDP-11 ' ) ;
                M8080      : WRITE( o, '8080   ' ) ;
                Z80        : WRITE( o, 'Z80    ' ) ;
                GA440      : WRITE( o, 'GA440  ' ) ;
                M6502      : WRITE( o, '6502   ' ) ;
                M6800      : WRITE( o, '6800   ' ) ;
                TI990      : WRITE( o, 'TI990  ' ) ;
                END ; { case }
              WRITE( o, '  ' ) ;
              CASE SegMisc.SegType[i] OF
                Linked           : WRITE( o, 'Linked excutable  ' ) ;
                HostSeg          : WRITE( o, 'Unlinked host     ' ) ;
                SegProc          : WRITE( o, 'Segment procedure ' ) ;
                UnitSeg          : WRITE( o, 'Regular unit      ' ) ;
                SeprtSeg         : WRITE( o, 'Separate procedure' ) ;
                Unlinked_Intrins : WRITE( o, 'Unlinked intrinsic' ) ;
                Linked_Intrinsic : WRITE( o, 'Linked intrinsic  ' ) ;
                DataSeg          : WRITE( o, 'Data segment      ' ) ;
                END ; { case }
              WRITE( o, '  ' ) ;
              WRITE( o, SegNum:3, ' ' ) ;
              WRITE( o, '  ' ) ;
              IF SegMisc.SegType[i] IN
                 [ UnitSeg, UnLinkedIntrins, LinkedIntrins ] THEN
                WRITE( o, SegText[i]:4 ) ;
              END ; { if majorversion <> volition }
            END ; { with seginfo }
          END ; { if }
        WRITELN( o ) ;
        END ; { for }
      
      WRITE( o, 'Intrinsic segments required: ' ) ;
      FOR i := 0 TO MaxSeg DO BEGIN
        IF i IN IntSegSet THEN BEGIN
          WRITE( o, i:3 ) ;
          IntrinsNeeded := TRUE
          END ; { if }
        END ; { for }
      IF IntrinsNeeded = FALSE THEN
        WRITE( o, ' None' ) ;
      WRITELN( o ) 
      
      END ; { with segdic, dict }
      
    END { MapUCSD } ;
  
  
  PROCEDURE MapSofTech 
    ( VAR SegDic    : SegDicRec ;
          SegDicNum : INTEGER ;
          BlockNum  : INTEGER ) ;
  
    CONST
      { machine types kludge }
      xPsuedo   =  0 ;
      x6809     =  1 ;
      xPDP11    =  2 ;
      x8080     =  3 ;
      xZ80      =  4 ;
      xGA440    =  5 ;
      x6502     =  6 ;
      x6800     =  7 ;
      x9900     =  8 ;
      x8086     =  9 ;
      xZ8000    = 10 ;
      x68000    = 11 ;
    
    VAR
      i         : INTEGER ;
      j         : SegRange ;
      BadSegs   : SegSet ;
      TooBig    : BOOLEAN ;

  
    PROCEDURE PutFamilyInfo 
      (     Index : INTEGER ) ;
    
    { uses SegDic and the file o globally }
    
    BEGIN { PutFamilyInfo }
      
      WITH SegDic, Dict, SegFamily[Index] DO BEGIN
        CASE SegMisc.xSegMisc[Index].SegType OF
          xUnitSeg, ProgSeg: BEGIN
            WRITE( o, ' ' ) ;
            WRITE( o, DataSize:5 ) ;
            WRITE( o, ' ' ) ;
            WRITE( o, SegRefs:5 ) ;
            WRITE( o, ' ' ) ;
            WRITE( o, MaxSegNum:5 ) ;
            IF SegMisc.xSegMisc[Index].SegType = xUnitSeg THEN BEGIN
              WRITE( o, ' ' ) ;
              WRITE( o, SegText[Index]:5 ) ;
              WRITE( o, ' ' ) ;
              WRITE( o, TextSize:5 ) ;
              END
            ELSE
              WRITE( o, '':12 ) ;
            END ;
          xSeprtSeg, ProcSeg: BEGIN
            WRITE( o, ' ' ) ;
            WRITE( o, '':11, ProgName ) ;
            END ;
          NoSeg: BEGIN
            END ;
          END ; { case }
        END

      END { PutFamilyInfo } ;
      
      
    PROCEDURE PutOtherInfo ;
    
    { uses SegDic, output file o globally }
    
      VAR
        i       : INTEGER ;
        
    BEGIN { PutOtherInfo }
      
      WITH SegDic, Dict DO BEGIN
        WRITE( o, 'pCode version ' ) ;
        CASE SegInfo[0].MajorVersion OF 
          Unknown     : WRITE( o, 'unknown' ) ;
          II,II_1,III : WRITE( o, '<<bad>>' ) ;
          IV          : WRITE( o, 'IV' ) ;
          V,VI,VII    : WRITE( o, 'unknown' ) ;
          END ; { case }
        WRITE( o, '.  ' ) ;
        IF NextDict = 0 THEN
          WRITELN( o, 'Last dictionary segment in chain.' ) 
        ELSE
          WRITELN( o, 'Next dictionary segment is at block #', NextDict, '.' ) ;
        WRITELN( o, '[', CopyNote, ']' ) 
        END ;
      IF TooBig THEN BEGIN
        WRITE( o, '*** ERROR: The following segments are too large: ' ) ;
        FOR i := 0 TO MaxDicSeg DO 
          IF i IN BadSegs THEN
            WRITE( o, i, ' ' ) ;
        WRITELN( o )
        END 
      
      END { PutOtherInfo } ;
      
      
  BEGIN { MapSofTech }
    
    BadSegs := [] ;
    TooBig  := FALSE ;
      
    IF ReadSegDic( f, BlockNum, SegDic ) THEN BEGIN
      WRITE  ( o, ', segment dictionary record #', SegDicNum ) ;
      WRITELN( o, ',  block #', BlockNum ) ;
      WRITE( o, 'Seg Name      Addr    Len  Mach.  Kind    ' ) ;
      WRITE( o, 'Lnk Rel ' ) ;
      WRITE( o, ' Data  Refs MxSeg TxAdr TxLen' ) ;
      WRITELN( o ) ;
      FOR i := 0 TO MaxDicSeg DO BEGIN
        WRITE( o, i:3 ) ;
        IF SegDic.Dict.DiskInfo[i].CodeLeng <> 0 THEN WITH SegDic, Dict DO BEGIN
          WRITE( o, ' ', SegName[i] ) ;
          WITH DiskInfo[i] DO BEGIN
            WRITE( o, CodeAddr:6 ) ; 
            WRITE( o, CodeLeng:7 ) ;
            IF CodeLeng > 8191 THEN BEGIN
              BadSegs := BadSegs + [ i ] ;
              TooBig  := TRUE
              END
            END ;
          WITH SegInfo[i] DO BEGIN
            WRITE( o, '  ' ) ;
            IF ORD(MType) = xPsuedo THEN BEGIN
              WRITE( o, 'pCode' ) ;
              IF Flipped THEN 
                WRITE( o, '~' )
              ELSE
                WRITE( o, ' ' )
              END
            ELSE CASE ORD(MType) OF
              x6809 : WRITE( o, '6809  ' ) ;
              xPDP11: WRITE( o, 'PDP11 ' ) ;
              x8080 : WRITE( o, '8080  ' ) ;
              xZ80  : WRITE( o, 'Z80   ' ) ;
              xGA440: WRITE( o, 'GA440 ' ) ;
              x6502 : WRITE( o, '6502  ' ) ;
              x6800 : WRITE( o, '6800  ' ) ;
              x9900 : WRITE( o, '9900  ' ) ;
              x8086 : WRITE( o, '8086  ' ) ;
              xZ8000: WRITE( o, 'Z8000 ' ) ;
              x68000: WRITE( o, '68000 ' ) ;
              END ; { case }
            WRITE( o, ' ' ) ;
            CASE SegMisc.xSegMisc[i].SegType OF
              NoSeg     : WRITE( o, '<empty> ' ) ;
              ProgSeg   : WRITE( o, 'Program ' ) ;
              xUnitSeg  : WRITE( o, 'Unit    ' ) ;
              ProcSeg   : WRITE( o, 'Segment ' ) ;
              xSeprtSeg : WRITE( o, 'Separate' ) ;
              END ; { case }
            END ; { with seginfo }
          WRITE( o, ' ' ) ;
          WITH SegMisc, xSegMisc[i] DO BEGIN
            IF HasLinkInfo THEN
              WRITE( o, ' T' )
            ELSE
              WRITE( o, ' F' ) ;
            WRITE( o, ' ' ) ;
            IF Relocatable THEN
              WRITE( o, '  T' )
            ELSE
              WRITE( o, '  F' ) ;
            END ;
          PutFamilyInfo( i ) ;
          END ; (* if, with segdic *)
        WRITELN( o ) ;
        END ; (* for *)
      PutOtherInfo ;
      END
    ELSE BEGIN
      { ReadSegDic has already written err msg, so set NextDict to quit }
      SegDic.Dict.NextDict := 0
      END ;
    
    END { MapSofTech } ;
    

BEGIN { Map }

  SegDicNum := 0 ;
  BlockNum  := 0 ;
  
  IF ReadSegDic( f, BlockNum, SegDic ) THEN BEGIN
    IF SegDic.Dict.SegInfo[0].MajorVersion < IV THEN BEGIN
      IF ConsoleOutput THEN
        CrtControl( ClrToEoS ) 
      ELSE
        Page( o ) ;
      WRITELN( o ) ;
      WRITELN( o, 'File: ', CFileName ) ;
      MapUCSD( SegDic )
      END 
    ELSE BEGIN
      REPEAT
        IF ConsoleOutput THEN
          CrtControl( ClrToEoS ) 
        ELSE 
          Page( o ) ;
        WRITELN( o ) ;
        WRITE( o, 'File: ', CFileName ) ;
        MapSofTech( SegDic, SegDicNum, BlockNum ) ;
        BlockNum  := SegDic.Dict.NextDict ;
        SegDicNum := SUCC( SegDicNum ) ;
        IF (OFileName = 'CONSOLE:') AND (BlockNum <> 0) THEN
          SpaceWait ;
        UNTIL BlockNum = 0
      END
    END
  ELSE BEGIN
    { ReadSegDic has already written error message, so do nothing! }
    END ;
  
  END { Map } ;
 
 
 BEGIN
   
   Initialize ;
   WHILE Menu = TRUE DO 
     Map( f ) ;
   CleanUp
 
   END.

========================================================================================
DOCUMENT :usus Folder:VOL18:segmasher.text
========================================================================================

program segmasher;

{This program tests the speed of segment swaps.  It was originally written
to test the swapping ability of the IV.1 LSI-11 extended memory p-system vs.
the non-extended memory implementation of IV.0.

     The program causes successive segment swaps.  If the value of "selector" 
is set to 2, then the segments are very small, and can co-reside in the IV.0 
code pool.  They can be called without causing stack or heap faults and should
present very little overhead.

     If the value of "selector" is set to be very large, 8165 in this case, 
the compiler generates a huge jump table, and the segment will very large.  In 
this case each segment is nearly 16k bytes, the maximum allowed under the LSI-
11 IV.1 implementation.  Each of the two segments has this size.  However, 
depending on how much memory you have, they may still be able to co-reside in 
the code pool.  If this is the case, there will be very little difference in 
swapping speed.  

     The global variable "buffer" is designed to eat up a lot of stack to 
cause the system to be forced to cause segment loads of each segment.  When 
this happens, the segment swaps in IV.0 will be quite slow, depending on the 
speed of your disks.  To cause the segments to swap, set "stack_filler" so 
that the varavail displayed is between about 9000 and 15,000 words, or enough 
room for one, but not both of the segments.

     Version IV.1 swaps from extended memory, so its swaps should be much 
quicker.  The swapping speed should not be dependant on the size of the 
segments.  The results I got on an 11/23 with IV.0 and IV.1 are shown below.

                IV.0 hard disk          IV.0 floppy             IV.1

small segment     0.8 ms/swap           0.8 ms/swap             1.7 ms/swap
large segment   190   ms/swap        2000   ms/swap             1.7 ms/swap

    Swapping the small segment under IV.1 is slower than IV.0 as the system 
must massage some memory mapping registers to access the new segment in 
extended memory.  However, if IV.0 must do a disk swap, IV.1 has a decided 
advantage.  The disk swaps from floppy disk are so slow as not only is a seek 
performed, but 16k of code, or about 64 sectors, must be loaded.

     george w. schreyer}

const stack_filler = 20000;
      selector     = 8165;
      
var i : integer;
    num_swaps : integer;
    buff : packed array [ 0..stack_filler ] of char;

segment procedure big_seg1;
var i : integer;
begin
   case i of
        1 : ;
      selector : ;
   end;
end;

segment procedure big_seg2;
var i : integer;
begin
   case i of
        1 : ;
      selector : ;
   end;
end;

begin
   writeln ( varavail ( 'segmasher' ) );
   write ( 'number of swaps ? ' );
   readln ( num_swaps );
   write ( chr ( 7 ) );
   for i := 1 to ( num_swaps div 2 ) do
      begin
         bigseg1;
         bigseg2;
      end;
  write ( chr ( 7 ) );
end.


========================================================================================
DOCUMENT :usus Folder:VOL18:sieve.text
========================================================================================

(* Eratosthenes Sieve Prime Number Program in PASCAL *)
PROGRAM PRIMES;

{This is the original version from Byte, with only the modifications necessary
to allow it to compile under UCSD and a bell at the end.  
If you choose to report your results, 
PLEASE RUN IT AS IS!  It is a known fact that the speed of this version
can be significantly improved by turning off range checking and re-ordering
the declarations of the variables,  but this is the version which has been used
most and we desire consistantcy.  

Start timing by typing <cr> and stop at the bell.  gws}

{The results of this version on several systems have been reported on MUSUS.

System          UCSD version    Time (sec)
------          ------------    ----------

Sage II         IV.1            57     (68000 at 8 MHz)
WD uEngine      III.0           59     (fillchar is so slow on uE)

LSI-11/23       IV.01           92-122 (depends on memory speed)
LSI-11/23       II.0            105    (98 seconds under IV.01)
LSI-11/23       IV.1            107    (non-extended memory)
LSI-11/23       IV.1            128    (extended memory)

NEC APC         IV.1            144     8086 at 4.9 Mhz  extended memory

JONOS           IV.03 ?         162    (pretty good for a 4 MHz Z-80A)
NorthStar       I.5             183    (Z-80 at 4 MHz)
OSI C8P-DF      II.0  ?         197    (6502 at 2 MHz)
H-89            II.0            200    (4 MHz Z-80A)
LSI-11/2        IV.0            202
IBM PC          IV.03           203    (4.77 MHz 8088)
LSI-11/2        II.0            220

Apple ][        II.1            390    (1 MHz 6502)
H-89            II.0            455    (2 MHz Z-80)

}
CONST
 SIZE = 8190;

VAR
 FLAGS : ARRAY [0..SIZE] OF BOOLEAN;
 I,PRIME,K,COUNT,ITER : INTEGER;

BEGIN
WRITE('10 iterations, <cr> to start');
readln;
FOR ITER := 1 TO 10 DO BEGIN
       COUNT := 0;
       FILLCHAR(FLAGS,SIZEOF(FLAGS),CHR(1));
       FOR I := 0 TO SIZE DO
               IF FLAGS[I] THEN BEGIN
                       PRIME := I+I+3;
                       K := I + PRIME;
                       WHILE K <= SIZE DO BEGIN
                               FLAGS[K] := FALSE;
                               K := K + PRIME
                               END;
                       COUNT := COUNT + 1;
                       (* WRITELN(PRIME) *)
                       END;
       END;
WRITELN( chr ( 7 ),COUNT,' primes')
END.



========================================================================================
DOCUMENT :usus Folder:VOL18:sort2.text
========================================================================================

PROGRAM Sort;                                                                          
 TYPE lrec = RECORD
              stpart : STRING;
              lpart  : ^lrec;
             END;
 VAR optr, tptr, first, ptr : ^lrec;
     ifile, ofile : TEXT; 
     nlines,temp : INTEGER; 
     added : BOOLEAN;
     space,key1,key2,key3 : STRING;
     infile, outfile : STRING[30];  
     b1,l1,o1,b2,l2,o2,b3,l3,o3 : INTEGER;
 
 FUNCTION Atrectoaddat : BOOLEAN;
  VAR intb : BOOLEAN;
      tkey1,tkey2,tkey3 : STRING; 
  BEGIN 
   WITH tptr^ DO   
    BEGIN
     tkey1 := COPY(CONCAT(stpart,space),b1,l1);    
     tkey2 := COPY(CONCAT(stpart,space),b2,l2);  
     tkey3 := COPY(CONCAT(stpart,space),b3,l3);
    END;   
   intb := FALSE;      
   CASE (o1*4) + (o2*2) + o3 OF        
    0 : IF      tkey1<key1  THEN intb := TRUE              
       ELSE IF (tkey1=key1) AND             
               (tkey2<key2) THEN intb := TRUE 
       ELSE IF (tkey1=key1) AND      
               (tkey2=key2) AND 
               (tkey3<key3) THEN intb := TRUE;    
    1 : IF      tkey1<key1  THEN intb := TRUE                 
       ELSE IF (tkey1=key1) AND  
               (tkey2<key2) THEN intb := TRUE           
       ELSE IF (tkey1=key1) AND
               (tkey2=key2) AND       
               (tkey3>key3) THEN intb := TRUE;                
    2 : IF      tkey1<key1  THEN intb := TRUE            
       ELSE IF (tkey1=key1) AND 
               (tkey2>key2) THEN intb := TRUE 
       ELSE IF (tkey1=key1) AND
               (tkey2=key2) AND 
               (tkey3<key3) THEN intb := TRUE;    
    3 : IF      tkey1<key1  THEN intb := TRUE             
       ELSE IF (tkey1=key1) AND 
               (tkey2>key2) THEN intb := TRUE 
       ELSE IF (tkey1=key1) AND
               (tkey2=key2) AND 
               (tkey3>key3) THEN intb := TRUE;    
    4 : IF      tkey1>key1  THEN intb := TRUE             
       ELSE IF (tkey1=key1) AND 
               (tkey2<key2) THEN intb := TRUE     
       ELSE IF (tkey1=key1) AND
               (tkey2=key2) AND 
               (tkey3<key3) THEN intb := TRUE;         
    5 : IF      tkey1>key1  THEN intb := TRUE             
       ELSE IF (tkey1=key1) AND   
               (tkey2<key2) THEN intb := TRUE 
       ELSE IF (tkey1=key1) AND
               (tkey2=key2) AND 
               (tkey3>key3) THEN intb := TRUE;    
    6 : IF      tkey1>key1  THEN intb := TRUE             
       ELSE IF (tkey1=key1) AND             
               (tkey2>key2) THEN intb := TRUE 
       ELSE IF (tkey1=key1) AND
               (tkey2=key2) AND     
               (tkey3<key3) THEN intb := TRUE;    
    7 : IF      tkey1>key1  THEN intb := TRUE             
       ELSE IF (tkey1=key1) AND 
               (tkey2>key2) THEN intb := TRUE 
       ELSE IF (tkey1=key1) AND      
               (tkey2=key2) AND 
               (tkey3>key3) THEN intb := TRUE;    
    END; 
    Atrectoaddat := intb;          
  END;          
     
 PROCEDURE Putinlinkedlist;
  BEGIN
   IF tptr<>first THEN   
    BEGIN
     optr^.lpart := ptr;
     ptr^.lpart  := tptr;
    END
   ELSE
    BEGIN
     ptr^.lpart := first;
     first := ptr;      
    END;
  added := TRUE;
  END;    
 
 PROCEDURE Getitandputitinlinkedlist;             
  BEGIN
   NEW(ptr);
   READLN(ifile,ptr^.stpart); 
   WITH ptr^ DO           
    BEGIN
     key1 := COPY(CONCAT(stpart,space),b1,l1);    
     key2 := COPY(CONCAT(stpart,space),b2,l2);     
     key3 := COPY(CONCAT(stpart,space),b3,l3);  
    END;
   tptr := first; 
   optr := NIL;   
   added := FALSE;
   WHILE (NOT added) AND (tptr<>NIL) DO 
    IF Atrectoaddat 
    THEN Putinlinkedlist       
    ELSE 
     BEGIN
      optr := tptr; 
      tptr := tptr^.lpart;  
     END;  
    IF NOT added THEN
    BEGIN          
     optr^.lpart := ptr;    
     ptr^.lpart  := NIL;
    END
   END;    
  
 BEGIN
  first := NIL;
  WRITE('enter input file name ---->');
  READLN(infile);  
  WRITE('enter output file name --->');    
  READLN(outfile);
  RESET(ifile,infile);
  REWRITE(ofile,outfile);
  WRITELN;
  WRITELN;
  WRITELN('enter sort specification: ');
  WRITELN;  
  WRITE('beginnig byte of sortkey 1 --->');  
  READLN(b1);
  WRITE('length of sortkey1 ----------->');
  READLN(l1);
  WRITE('order (0=asc, 1=desc) -------->'); 
  READLN(o1); 
  WRITELN; 
  WRITE('beginnig byte of sortkey 2 --->'); 
  READLN(b2);
  WRITE('length of sortkey2 ----------->');
  READLN(l2);
  WRITE('order (0=asc, 1=desc) -------->');
  READLN(o2);
  WRITELN; 
  WRITE('beginnig byte of sortkey 3 --->'); 
  READLN(b3);
  WRITE('length of sortkey3 ----------->');
  READLN(l3);
  WRITE('order (0=asc, 1=desc) -------->');
  READLN(o3);
  WRITELN;
  WRITELN;
  WRITE('enter the number of lines for header info --->');
  READLN(nlines);
  NEW(ptr);   
  FOR temp := 1 TO nlines DO 
   BEGIN
    READLN(ifile,ptr^.stpart);
    WRITELN(ofile,ptr^.stpart);
   END;
  READLN(ifile,ptr^.stpart); 
  space := '';
  FOR temp := 1 TO 8 DO space := CONCAT(space,'          '); 
  first := ptr;
  ptr^.lpart := NIL;     
  WHILE NOT EOF(ifile) DO Getitandputitinlinkedlist;     
  ptr := first;
  WHILE ptr <> NIL DO
   BEGIN
    WRITELN(ofile,ptr^.stpart);
    ptr := ptr^.lpart;
   END;
  CLOSE(ofile,lock);
  CLOSE(ifile); 
 END.



========================================================================================
DOCUMENT :usus Folder:VOL18:sortunit.text
========================================================================================

UNIT Sortunit;     
 
 INTERFACE
  VAR disk : FILE; 
  
  PROCEDURE pSort( fname : STRING;     
                   recsiz,numrecs,
                   pos1,len1,ord1,
                   pos2,len2,ord2,
                   pos3,len3,ord3  : INTEGER);
                   
  
  IMPLEMENTATION
  
  PROCEDURE pSort; 
  TYPE lptr = ^lrec;  
       lrec = RECORD   
               key1,key2,key3 : STRING[30];  
               recfrom        : INTEGER;
               link           : lptr;      
              END;
    VAR linkedrec                   : lrec;
        first,ptr,tptr,hptr         : lptr;  
        currentblock,rectoaddto,recat,temp,rnum  : INTEGER;     
        heaptr                      : ^INTEGER;
        frecord,tfrecord            : PACKED ARRAY[1..512] OF CHAR;
      tdblock : PACKED ARRAY[1..512] OF CHAR;   
       
      ch : CHAR;
      
  
  PROCEDURE Getlogrec(recnumber : INTEGER); 
   VAR temp1,temp2,posinblock : INTEGER;  
   
   BEGIN   
    WRITE('+');
    temp := currentblock;   
    currentblock := 0;
    temp1 := 0;temp2 := 0;                              
    WHILE temp1 < recnumber DO 
     BEGIN
      temp2 := temp2 + recsiz;
      IF temp2 >= 512 THEN BEGIN 
                           currentblock := currentblock + 1;
                           temp2 := temp2 - 512;
                          END;
      temp1 := temp1 + 1;
     END;
    posinblock := temp2;  
    IF temp<>currentblock                                         
     THEN
       temp := BLOCKREAD(disk,tdblock,1,currentblock);                                             
    IF posinblock + recsiz <= 512 THEN               
     BEGIN
      FOR temp := 1 TO recsiz DO  
       frecord[temp] := tdblock[posinblock+temp];     
     END 
    ELSE
     BEGIN
      FOR temp := posinblock + 1 TO 512 DO
       frecord[temp-posinblock] := tdblock[temp];   
       currentblock := currentblock + 1;
       temp := BLOCKREAD(disk,tdblock,1,currentblock);                                             
      FOR temp := 1 TO posinblock + recsiz - 512 DO  
       frecord[temp+512-posinblock] := tdblock[temp];     
     END;  
  END;

  PROCEDURE Putlogrec(recnumber: INTEGER);  
   VAR temp1,temp2,posinblock : INTEGER;            
   BEGIN            
    WRITE('-');
    temp := currentblock;              
    currentblock := 0;
    temp1 := 0;temp2 := 0;  
    WHILE temp1 < recnumber DO 
     BEGIN
      temp2 := temp2 + recsiz;
      IF temp2 >= 512 THEN BEGIN 
                           currentblock := currentblock + 1;
                           temp2 := temp2 - 512;
                          END;
      temp1 := temp1 + 1;
     END;
    posinblock := temp2;  
    IF temp<>currentblock   
     THEN temp := BLOCKREAD(disk,tdblock,1,currentblock);                        
    IF posinblock + recsiz <= 512 THEN                 
     BEGIN  
      FOR temp := 1 TO recsiz DO  
       tdblock[posinblock+temp] := frecord[temp];           
      temp := BLOCKWRITE(disk,tdblock,1,currentblock);     
     END  
    ELSE
     BEGIN
      FOR temp := posinblock + 1 TO 512 DO    
        tdblock[temp] := frecord[temp-posinblock];    
      temp := BLOCKWRITE(disk,tdblock,1,currentblock);
      currentblock := currentblock + 1;
      temp := BLOCKREAD(disk,tdblock,1,currentblock);         
      FOR temp := 1 TO posinblock + recsiz - 512 DO  
       tdblock[temp] := frecord[temp+512-posinblock] ;      
      temp := BLOCKWRITE(disk,tdblock,1,currentblock);        
     END;  
   END;      
   
  PROCEDURE Getkeys(recnumber : INTEGER);            
   BEGIN      
    Getlogrec(recnumber);      
    NEW(ptr);    
    WITH ptr^ DO
     BEGIN
      key1 := ''; 
      key2 := '';
      key3 := '';
      FOR temp := 1 TO len1 DO 
       BEGIN
        key1 := CONCAT(key1,' '); 
        key1[temp] := frecord[pos1+temp];
       END;
      FOR temp := 1 TO len2 DO 
       BEGIN
        key2 := CONCAT(key2,' ');  
        key2[temp] := frecord[pos2+temp];
       END;
      FOR temp := 1 TO len3 DO 
       BEGIN
        key3 := CONCAT(key3,' ');  
        key3[temp] := frecord[pos3+temp];
       END;
      recfrom := recnumber;                                
     END;
   END;  
   
    FUNCTION Atrecbelowtheonetobeadded: BOOLEAN;      
     VAR intb : BOOLEAN;  
     BEGIN
      intb := FALSE;  
      CASE (ord1*4) + (ord2*2) + ord3 OF    
       0 : IF      ptr^.key1<tptr^.key1  THEN intb := TRUE              
          ELSE IF (ptr^.key1=tptr^.key1) AND 
                  (ptr^.key2<tptr^.key2) THEN intb := TRUE 
          ELSE IF (ptr^.key1=tptr^.key1) AND    
                  (ptr^.key2=tptr^.key2) AND 
                  (ptr^.key3<tptr^.key3) THEN intb := TRUE;    
       1 : IF      ptr^.key1<tptr^.key1  THEN intb := TRUE                 
          ELSE IF (ptr^.key1=tptr^.key1) AND 
                  (ptr^.key2<tptr^.key2) THEN intb := TRUE 
          ELSE IF (ptr^.key1=tptr^.key1) AND
                  (ptr^.key2=tptr^.key2) AND 
                  (ptr^.key3>tptr^.key3) THEN intb := TRUE;    
       2 : IF      ptr^.key1<tptr^.key1  THEN intb := TRUE            
          ELSE IF (ptr^.key1=tptr^.key1) AND 
                  (ptr^.key2>tptr^.key2) THEN intb := TRUE 
          ELSE IF (ptr^.key1=tptr^.key1) AND
                  (ptr^.key2=tptr^.key2) AND 
                  (ptr^.key3<tptr^.key3) THEN intb := TRUE;    
       3 : IF      ptr^.key1<tptr^.key1  THEN intb := TRUE             
          ELSE IF (ptr^.key1=tptr^.key1) AND 
                  (ptr^.key2>tptr^.key2) THEN intb := TRUE 
          ELSE IF (ptr^.key1=tptr^.key1) AND
                  (ptr^.key2=tptr^.key2) AND 
                  (ptr^.key3>tptr^.key3) THEN intb := TRUE;    
       4 : IF      ptr^.key1>tptr^.key1  THEN intb := TRUE             
          ELSE IF (ptr^.key1=tptr^.key1) AND 
                  (ptr^.key2<tptr^.key2) THEN intb := TRUE     
          ELSE IF (ptr^.key1=tptr^.key1) AND
                  (ptr^.key2=tptr^.key2) AND 
                  (ptr^.key3<tptr^.key3) THEN intb := TRUE;         
       5 : IF      ptr^.key1>tptr^.key1  THEN intb := TRUE             
          ELSE IF (ptr^.key1=tptr^.key1) AND 
                  (ptr^.key2<tptr^.key2) THEN intb := TRUE 
          ELSE IF (ptr^.key1=tptr^.key1) AND
                  (ptr^.key2=tptr^.key2) AND 
                  (ptr^.key3>tptr^.key3) THEN intb := TRUE;    
       6 : IF      ptr^.key1>tptr^.key1  THEN intb := TRUE             
          ELSE IF (ptr^.key1=tptr^.key1) AND 
                  (ptr^.key2>tptr^.key2) THEN intb := TRUE 
          ELSE IF (ptr^.key1=tptr^.key1) AND
                  (ptr^.key2=tptr^.key2) AND 
                  (ptr^.key3<tptr^.key3) THEN intb := TRUE;    
       7 : IF      ptr^.key1>tptr^.key1  THEN intb := TRUE             
          ELSE IF (ptr^.key1=tptr^.key1) AND 
                  (ptr^.key2>tptr^.key2) THEN intb := TRUE 
          ELSE IF (ptr^.key1=tptr^.key1) AND      
                  (ptr^.key2=tptr^.key2) AND 
                  (ptr^.key3>tptr^.key3) THEN intb := TRUE;    
       END; 
       Atrecbelowtheonetobeadded := intb;        
     END;        
     
  PROCEDURE Addtolinkedlist;          
   VAR intb : BOOLEAN;
   BEGIN        
    tptr := first; intb := TRUE;     
    WHILE (tptr<>NIL) AND intb DO    
    IF Atrecbelowtheonetobeadded THEN intb := FALSE                                     
    ELSE 
     BEGIN
      hptr := tptr;  
      tptr := tptr^.link;    
     END;
    ptr^.link := tptr;  
    IF tptr = first THEN first := ptr
                    ELSE hptr^.link := ptr;
    tptr := first;
   END;     
   
  FUNCTION Inrightplace : BOOLEAN;        
   VAR intb : BOOLEAN;
   BEGIN
    intb := TRUE ;   
    IF ptr^.recfrom <> rectoaddto THEN intb := FALSE; 
    Inrightplace := intb;   
   END;
   
  PROCEDURE Puttptratlinkedrecthatwillgototemp(temp : INTEGER);
   VAR temp1 : INTEGER;        
   BEGIN  
    tptr := first; 
    temp1 := 0;
    WHILE (tptr<>NIL) AND (temp1<temp) DO    
     BEGIN
      temp1 := temp1 + 1;  
      tptr := tptr^.link;  
     END;
   END;   
   
  PROCEDURE Putinrightplace;        
   VAR temp2,temp  : INTEGER;  
   BEGIN 
    Getlogrec(rectoaddto);      
    tfrecord := frecord; 
    temp := rectoaddto;  
    tptr := ptr;  
    WHILE tptr^.recfrom<>rectoaddto DO          
     BEGIN
      Getlogrec(tptr^.recfrom);  
      Putlogrec(temp);        
      temp2 := tptr^.recfrom;     
      tptr^.recfrom := temp; 
      temp := temp2; 
      Puttptratlinkedrecthatwillgototemp(temp);     
     END; 
    tptr^.recfrom := temp;
    frecord := tfrecord;      
    Putlogrec(temp);  
   END;   
   
  BEGIN (* Sort *)  
   numrecs := numrecs - 1;
   pos1 := pos1 - 1; pos2 := pos2 - 1; pos3 :=pos3 - 1;  
   temp := 0; 
   currentblock := 32700;
   RESET(disk,fname);     
   MARK(heaptr);
   first := nil;
   FOR recat := 0 TO numrecs DO          
    BEGIN
     Getkeys(recat); 
     Addtolinkedlist;
    END;
   
   ptr := first; rectoaddto := 0;       
   
   REPEAT  
    IF NOT Inrightplace THEN Putinrightplace; 
    ptr := ptr^.link;   
    rectoaddto := rectoaddto + 1;
   UNTIL ptr=nil;
    
   RELEASE(Heaptr);            
   CLOSE(disk,lock); 
  END;
   
 END.
   
   
   

========================================================================================
DOCUMENT :usus Folder:VOL18:stars.text
========================================================================================

program stars;

     { This is a simple test of console I/O speed with the slowest I/O method,
single character writes.  1000 characters are written to the console, each
with a separate WRITE statement and its attendant system overhead.  The actual
time it takes to write the character to a serial port at 9600 baud is about 1
ms (0.5 ms for 19,200 baud) and the loop overhead time will be processor
dependant, but usually between about 0.05 ms for a Sage to about 0.4 ms for an
Apple.

     You will probably find that the time necessary to execute this test is 
much longer than you would expect.  For example, the loop overhead of my LSI-
11/23 is 0.14 ms and the I/O overhead is 0.5 ms (19.2k baud).  One would 
expect that the test would take 0.64 ms/loop to complete.  Not so under IV.1,
with extended memory the test takes 6.2 ms/loop! Without extended memory the
test runs at 4 ms/loop.  IV.0 takes 2.3 ms/loop. II.0 takes 1.5 ms/loop.

     Using the UNITWRITE, version II.0 takes 0.8 ms/loop, much closer to what
you would expect as UNIT I/O has very little system overhead.  Version IV.0
takes 0.9 ms/loop, and version IV.1 (with extended memory and probably memory 
management overhead) takes 1.6 ms/loop.  IV.1 without extended memory takes
1.2 ms/loop (IV.1 is about 15% slower than IV.0 anyway).

     As you may find, different versions of software can affect I/O speed as 
much as different hardware!

     - gws
     }

var i,j : integer;
    ch : packed array [ 0..1 ] of char;
begin
ch [ 0 ] := '*';
write ( chr ( 7 ) );
for i := 1 to 20 do
  begin
     for j := 1 to 49 do write ( '*' ) 
     {unitwrite ( 1, ch [ 0 ], 1 )};
     writeln;
  end; 
write ( chr ( 7 ) ); 
end.


========================================================================================
DOCUMENT :usus Folder:VOL18:tele.text
========================================================================================

PROGRAM Telephone;                                                                      
 TYPE Telrec = RECORD  
                date : STRING[6];
                time : STRING[4];
                wfrom: STRING[15]; 
                whoto: STRING[15];
                who  : STRING[5];  
                mins : INTEGER;
                cost : REAL;
                mode : STRING[1];
                END;
                
 VAR telfile : FILE OF Telrec;
     numrecs : INTEGER; 
     ch      : CHAR; 
     
 PROCEDURE Clear;    FORWARD;
 PROCEDURE Wnewnrecs; FORWARD;
 
 
 SEGMENT PROCEDURE Initfile; 
  BEGIN
   Clear;
   WRITE('are you sure you wish to initialize the file?');
   READ(ch);
   IF ch IN ['Y','y'] THEN
    BEGIN
     telfile^.whoto := '#2:';
     telfile^.mins := 0;
     SEEK(telfile,0); 
     PUT(telfile);
     numrecs := 0;
    END;  
  END; 
  
 SEGMENT PROCEDURE Sortfile;
  VAR temp1,temp2 : INTEGER;
      trec1,trec2 : telrec; 
  
  FUNCTION Necessary: BOOLEAN;
   BEGIN
    IF (trec2.date>trec1.date) OR  
      
      ((trec2.date=trec1.date) AND (trec2.time>trec1.time)) OR   
      
      ((trec2.date=trec1.date) AND (trec2.time=trec1.time) AND  
                  (trec2.wfrom>trec1.wfrom)) OR                 
      
      ((trec2.date=trec1.date) AND (trec2.time=trec1.time) AND 
      (trec2.wfrom=trec1.wfrom) AND (trec2.whoto>trec1.whoto)) 
      
      THEN Necessary := TRUE ELSE Necessary := FALSE;  
   END;
   
   
  BEGIN        
   WRITELN;
   WRITE('Sorting '); 
   FOR temp1 := 2 TO numrecs DO 
    BEGIN
     WRITE('.');
     SEEK(telfile,temp1);
     GET(telfile);
     trec1 := telfile^;
     
     temp2 := temp1 - 1; 
     SEEK(telfile,temp2);
     GET(telfile);
     trec2 := telfile^; 
     
     WHILE Necessary and (temp2>0) DO      
      BEGIN
       telfile^ := trec2;
       SEEK(telfile,temp2 + 1);
       PUT(telfile);
       temp2 := temp2 - 1;
       IF temp2 > 0 THEN 
        BEGIN
         SEEK(telfile,temp2);
         GET(telfile);
         trec2 := telfile^; 
        END
      END; 
     
     telfile^ := trec1;
     SEEK(telfile,temp2 + 1);
     PUT(telfile);
    END;         
  END; 
     
 
 SEGMENT PROCEDURE Add; 
  BEGIN
   WITH telfile^ DO  
    BEGIN
     Clear; 
     {$I-}
     WRITELN('date (mmddyy) --->      <'); 
     WRITELN('time (hh:mm)  --->    <'); 
     WRITELN('who from      --->               <');  
     WRITELN('who to        --->               <');
     WRITELN('who           --->     <'); 
     WRITELN('number of mins -->');   
     WRITELN('cost          --->');
     WRITELN('mode          ---> <');
     GOTOXY(18,0);  
     READLN(date);
     GOTOXY(18,1);
     READLN(time);
     GOTOXY(18,2);
     READLN(wfrom); 
     GOTOXY(18,3); 
     READLN(whoto);
     GOTOXY(18,4);
     READLN(who);
     GOTOXY(18,5); 
     READLN(mins); 
     GOTOXY(18,6); 
     READLN(cost); 
     GOTOXY(18,7);
     READLN(mode); 
     {$I+}
    END; 
   numrecs := numrecs + 1;
   SEEK(telfile,numrecs);
   PUT(telfile);
   Wnewnrecs;
  END;   
  
 SEGMENT PROCEDURE Report;
  VAR ofname      : STRING; 
      ofile       : TEXT; 
      temp        : INTEGER; 
      mwild       : STRING[1];
      wwild       : STRING[5];
      dwild       : STRING[6];   
      fwild,twild : STRING[15];
      rmode       : CHAR;
      total       : REAL;
  
  PROCEDURE Getwilds;
   BEGIN
    Clear;
    WRITE('enter date wildcard --->');
    READLN(dwild);
    WRITE('enter from# wildcard --->');
    READLN(fwild);
    WRITE('enter to# wildcard  --->');           
    READLN(twild);
    WRITE('enter initials wildcard --->'); 
    READLN(wwild);
    WRITE('enter mode --->'); 
    READLN(mwild);
   END; 
   
  FUNCTION Wildok : BOOLEAN;
   VAR intb : BOOLEAN;
       temp : INTEGER;
   
   FUNCTION Min(a,b : INTEGER): INTEGER;  
    BEGIN
     IF a<b THEN Min := a ELSE Min := b;
    END;
   
   BEGIN 
    intb := TRUE; 
    WITH telfile^ DO
     BEGIN
      IF (LENGTH(fwild)>LENGTH(wfrom)) OR  
         (LENGTH(twild)>LENGTH(whoto)) OR
         (LENGTH(dwild)>LENGTH(date )) OR
         (LENGTH(wwild)>LENGTH(who  )) OR
         (LENGTH(mwild)>LENGTH(mode )) THEN intb := FALSE;
      
      FOR temp := 1 TO Min(LENGTH(fwild),LENGTH(wfrom)) DO    
       IF (fwild[temp]<>'?') AND (fwild[temp]<>wfrom[temp]) THEN intb := FALSE;
       
      FOR temp := 1 TO Min(LENGTH(twild),LENGTH(whoto)) DO  
       IF (twild[temp]<>'?') AND (twild[temp]<>whoto[temp]) THEN intb := FALSE;
       
      FOR temp := 1 TO Min(LENGTH(dwild),LENGTH(date)) DO  
       IF (dwild[temp]<>'?') AND (dwild[temp]<>date[temp]) THEN intb := FALSE;                 
       
      FOR temp := 1 TO Min(LENGTH(wwild),LENGTH(who)) DO
       IF (wwild[temp]<>'?') AND (wwild[temp]<>who[temp]) THEN intb := FALSE;      
        
      IF (LENGTH(mwild)<>0) AND   
         (mwild<>'?') AND (mwild<>mode) THEN intb := FALSE;  
      END; 
    Wildok := intb;
   END; 
   
  BEGIN
   REPEAT
    Clear; 
    WRITE('Report :: W)ildcard, A)ll, C)hangeoutputdevice  ::');
    READ(rmode);
    WRITELN;
    WRITELN;
    IF rmode IN ['C','c'] THEN
     BEGIN
      WRITE('enter new output device --->');
      READLN(ofname);
      SEEK(telfile,0);
      GET(telfile);
      telfile^.whoto := ofname;
      SEEK(telfile,0);
      PUT(telfile);
     END;
   UNTIL NOT (rmode IN ['C','c']);  
   SEEK(telfile,0);
   GET(telfile);
   ofname := telfile^.whoto;
   REWRITE(ofile,ofname);     
   WRITELN;
   WRITELN;
   IF rmode IN ['W','w'] THEN 
    BEGIN
     Getwilds;
     rmode := 'W'; 
    END;
   total := 0;
   WRITE(ofile,  '   #   date time        who from ');       
   WRITELN(ofile,'         who to chgto   mins      cost m');      
   WRITE(ofile,  '----------------------------------------');           
   WRITELN(ofile,'---------------------------------');  
   {$I-}
   FOR temp := 1 TO numrecs DO
    BEGIN
     SEEK(telfile,temp);
     GET(telfile);
     IF ((rmode='W') AND Wildok) OR (rmode<>'W') THEN 
     WITH telfile^ DO  
      BEGIN
       WRITE(ofile,temp:4,' ');
       WRITE(ofile,date:6,' ');
       WRITE(ofile,time:4,' ');             
       WRITE(ofile,wfrom:15,' '); 
       WRITE(ofile,whoto:15,' ');
       WRITE(ofile,who  :5,' ');  
       WRITE(ofile,mins:6,' ');      
       total := total + cost;
       WRITE(ofile,'$',cost:8:2,' '); 
       WRITELN(ofile,mode);
      END; 
    END;
   {$I+}
  WRITE(ofile,'                                 ');  
  WRITELN(ofile,'                 total cost - ',total:8:2);      
  CLOSE(ofile,lock);  
  IF ofname = '#2:' THEN 
   BEGIN
    WRITE('<cr> to continue --->');
    READLN(keyboard);
   END;
  END; 
  
 PROCEDURE Delete;
  VAR todelete,recat : INTEGER;
  BEGIN
   Clear;
   WRITE('enter record number to be deleted --->');
   READLN(todelete);
   WRITE('are you sure you want to delete record #',todelete,'? ');
   READ(ch);
   IF (ch IN ['Y','y']) AND (todelete>0) AND (todelete<=numrecs) THEN  
    BEGIN
     FOR recat := todelete TO numrecs-1 DO
      BEGIN
       SEEK(telfile,recat+1);
       GET(telfile);
       SEEK(telfile,recat);
       PUT(telfile);
      END;
     numrecs := numrecs - 1;
     Wnewnrecs;
    END;
  END;  
 
 PROCEDURE Initprog;
  BEGIN
   {$I-}
   RESET(telfile,'Tele.data');
   {$I+}
   IF IORESULT <> 0 THEN 
    BEGIN
     REWRITE(telfile,'Tele.data');
     Initfile; 
    END;
   SEEK(telfile,0);
   GET(telfile); 
   numrecs := telfile^.mins;
  END; 
  
 PROCEDURE Clear; 
  BEGIN
   gotoxy ( 0, 0 );
   WRITE(CHR(27),chr ( 69 ));   {H-19 specific}
  END;
  
 PROCEDURE Wnewnrecs;
  BEGIN
   SEEK(telfile,0);
   GET(telfile);
   telfile^.mins := numrecs;   
   SEEK(telfile,0);
   PUT(telfile);
  END;
   
 BEGIN 
  Initprog;
  REPEAT
   Clear; 
   WRITE('Telephone :: I)nit, A)dd, D)elete, S)ort, R)eport, Q)uit ::');  
   READ(ch);
   CASE ch OF
    'I','i' : Initfile;  
    'A','a' : Add;    
    'S','s' : Sortfile;
    'R','r' : Report;
    'D','d' : Delete;
    END;
  UNTIL ch IN ['Q','q'];
  CLOSE(telfile,lock);
 END.


========================================================================================
DOCUMENT :usus Folder:VOL18:vol18.doc.text
========================================================================================

                                 USUS Volume 18

SEGMAP.1.TEXT     34  Arley Dealey's version independant segment mapper
SEGMAP.2.TEXT     28    an include file of segmap
ODMSCU.TEXT       10  One Damn More Screen Control Unit (for Segmap)
LIFE.TEXT         32  The game of LIFE
LIFE.INC.TEXT      8    an include file for LIFE
BLACKBOX.TEXT     38  A guessing game based on particle physics
BLACK.DOC1.TEXT    6     a help file for BLACKBOX
BLACK.DOC2.TEXT    6     ditto
TELE.TEXT         18  Keeps a data base of telephone traffic
SORTUNIT.TEXT     18  A three-way key sort unit
SORT2.TEXT        12  A sort program
DEBUG.A.TEXT      22  The UCSD I.3 debugger
DEBUG.B.TEXT      44    an include file of the debugger
BENCHMARKS.TEXT   10  An overview of the benchmarks on this disk
PWROF2.TEXT        8  A Pascal benchmark program
8QUEENS.TEXT       6    ditto
NUMBERIO.TEXT      8    ditto
ANCEST.S.TEXT      6    ditto
PRIMES.TEXT        6    ditto
QUICKSORT.TEXT     6    ditto
QUR.TEXT           6  A simple benchmark to measure "system" speed
STARS.TEXT         6  A simple I/O benchmark
COMPKILLER.TEXT    6  A benchmark designed especially to crash your compiler
WHETSTONE.TEXT    12  The famous WHETSTONE benchmark
WHET.DOC.TEXT     16  Some notes on WHETSTONE, taken from MUSUS
SIEVE.TEXT         8  The infamous Byte Benchmark, as standard as possible
LONG_INT.TEXT     12  Tests long integer operations
INTRINSICS.TEXT   18  Tests system intrinsics
SEGMASHER.TEXT     8  A segment swap speed tester
REPORT.DOC.TEXT    6  Some simple instructions for running the benchmarks
REPORTFORM.TEXT    8  A form for recording the results of the benchmarks.
BENCH.USUS.TEXT   26  Jon Bondy's benchmark ( again ) 
BONDY_FORM.TEXT    8  A form for recording the results of BENCH.USUS 
VOL18.DOC.TEXT    12  You're reading it
-----------------------------------------------------------------------------

Please transfer the text below to a disk label if you copy this volume.

    USUS Volume 18 -***- USUS Software Library
                         
   For not-for-profit use by USUS members only.
  May be used and distributed only according to 
      stated policy and the author's wishes.



This volume was assembled by George Schreyer from material collected by
the Library committee.

__________________________________________________________________________

Some notes from the editor:



                                      LIFE

     This is the game of LIFE submitted by Pat Horton.  It will require some
form of KEY_PRESS routine.  There is one in there which should work on many
IV.0 systems.  I haven't as yet figured out the meaning of this game, but
after one watches it for a while, one wonders what life is all about.


                                      TELE

     TELE, submitted by Pat Horton, keeps a database of telephone
transactions.  It probably takes longer to enter the data than to complete
the conversion, but it is fun.

                                    SORTUNIT

     This is a three-key sort, submitted by Pat Horton.  I haven't used it,
but it compiles and seems to be alive.

                                     SORT2
                                        
     A program version of SORTUNIT.

                                     DEBUG

     This is the UCSD Pascal version I.3 debugger.  It is reputed to have 
problems, but is is also reputed to work.  Although I haven't tried it, I am 
willing to bet that it will be fairly easy to convert it to run as a separate
program under any version of the p-system.

                                    BLACKBOX

     Blackbox is a game that simulates the work of a nuclear physicist.  The 
player fires rays into an unknown 8 * 8 grid.  The resultant interaction of 
the rays with the contents of the 8 * 8 grid allows deduction of its contents.


                                     SEGMAP
                             
     Segmap displays a report the the contents of ANY UCSD segment from ANY
version of the p-system.  If you are having troubles and want to determine
what's REALLY in that questionable segment, this will tell you.
                             
                             THE BENCHMARK PACKAGE

     There are several benchmark programs on this disk.  These are intended to 
determine how fast a particular computer/software combo is in relation to 
others for reasonable "real-life" type computer tasks.  Refer to the file
BENCHMARKS.TEXT for more info.



========================================================================================
DOCUMENT :usus Folder:VOL18:whet.doc.text
========================================================================================

******************************************************************************

#: 8590      Sec. 1 - Members
Sb: Whetstone and Apple II
    02-Oct-82  10:35:42
Fm: Keith McLaurin 71505,2035
To: Roger Peterson

Roger, I compiled and ran the whetstone on an Apple II with Apple Pascal 1.1. 
The results are below.  I added a time instruction to relate the time spent in
the program initialized after the readln(I) and all times are relative to that
point.  The input/output to the screen and the disk file adds about 15
seconds.  I added looping constructs to call each routine to allow running the
program for more than 1 million (I=10) to reduce the I/O percentage and
improve the 1 second resolution of the clock.  To compile, I had to enable the
goto compiler option, add Uses Transcend, and change ARCTAN to ATAN.  I also
ran it for IV.0...  no Uses Transcend needed for iv.0 .
Whetstone  I = 10;      Range Checking on.
  T:     0 MODULE  1    0    0    0     1.000    -1.000    -1.000    -1.000
  T:     7 MODULE  2  120  140  120    -0.068    -0.463    -0.730    -1.124
  T:    46 MODULE  3  140  120  120    -0.055    -0.447    -0.711    -1.103
  T:    55 MODULE  4 3450    1    1     1.000    -1.000    -1.000    -1.000
  T:    84 MODULE  6 2100    1    2     6.000     6.000    -0.711    -1.103
  T:   231 MODULE  7  320    1    2     0.492     0.492     0.492     0.492
  T:   355 MODULE  8 8990    1    2     1.000     1.000     1.000     1.000
  T:   421 MODULE  9 6160    1    2     3.000     2.000     3.000    -1.103
  T:   423 MODULE 10    0    2    3     1.000    -1.000    -1.000    -1.000
  T:   515 MODULE 11  930    2    3     0.835     0.835     0.835     0.835

  Apple Pascal 1.1   Apple Pascal 1.1     Apple Pascal 1.1    IV.0 - Apple
  Weight 1 million . Weight 100 Million . Weight 1 Million . Weight 1 Million
  (range chkg off)     (range chkg on)     (range chkg on)   (range chkg on)
  T:   0 MODULE  1   T:     1 MODULE  1  T:     0 MODULE  1  T:   0 MODULE  1
  T:   6 MODULE  2   T:   534 MODULE  2  T:     7 MODULE  2  T:   6 MODULE  2
  T:  42 MODULE  3   T:  4269 MODULE  3  T:    46 MODULE  3  T:  41 MODULE  3
  T:  52 MODULE  4   T:  5063 MODULE  4  T:    55 MODULE  4  T:  50 MODULE  4
  T:  80 MODULE  6   T:  7826 MODULE  6  T:    84 MODULE  6  T:  75 MODULE  6
  T: 226 MODULE  7   T: 22302 MODULE  7  T:   231 MODULE  7  T: 219 MODULE  7
  T: 350 MODULE  8   T: 34553 MODULE  8  T:   355 MODULE  8  T: 342 MODULE  8
  T: 410 MODULE  9   T: 40961 MODULE  9  T:   421 MODULE  9  T: 400 MODULE  9
  T: 412 MODULE 10   T: 40962 MODULE 10  T:   423 MODULE 10  T: 401 MODULE 10
  T: 504 MODULE 11   T: 50078 MODULE 11  T:   515 MODULE 11  T: 493 MODULE 11
  Comments:  Module 1 -- Simple identifiers, assignments
             Module 2 -- Array Elements
             Module 3 -- Array as Parameter
             Module 4 -- Conditional Jumps
             Module 5 -- Omitted ?? Why and What ??
             Module 6 -- Integer (Array) arithmetic
             Module 7 -- Trig Functions
             Module 8 -- Procedure Calls
             Module 9 -- Array References
             Module 10 - Integer Arithmetic
             Module 11 - Standard Math Functions
    IV.0 is faster in excution than Apple Pascal 1.1. The time spent in any
    Module is calculated by subtracting the T: value above the module. e.g.
    time in module 11 is 50078 - 40962 = 9116 seconds. The values were
    calculated as long integers. - keith mclaurin










******************************************************************************

MODULE 5 was also omitted in the original reference.  There was no reason
given, nor any explanation of its original purpose.  -Roger Peterson

******************************************************************************

 #: 8732      Sec. 1 - Members
Sb: #8685-Whetstone cont.
Fm: Keith McLaurin 71505,2035
To: Roger Peterson 71565,411

Roger,
I looked up the reference you listed for 'The Computer Journal' Volume 19, #1
p. 43-49 and see that Module 5 is ommited in the Appendix with no explanation
as to why.  So please disreguard my earlier question.

The source file I downloaded from the MUSUS data base WHET.PAS has one very
minor typo in MODULE 4.  The conditional statement J<1 should read J<2.  This
has little impact on program execution time on the Apple II.  I replaced the
Var Temp in MODULE 7 with the source to match the Algol listing and the 
execution time of that module increased about 20%.  The use of Temp 
variable optimizes the source sincethe Temp expression is evaluated only once
in a pass rather than twice when it is in the denominator.  Essentially
equivalent times are obtained when the Temp expression is evaluated twice.

I have often heard of 'Whetstones' and often wondered what they specifically
were.  The Whetstone program is a benchmark for evaluating scientific type 
programs based on analysis of about 1000 programs for frequencies of
operations.  The term 'Whetstones per second' is calculated by I * 100,000 /
(Program execution in seconds).  Thanks for sharing this program with the USUS
group.  -keith mclaurin

******************************************************************************

The temporary variable, TEMP, in MODULE 7 was added for the OMSI compiler.
OMSI Pascal (versions 1.1 and really do NOT use the stack properly and thus 
have severe limits on nesting of expressions (especially floating point 
calculations).  This is not a limitation in UCSD.  I suggest that the original
source of WHET.PAS be changed to read

             BEGIN
               TEMP:= COS(X+Y)+COS(X-Y)-1.0;
               X:=T*ATAN(T2*SIN(X)*COS(X)/TEMP);  (* USE ARCTAN FOR OMSI *)
               TEMP:=COS(X+Y)+COS(X-Y)-1.0;
               Y:=T*ATAN(T2*SIN(Y)*COS(Y)/TEMP)
             END;

Now the only difference from the original is that it has two additional
floating point store and retrieve operations.  -Roger Peterson

******************************************************************************



========================================================================================
DOCUMENT :usus Folder:VOL18:whetstone.text
========================================================================================

(*$R-*)
(*WHETSTONE BENCHMARK - - DIRECT TRANSLITERATION OF THE ORIGINAL 
                          ALGOL PROGRAM FROM:
    "A SYNTHETIC BENCKMARK"  BY H. J. CURNOW & B. A. WICHMANN
    'THE COMPUTER JOURNAL' VOL 19, NO. *)

(*$G+*)   (* TURN ON 'GOTO' -- FOR UCSD COMPILER                     *)
          (* UGLY, BUT THAT'S THE WAY IT WAS IN THE ORIGINAL VERSION *) 
PROGRAM WHETSTONE;

CONST T=0.499975;
      T1=0.50025;
      T2=2.0;

TYPE ARGARRAY = ARRAY[1..4] OF REAL;

VAR E1 : ARRAY[1..4] OF REAL;
    X,Y,Z,X1,X2,X3,X4 : REAL;
    MODULE,I,J,K,L,N1,N2,N3,N4,N5,N6,N7,N8,N9,N10,N11 : INTEGER;

PROCEDURE PA(VAR E:ARGARRAY);

LABEL 1;
VAR J : INTEGER;

BEGIN
   J:=0;

1:
   E[1]:=(E[1]+E[2]+E[3]-E[4])*T;
   E[2]:=(E[1]+E[2]-E[3]+E[4])*T;
   E[3]:=(E[1]-E[2]+E[3]+E[4])*T;
   E[4]:=(-E[1]+E[2]+E[3]+E[4])/T2;
   J:=J+1;
   IF J<6 THEN
    GOTO 1
END;  (* PROCEDURE PA*)


PROCEDURE P0;

BEGIN
   E1[J]:=E1[K];
   E1[K]:=E1[L];
   E1[L]:=E1[J]
END;   (* PROCEDURE P0 *)

PROCEDURE P3(X,Y:REAL;VAR Z:REAL);

BEGIN
   X:=T*(X+Y);
   Y:=T*(X+Y);
   Z:=(X+Y)/T2
END;  (* PROCEDURE P3 *)

PROCEDURE MODULE1; (* MODULE 1: SIMPLE IDENTIFIERS *)

BEGIN
  X1:=1.0;
  X2:=-1.0; X3:=-1.0; X4:=-1.0;

  FOR I:=1 TO N1 DO
  BEGIN
    X1:=(X1+X2+X3-X4)*T;
    X2:=(X1+X2-X3+X4)*T;
    X3:=(X1-X2+X3+X4)*T;
    X4:=(-X1+X2+X3+X4)*T
  END;

END; (* MODULE 1 *)

PROCEDURE MODULE2; (* MODULE 2: ARRAY ELEMENTS *)

BEGIN
E1[1]:=1.0;
E1[2]:=-1.0; E1[3]:=-1.0; E1[4]:=-1.0;

FOR I:=1 TO N2 DO
  BEGIN
  E1[1]:=(E1[1]+E1[2]+E1[3]-E1[4])*T;
  E1[2]:=(E1[1]+E1[2]-E1[3]+E1[4])*T;
  E1[3]:=(E1[1]-E1[2]+E1[3]+E1[4])*T;
  E1[4]:=(-E1[1]+E1[2]+E1[3]+E1[4])*T
  END;
END;  (* MODULE 2 *)

PROCEDURE MODULE4; (* MODULE 4: CONDITIONAL JUMPS *)

BEGIN
J:=1;
FOR I:=1 TO N4 DO
  BEGIN
    IF J=1 THEN
      J:=2
    ELSE
      J:=3;
    IF J>1 THEN
      J:=0
    ELSE
      J:=1;
    IF J<2 THEN
      J:=1
    ELSE
      J:=0
  END;
END; (* MODULE 4 *)

PROCEDURE MODULE6; (* INTEGER ARITHMETIC *)

BEGIN
  J:=1;
  K:=2;
  L:=3;

  FOR I:= 1 TO N6 DO
  BEGIN
    J:=J*(K-J)*(L-K);
    K:=L*K-(L-J)*K;
    L:=(L-K)*K+J;
    E1[L-1]:=J+K+L;
    E1[K-1]:=J*K*L
  END;
END; (* MODULE 6 *)

PROCEDURE MODULE7; (* MODULE 7: TRIG FUNCTIONS *)

VAR TEMP : REAL;

BEGIN
X:=0.5; Y:=0.5;
FOR I:=1 TO N7 DO
  BEGIN
    TEMP:=COS(X+Y)+COS(X-Y)-1.0;
    X:=T*ATAN(T2*SIN(X)*COS(X)/TEMP);  (*USE ARCTAN FORM OMSI*)
    TEMP:=COS(X+Y)+COS(X-Y)-1.0;
    Y:=T*ATAN(T2*SIN(Y)*COS(Y)/TEMP);
  END;
END; (* MODULE 7 *)

PROCEDURE MODULE8; (* MODULE 8: PROCEDURE CALLS *)

BEGIN
  X:=1.0; Y:=1.0; Z:=1.0;

  FOR I:=1 TO N8 DO
    P3(X,Y,Z)
END; (* MODULE 8 *)

PROCEDURE MODULE10; (* MODULE 10: INTEGER ARTIHMETIC *)

BEGIN
  J:=2;
  K:=3;
  FOR I:=1 TO N10 DO
    BEGIN
    J:=J+K;
    K:=J+K;
    J:=K-J;
    K:=K-J-J
  END;
END; (* MODULE 10 *)

PROCEDURE MODULE11; (* MODULE 11: STANDARD FUNCTIONS *)

BEGIN
  X:=0.75;

  FOR I:=1 TO N11 DO
    X:=SQRT(EXP(LN(X)/T1));
END; (* MODULE 11 *)

PROCEDURE POUT(VAR N,J,K:INTEGER; VAR X1,X2,X3,X4:REAL);

BEGIN
  WRITE('MODULE ',MODULE:2,N:5,J:5,K:5);
  WRITELN(X1:12:3,X2:12:3,X3:12:3,X4:12:3);
END;   (* PROCEDURE POUT *)

BEGIN  (* START WHETSTONE *)

(* READ VALUE OF I, CONTROLLING TOTAL WEIGHT: IF I=10,
    THE TOTAL WEIGHT IS ONE MILLION WHETSTONE INSTRUCTIONS *);

  WRITELN;
  WRITE ('WEIGHTING FACTOR I = '); READLN(I);
  WRITELN;
  N1:=0;
  N2:=12*I;
  N3:=14*I;
  N4:=345*I;
  N5:=0;
  N6:=210*I;
  N7:=32*I;
  N8:=899*I;
  N9:=616*I;
  N10:=0;
  N11:=93*I;

(* MODULAR PROGRAMMING IS USED TO REDUCE THE LENGTH OF MAIN CODE *)

MODULE1; (* SIMPLE IDENTIFIERS *)
MODULE:=1;
POUT(N1,N1,N1,X1,X2,X3,X4);

MODULE2; (* ARRAY ELEMENTS *)
MODULE:=2;
POUT(N2,N3,N2,E1[1],E1[2],E1[3],E1[4]);

(* MODULE 3: ARRAY AS A PARAMETER *)

FOR I:= 1 TO N3 DO

  PA(E1);
MODULE:=3;
POUT(N3,N2,N2,E1[1],E1[2],E1[3],E1[4]);

(* END OF MODULE 3 *)

MODULE4; (* CONDITIONAL JUMPS *)
MODULE:=4;
POUT(N4,J,J,X1,X2,X3,X4);

WRITELN('MODULE  5 OMITTED ');
MODULE6; (* INTEGER ARITHMETIC *)
MODULE:=6;
POUT(N6,J,K,E1[1],E1[2],E1[3],E1[4]);

MODULE7; (* TRIG FUNCTIONS *)
MODULE:=7;
POUT(N7,J,K,X,X,Y,Y);

MODULE8; (* PROCEDURE CALLS *)
MODULE:=8;
POUT(N8,J,K,X,Y,Z,Z);

(* MODULE 9: ARRAY REFERENCES *)

  J:=1;
  K:=2;
  L:=3;
  E1[1]:=1.0;
  E1[2]:=2.0;
  E1[3]:=3.0;

  FOR I:=1 TO N9 DO P0;

MODULE:=9;
POUT(N9,J,K,E1[1],E1[2],E1[3],E1[4]);

MODULE10; (* INTEGER ARITHMETIC *)
MODULE:=10;
POUT(N10,J,K,X1,X2,X3,X4);

MODULE11; (* STANDARD FUNCTIONS *)
MODULE:=11;
POUT(N11,J,K,X,X,X,X);

WRITELN('END OF WHETSTONE')
END. (* END WHETSTONE *)





========================================================================================
DOCUMENT :usus Folder:VOL19:2k.key.text
========================================================================================

                                   The 2K Key


     There is a ROM available from E&H Systems which replaces the H-27 boot 
ROM and allows you to obtain an extra 2K words (4k bytes) of RAM if your 
memory board can support a 2K word I/O page in addition to the standard 4K I/O 
page.  The ROM moves boot and diagnostic code from below address 170000 
(octal) to above 170000.  If you have no other I/O devices which respond to 
address between 160000 and 167777 then this ROM can considerably help you, 
especially if you use version IV.0.

     The ROM uses a different boot procedure than the standard Heath ROM. 
Instead of letting you specify the device to boot, it tries to boot any
bootable device on line.  This allows the system to boot automatically on 
power-up with no console microcode necessary.  This feature is neat in some
circumstances and a pain in the a** in others.

     The ROM first tries to boot DL0..4: (RL01).  If it doesn't find an RL01 it
tries DK0..7: (RK05).  If that fails it tries DX0..1: (RX01) and then DY0..1:
(RX02). If all of the boots fail, it starts over at RL01.  This sequence can
cause problems. When the ROM tries to boot any of the four devices, it first
looks at unit 0 of the device and then tries unit 1 and so on.  This means that
if, for example, DK0: and DK1: are both bootable, the ROM will always boot DK0
and never even try DK1:.  To boot DK1: or higher, you will must (as I do) enter
the DMA bootstrap instructions by hand into console microcode.  Also if your 
hard disk and floppy come on with the same power switch, and you want to boot
floppy, you had better plug in the floppy before you hard disk controller
signals that it is ready or the system will boot the hard disk.  Then in order
to boot your floppy, you will have to enter the console microcode instructions
(about 30 of them) by hand, or turn your hard disk off and start over.  There
ain't no free lunch.

     There is also a problem with the software bootstrap compatibility and the
2K key, but it can be easily fixed with a simple object patch to the bootstrap.

     When the LSI-11 processor generates an address above 160000, it also
asserts bus line BBS7.  This tells all I/O devices to decode the lower 13 bits
of the address so the one being address can respond.  I/O devices look at line
BBS7 instead of the high order 3 bits (or 5 bits in the case of the 11/23).
Memory on the bus also looks at line BBS7 except that to memory it means ignore
this address.  However, some memory boards such as the Mostek, Chrislin,
Monolithic Memories and others allow a trick to occur.  The standard Heath 16K
boards and all standard DEC boards do not allow this special trick.  

     When a switch or jumper on the memory board is properly set, the memory
board will not ignore addresses between 160000 and 167777 when BBS7 is
asserted.  It will ignore address above 170000 if BBS7 is asserted.  If BBS7
is asserted by the CPU and no I/O device responds to an address in the range
of 160000 to 167777, then no address conflict occurs and memory can legally
respond.  So this "extra" address space, 2K words of it, can be reclaimed for 
system memory.

     There is a hitch however.  The p-system boot code (located in block 0 of 
your system disk) sometimes does not allow the processor to access the memory 
which you have so carefully made free.  This is because it only looks up to
157777 to find the top of memory, as it does not expect to find any in the I/O 
page.  The version II.0 RX01 interpreter handles the memory sizing properly 
and the 2K Key works fine, but none of the other software bootstraps that I
have tested do.

     There is a patch which is simple to do.  You must use PATCH to view block 
0 of your system disk (use a copy in case you screw it up).  You must change a 
word which indicates to highest memory to search from 160000 (octal) to 
170000.  The byte flipped hex pattern which you are looking for is 00E0 and 
you want to change it to 00F0.  The byte offsets (decimal per the PATCH 
display) are shown below for some of the p-system bootstraps.

     version II.0  RK05    offset  282
     version IV.0  RK05    offset  282
     version IV.0  RX01    offset  446
     
     If you want to patch some other bootstrap such as RL01 or RX02, you will 
have to look through every word to find the appropriate pattern and change it.
If your system won't boot, you found the wrong place.

     You should write a simple program BEFORE you make the change to display
the available memory to see if you really got 2048 more words.

     program memtest;
     begin
        writeln;
        write ( memavail );
     end.



                        regards - gws



========================================================================================
DOCUMENT :usus Folder:VOL19:booter.code
========================================================================================

< binary file -- not listed >

========================================================================================
DOCUMENT :usus Folder:VOL19:dec.index.text
========================================================================================



                        USUS Library DEC specific Index

     The following is an index of the DEC specific programs which are already 
in the USUS Library.  

Volume #2A

PUNCH.TAPE.TEXT     These programs allow you to use your H-10 paper tape 
READ.TAPE.TEXT      punch.

SMARTREMOT.TEXT     This is a terminal emulator which is very DEC specific.
                    It is also H-19 (VT-52) specific.  
                    An improved version is found on Volume 15.


Volume #5

FMT.2.0.CODE        A code file of a fair text formatter.  It works on DEC
                    iron, but on nothing else.  Source is N/A.

SP.TEXT             This is a utility needed to do underlining and boldface
                    with FMT.  It has a DEC specific routine to output a 
                    CR without a LF, but an easier way is just to send 
                    chr ( 141 ).
                    
                    
Volume #8

MODEMV2.2.TEXT      The worlds simplest terminal emulator.  Requires UNITBUSY
                    so it is DEC specific.


Volume #15

SMARTREMOT.TEXT     The reworked version of the terminal emulator on #2A.  
                    Requires an H-19 also.

IOUNIT.TEXT         A unit used by SMARTREMOT.  It is a bunch of declarations
                    which allow one to easily access hardware buffer for I/O dev
                    devices.
                    
REMUNIT.L3.TEXT     A DEC specific USUS Standard remote unit.
CLR_BREAK.TEXT        an external procedure for REMUNIT.L3
SET_BREAK.TEXT        ditto


========================================================================================
DOCUMENT :usus Folder:VOL19:eis.text
========================================================================================

EIS=1
 

========================================================================================
DOCUMENT :usus Folder:VOL19:lp11.text
========================================================================================

         .TITLE  LP-11 PRINTER HANDLER
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;                                                                   ;
 ;                       SYSTEM TABLE CONTENTS                       ;
 ;                                                                   ;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
         .ASECT          ; INTERRUPT HANDLER LOCATION IN VECTORS
 .=200
         LP$INT
         200
 
         .CSECT  TABLES
         .BLKW   128.    ; OPERATOR XFER TABLE
         .REPT   6
         .BLKW   3
         .ENDR
         .WORD   OUTBIT,LPSTRT,LPABRT
         .PAGE
         .CSECT  LPDRVR
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;                                                                   ;
 ;               PRINTER OUTPUT HANDLER                              ;
 ;                                                                   ;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 LPUNIT: .WORD   0
 LPBUFA: .WORD
 LPLENG: .WORD
 LP.COL: .WORD   0
 LPCSR:  .WORD   177514
 LPBUF:  .WORD   177516

 LPOFST  = 4
 LPSTRT:         ; THIS CODE STARTS IO'S TO THE PRINTER DEVICE
         TST     LPUNIT          ; SEE IF AN IO ALREADY IN PROGRESS
         BNE     LPSTRT          ; IF SO LOOP UNTIL THE IO IS COMPLETE
         MTPS    #200            ; NO INTERRUPTS PLEASE
         MOV     R1,LPUNIT       ; MARK HANDLER AS BUSY
         BIS     #BSYBIT,(R1)    ; MARK LOGICAL UNIT AS BUSY
         CLR     (SP)            ; SET UP RETURN STUFF ON STACK...PR-0 PS
         TST     (R3)+           ; SKIP R3 OVER IO INFO WORD
         MOV     R3,-(SP)        ; NOW THE RETURN ADDRESS
         MOV     <UBUFFR+LPOFST>(SP),LPBUFA      ; GRAB USER BUFFER ADDR
         MOV     <URLENG+LPOFST>(SP),LPLENG      ; AND REQUESTED IO LENGTH
 LP$INT: BIC     #100,@LPCSR     ; DISABLE INTERRUPTS
         TST     LPUNIT          ; ANY IO'S IN PROGRESS
         BEQ     LPEXIT          ; IF NOT JUST FORGET IT
         TST     LPLENG          ; ANY CHARS LEFT TO BE SENT?
         BEQ     LPQUIT          ; IF NOT THEN FINISH UP IO
         MOV     R0,-(SP)        ; STASH REG
         CLR     R0
         BISB    @LPBUFA,R0      ; GRAB CHAR FROM USER BUFFER
         BEQ     3$              ; A NULL? RESET TABS STOPS
         CMPB    R0,#FF          ; FORM - FEED?
         BEQ     3$
         CMPB    R0,#HT
         BNE     4$
         JSR     PC,LPTABR
 4$:     INC     LP.COL
         CMPB    R0,#CR          ; AN END-OF-LINE CHAR?
         BNE     1$
         MOVB    #LF,R0          ; MAKE A PRINTRONIX EOL
         BR      3$
 1$:     CMPB    R0,#21          ; A DC1?? (USED TO DO UNDERLINING)
         BNE     2$
         MOVB    #CR,R0          ; MAKE A CR FOR PRINTRONIX BENEFIT
 3$:     CLR     LP.COL
 2$:     TST     @LPCSR          ; TEST ERROR BIT
         BMI     2$              ; AND HANG TIL READY
         MOVB    R0,@LPBUF       ; SEND CHAR TO DL
         MOV     (SP)+,R0        ; RESTORE TEMP REG
         BIS     #100,@LPCSR     ; ALLOW INTERRUPT
         INC     LPBUFA          ; BUMP BUFFER POINTER TO NEXT CHAR
         DEC     LPLENG          ; ALSO REFLECT ONE FEWER CHAR TO SEND
         JMP     @#INTRTN        ; THIS STRUCTURE IMPLIES AN IO IS NOT
                                 ; DONE UNTIL THE LAST INTERRUPT IS RECEIVED
 LPQUIT: BIC     #BSYBIT,@LPUNIT         ; CLEAR BUSY BIT IN IO UNIT TABLE
         CLR     LPUNIT          ; MARK HANDLER AS NOT BUSY NOW
 LPEXIT: JMP     INTRTN          ; AND BACK NOW TO WHEREVER

 LPTABR: ; LITTLE SUBROUTINE TO TAB
         MOV     R1,-(SP)
         MOV     #' ,R0
         MOV     LP.COL,R1
         BIS     #7,LP.COL
         SUB     LP.COL,R1
         BEQ     3$
 1$:     MOVB    R0,@LPBUF
 2$:     TSTB    @LPCSR
         BPL     2$
         INC     R1
         BNE     1$
 3$:     MOV     (SP)+,R1
         RTS     PC

 LPABRT: MTPS    #200
         TST     LPUNIT
         BEQ     1$
         BIC     #BSYBIT,@LPUNIT
         CLR     LPUNIT
 1$:     MTPS    #0
         RTS     PC

         .END



========================================================================================
DOCUMENT :usus Folder:VOL19:macros.text
========================================================================================

         .NLIST
         .NLIST  CND
         .NLIST  TTM
         .LIST
 ;************************************************;
 ;*                                              *;
 ;*    UCSD PASCAL INTERPRETER FOR PDP-11'S      *;
 ;*                                              *;
 ;*    WRITTEN BY ROGER T. SUMNER                *;
 ;*    AND MARK OVERGAARD, 1977                  *;
 ;*                                              *;
 ;*    INSTITUTE FOR INFORMATION SYSTEMS         *;
 ;*    UC SAN DIEGO, LA JOLLA, CA                *;
 ;*                                              *;
 ;*    KENNETH L. BOWLES, DIRECTOR               *;
 ;*                                              *;
 ;*    THIS SOFTWARE IS THE PROPERTY OF THE      *;
 ;*  REGENTS OF THE UNIVERSITY OF CALIFORNIA.    *;
 ;*                                              *;
 ;************************************************;

         .NLIST
 PC=%7                   ;PDP-11 PROGRAM COUNTER
 SP=%6                   ;PDP-11 AND P-11 STACK POINTER
 IPC=%4                  ;P-11 PROGRAM COUNTER
 MP=%5                   ;BASE OF LOCAL DATA SEGMENT
 BASE=%3                 ;BASE OF GLOBAL DATA SEG
 BK=%2                   ;USED TO GET TO BACK FOR NEXT OPCODE FETCH

 MAXUNT = 8.     ; MAX LEGAL UNIT # IN SYSTEM
 MAXSEG = 15.    ; MAX SEGMENT NUMBER ALLOWED
 NP = 50         ; INITIAL HEAP TOP...SET BY LINKER MAGICALLY

 .IF     DF,TERAK
         LSI=1
         EIS=1
         FPI=1
         .GLOBL  DRAWLINE,DRAWBLOCK
 .ENDC

 .IF     NDF,FPI
         .GLOBL  $ADR,$SBR,$MLR,$DVR,$CMR
 .ENDC

         .GLOBL  HLTLIN,BRKPTS,BUGSTA
         .GLOBL  $IR,$RI,ALOG,ALOG10,EXP,SIN,COS,ATAN,SQRT
         .GLOBL  ENTFP,XITFP,LOTIME,HITIME
         .GLOBL  MEMTOP,CRTNFO,GDIRP,INTRTN
         .GLOBL  BACK,SYIORQ,SYSUNT,DIV,MLI,STKBAS,IORSLT
         .GLOBL  JTAB,SEGTBL,LASTMP,SEG,UNITBL,BITTER


 BLANK=40
 BLANKS=20040    ;TWO ASCII BLNKS
 BS=10           ;BACKSPACE
 CR=15
 LF=12
 HT=11
 EM=31
 FS=34
 US=37
 FF=14
 GS=35
 VT=13
 RS=36
 DC1=21
 DC2=22

 ; TRAP PARAMETERS ( >=0 ARE EXECERR, <0 ARE SYSTEM REQUESTS)
 SYSERR=0
 INVNDX=1
 NOPROC=2
 NOEXIT=3
 STKOVR=4
 INTOVR=5
 DIVZER=6
 BADMEM=7
 UBREAK=10
 SYIOER=11
 UIOERR=12
 NOTIMP=13
 FPIERR=14
 S2LONG=15
 HLTBPT=16
 BRKPNT=17
 TTXREQ=-1

 NIL = 1

 ;;;; CODE SEGMENT FORMAT DEFINES
 ; R@JTAB IS PROC# (LOW BYTE) AND LL (HIGH BYTE)

 ENTRIC  = -2    ; JTAB INDEX OF ENTRY OFFSET
 EXITIC  = -4    ;   "    "    "   EXIT POINT
 PARMSZ  = -6    ;   "    "    "  # WORDS OF PARAMS TO COPY AT ENTRY TIME
 DATASZ  = -10   ;   "    "    "  # WORDS TO OPEN IN STACK

 ;;;; MARK STACK CONTROL WORD FORMAT
 ; THESE OFFSETS ARE RELATIVE TO THE STAT LINK WORD!

 MSSTAT = 0      ; STATIC LINK...POINTS TO PARENTS STAT LINK
 MSDYN  = 2      ; DYNAMIC LINK...POINTS TO CALLERS STAT LINK
 MSIPC  = 10     ; ABSOLUTE MEM ADDR OF NEXT OPCODE IN CALLER
 MSSEG  = 6      ;    "      "    "  OF SEG TABLE OF CALLER (LIKELY = SEG)
 MSJTAB = 4      ;    "      "    " OF CALLER JTAB (PROCEDURE CODE INFO ETC)
 MSSP   = 12     ; VALUE TO SET SP TO UPON EXIT
 MSBASE = -2     ; BASE REG...ONLY IN BASE MSCW'S
 MSDLTA = 12     ; SIZE OF MSCW - 2

 ;;;; IO SUBSYSTEM STUFF
 ; BIT FIELDS IN UNITBL
 ; IO RESULTS GIVEN BY IO ROUTINES

 PARERR  = 1
 UNTERR  = 2
 MODERR  = 3
 INBIT   =  20000
 OUTBIT  =  40000
 BSYBIT  = 100000
 UNOWAIT = 0
 UBLOCK  = 2
 URLENG  = 4
 UBUFFR  = 6
 UUNIT   = 10

 .MACRO  GETNEXT         STUFF
         .IF     B,<STUFF>
         MOVB    (IPC)+,R0               ;GET A BYTE FROM CODE
         .IFF
         MOVB    (IPC)+,STUFF            ;AND PUT IT IN R0 OR
         .ENDC                   ;IN STUFF IF STUFF I S NON-BLANK
 .ENDM   GETNEXT

 .MACRO  GETBYTE STUFF
         .IF     B,<STUFF>
         CLR     R0
         BISB    (IPC)+,R0
         .IFF
         CLR     STUFF
         BISB    (IPC)+,STUFF
         .ENDC
 .ENDM   GETBYTE

 .MACRO  GETBIG  STUFF,?NOTBIG
         .IF     B,<STUFF>
         GETNEXT
         BPL     NOTBIG
         BIC     #SIGNWIPE,R0
         SWAB    R0
         BISB    (IPC)+,R0
         .IFF
         GETNEXT STUFF
         BPL     NOTBIG
         BIC     #SIGNWIPE,STUFF
         SWAB    STUFF
         BISB    (IPC)+,STUFF
         .ENDC
 NOTBIG:
 .ENDM   GETBIG

 R0=%0   ; DEFINE WORKING REGISTERS
 R1=%1
 R2=%2
 R3=%3
 R4=%4
 R5=%5

 .MACRO  MORE
         MOV     BK,PC   ;SET PC TO BACK LABEL ADDR
 .ENDM   MORE

 .MACRO  WORDBOUND
         INC     IPC             ;BUMP IPC
         BIC     #1,IPC          ;THEN ROUND
 .ENDM   WORDBOUND

 SIGNWIPE=177600
 CLREXT=177400

 .IF     NDF,LSI
 .MACRO  MTPS    NEWPS,?L
         MOV     NEWPS,-(SP)
         MOV     #L,-(SP)
         RTI
 L:
 .ENDM   MTPS

 .IF     NDF,EIS
 .MACRO  SOB     REG,LABEL
         DEC     REG     ; THIS IS AN SOB OPERATOR
         BNE     LABEL   ; AS IN LSI-11 OR 11-40
 .ENDM   SOB
 .ENDC
 .ENDC

 .MACRO  .TTYOUT         .CHAR
         .IIF    NB,<.CHAR>,     MOVB    .CHAR,R0
         TRAP    TTXREQ
 .ENDM   .TTYOUT

 .MACRO  UREAD   UNIT,BUFR,LENG,BLOCK
         MOV     UNIT,-(SP)
         MOV     BUFR,-(SP)
         MOV     LENG,-(SP)
         MOV     BLOCK,-(SP)
         CLR     -(SP)
         JSR     R1,SYIORQ
         .WORD   1
 .ENDM   UREAD

         .LIST




========================================================================================
DOCUMENT :usus Folder:VOL19:mainop.text
========================================================================================

         .TITLE  MAIN OPERATORS
         .CSECT  MAINOP
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;                                                                   ;
 ;                       MAIN OPERATORS                              ;
 ;                                                                   ;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 ; FIRST ARE THE SHORT FORM LDL,LDO, AND IND OPS.
 ; THESE ARE THE MOST COMMON OPS (EXCEPT LDCI) AND RUN
 ; VERY FAST.  EACH DISP VALUE FOR THESE IS A NEW OPCODE
 
 ; SHORT LOCAL LOADS...16 OF THEM
 SLDLS:  .IRP    N,<1,2,3,4,5,6,7,10,11,12,13,14,15,16,17,20>
         MOV     <N+N>+MSDLTA(MP),-(SP)
         BR      BACK
         .ENDR
 
 ; SHORT LOAD GLOBALS...16 OF THEM
 SLDOS:  .IRP    N,<1,2,3,4,5,6,7,10,11,12,13,14,15,16,17,20>
         MOV     <N+N>+MSDLTA(BASE),-(SP)
         BR      BACK
         .ENDR
 
 ; SHORT IND OPS...8 OF THEM
 SINDS:  MOV     @(SP)+,-(SP)
         BR      BACK
         .BLKW   2       ; FUNNY BUSINESS FOR EXTRA FAST IND 0
         .IRP    N,<1,2,3,4,5,6,7>
         ADD     #<N+N>,@SP
         MOV     @(SP)+,-(SP)
         BR      BACK
         .ENDR
         .PAGE
 ;;;;;;;;;;;;;;;;;;;;;;;
 ; MAIN INTERPRETER LOOP
 ; GO HERE FOR OPCODE
 ; FETCH SEQUENCE
 ;;;;;;;;;;;;;;;;;;;;;;;;
 
 SLDCI:  MOV     R0,-(SP)        ; PUSH THE LIT VALUE AND FALL INTO NEXT OP
 BACK:   GETNEXT                 ; GET NEXT INSTRUCTION BYTE
         BPL     SLDCI           ; IF POSITIVE THEN A SHORT LDCI
         ASL     R0              ; DOUBLE FOR WORD INDEXING
         MOV     XFRTBL(R0),PC   ; TRANSFER CONTROL TO PROPER OP
 
 ABI:    ; INTEGER ABSOLUTE VALUE
         TST     @SP
         BPL     1$
         NEG     @SP
         BPL     1$
         CLR     @SP
 1$:     MORE
 
 ABR:    ; REAL ABSOLUTE VALUE
         BIC     #100000,@SP
         MORE
 
 ADI:    ; ADD INTEGER
         ADD     (SP)+,@SP
         MORE
 
 ADR:    ; ADD REAL
         .IF     DF,FPI
         FADD    SP
         MORE
         .IFF
         JSR     R4,ENTFP
         .WORD   $ADR,XITFP
         .ENDC
 
 AND:    ; LOGICAL AND
         COM     @SP
         BIC     (SP)+,@SP
         MORE
 
 BPT:    ; CONDITIONAL HALT (BREAKPOINT)
         GETBIG                  ; LINE IN LIST FILE
         MOV     R0,HLTLIN
         CMP     BUGSTA,#3
         BGE     BPTTRP
         ; NOT IN STEPPING MODE, SO SEE IF MATCHES A BREAKPOINT
         MOV     #BRKPTS,R1
         CMP     (R1)+,R0
         BEQ     BPTTRP
         CMP     (R1)+,R0
         BEQ     BPTTRP
         CMP     (R1)+,R0
         BEQ     BPTTRP
         CMP     (R1),R0
         BEQ     BPTTRP
         MORE
 BPTTRP:         TRAP    BRKPNT
 
 DIF:    ; SET DIFFERENCE
         JSR     PC,SETADJ
         BEQ     2$
 1$:     BIC     (SP)+,(R0)+
         SOB     R1,1$
 2$:     MORE
 
 DVI:    ; INTEGER DIVIDE
         MOV     (SP)+,R1
         MOV     (SP)+,R0
         JSR     PC,DIV
         MOV     R0,-(SP)
         MORE
 
 DVR:    ; REAL DIVIDE
         .IF     DF,FPI
         FDIV    SP
         MORE
         .IFF
         JSR     R4,ENTFP
         .WORD   $DVR,XITFP
         .ENDC
 
 CHK:    ; CHECK INDEX OR RANGE
         CMP     (SP)+,2(SP)     ; CHECK MAXIMUM VALUE
         BLT     CHKERR
         CMP     (SP)+,@SP       ; CHECK MINIMUM VALUE
         BGT     CHKERR
         MORE
 CHKERR:         TRAP    INVNDX
 
 FLO:    ; FLOAT NEXT TO TOP-OF-STACK
         MOV     (SP)+,FLO1      ; SAVE REAL ON TOS
         MOV     (SP)+,FLO0
         JSR     R4,ENTFP
         .WORD   $IR,FIXTOS,XITFP
 FIXTOS: MOV     (PC)+,-(SP)
 FLO0:   .WORD
         MOV     (PC)+,-(SP)
 FLO1:   .WORD
         JMP     @(R4)+

 FLT:    ; FLOAT TOP-OF-STACK
         JSR     R4,ENTFP
         .WORD   $IR,XITFP

 INN:    ; SET INCLUSION
         MOV     (SP)+,BK        ; GET SET SIZE FROM STACK
         MOV     SP,R0           ; NOW POINT R0 AT THE SCALAR VAL
         ADD     BK,R0           ; BY SKIPPING IT ABOVE
         ADD     BK,R0           ; THE SET
         MOV     @R0,R1          ; R1 HAS THE VALUE TO TEST FOR NOW
         BMI     NOTINN          ; NO NEGATIVE SET INDEXES
         .IF     DF,EIS
         ASH     #-4,R1
         .IFF
         ASR     R1
         ASR     R1
         ASR     R1
         ASR     R1
         .ENDC
         CMP     R1,BK           ; CHECK IF ENOUGH WORD ARE IN SET
         BGE     NOTINN          ; TO ACCOMODATE THE VALUE IN R1
         ASL     R1              ; IF THERE ARE, POINT R1 AT THE WORD
         ADD     SP,R1           ; WHICH HAS THE BIT IN IT
         MOV     @R1,BK          ; PLACE THE WORD INTO BK FOR LATER
         MOV     @R0,R1          ; GET THE SCALAR AGAIN
         BIC     #177760,R1      ; CHUCK ALL BUT LOW 4 BITS
         ASL     R1              ; MAKE A WORD INDEX INTO BITTER
         BIT     BITTER(R1),BK   ; TEST IF THE BIT IN QUESTION IS ON
         BEQ     NOTINN
         MOV     R0,SP           ; FOUND IT...CUT BACK STACK
         MOV     #1,@SP          ; PUT A TRUE ON TOP
 XITINN: MOV     #BACK,BK        ; RESTORE REGISTER
         MORE
 NOTINN: MOV     R0,SP           ; CUT BACK HERE TOO
         CLR     @SP             ; EXCEPT PUSH A FALSE
         BR      XITINN


 INT:    ; SET INTERSECTION
         JSR     PC,SETADJ
         MOV     R1,TOPSIZ       ; SAVE TOP SET SIZE
         BEQ     2$
 1$:     COM     @SP
         BIC     (SP)+,(R0)+
         SOB     R1,1$
 2$:     MOV     @SP,R1          ; GET FINAL SET SIZE
         SUB     TOPSIZ,R1       ; SUBTRACT THE TOP SIZE...R1 = DIFF
         BEQ     4$              ; IF NO LEFTOVER WORDS THEN EXIT
 3$:     CLR     (R0)+           ; ELSE CLEAR EXTRA WORDS IN FINAL SET
         SOB     R1,3$
 4$:     MORE
 TOPSIZ: .WORD           ; SIZE OF TOP SET (TEMP)

 IOR:    ; LOGICAL OR
         BIS     (SP)+,@SP
         MORE

 MOD:    ; INTEGER REMAINDER DIVIDE
         MOV     (SP)+,R1
         MOV     (SP)+,R0
         JSR     PC,DIV
         MOV     R1,-(SP)
         MORE

 MPI:    ; INTEGER MULTIPLY
         MOV     (SP)+,R0
         MOV     (SP)+,R1
         JSR     PC,MLI
         MOV     R0,-(SP)
         MORE

 MPR:    ; REAL MULTIPLY
         .IF     DF,FPI
         FMUL    SP
         MORE
         .IFF
         JSR     R4,ENTFP
         .WORD   $MLR,XITFP
         .ENDC

 NGI:    ; INTEGER NEGATION
         NEG     @SP
         MORE

 NGR:    ; REAL NEGATION
         TST     @SP
         BEQ     1$
         ADD     #100000,@SP
 1$:     MORE

 NOT:    ; LOGICAL NOT
         COM     @SP
         MORE

 SRS:    ; BUILD SUBRANGE SET
         MOV     (SP)+,R0        ; GRAB HIGHER VALUE J OF I..J
         MOV     (SP)+,R1        ; AND LOWER VALUE I
         BMI     NULSET          ; IF I IS NEG THEN NULL SET TIME
         CMP     R1,R0           ; IF I > J THEN
         BGT     NULSET          ; ALSO A NULL SET
         MOV     #1,SETWDS       ; FINAL SET SIZE...START WITH 1 WORD
         MOV     #177777,-(SP)   ; OF ALL ONES
         MOV     R0,BK           ; CLEAR HIGH BITS 15 DOWNTO J
         BIC     #177760,BK      ; USE LOW BITS IN BK FOR CLRMSK INX
         ASL     BK              ; DOUBLE FOR WORDS INDEX
         BIC     CLRMSK+2(BK),@SP ; HIGH ORDER BITS GONE NOW
         BIS     #17,R0          ; FIND WORDS TO PUT BETWEEN I..J
         SUB     R1,R0           ; HAVE DIFFERENCE NOW * 16
         .IF     DF,EIS
         ASH     #-4,R0          ; DIV 16...NUMBER WORDS FROM I..J
         .IFF
         ASR     R0
         ASR     R0
         ASR     R0
         ASR     R0
         .ENDC
         BEQ     2$              ; IF ZERO, THEN 1 WORD IS ENOUDH
         ADD     R0,SETWDS       ; ELSE BUMP SET SIZE COUNTER
 1$:     MOV     #177777,-(SP)   ; AND PUSH ALL BIT SET WORDS
         SOB     R0,1$           ; FOR NUMBER WORDS DIFFERENCE
 2$:     MOV     R1,BK           ; NOW ZAP LOW BITS ON TOS WORD
         BIC     #177760,BK      ; THAT ARE LESS THAN I VALUE
         ASL     BK              ; WORD INDEX
         MOV     CLRMSK(BK),BK   ; GRAB HIGH ORDER CLEARING BIT MASK
         COM     BK              ; CHANGE TO LOW ORDER MASK
         BIC     BK,@SP          ; NOW THE ON BITS IN SET ARE OK
         .IF     DF,EIS
         ASH     #-4,R1          ; DIV 16...# OF ZERO TO PUSH NOW
         .IFF
         ASR     R1
         ASR     R1
         ASR     R1
         ASR     R1
         .ENDC
         BEQ     4$              ; IF NO MORE ZEROES THEN SKIP
         ADD     R1,SETWDS       ; ELSE ADD ON ZERO COUNT TO SET SIZE
 3$:     CLR     -(SP)           ; AND LOOP ADDING ON ZEROES
         SOB     R1,3$
 4$:     MOV     SETWDS,-(SP)    ; PUSH SET SIZE...NOW GOOD, CLEAN SET ON STACK
         MOV     #BACK,BK
         MORE
 SETWDS:         .WORD   ; SIZE OF SET BUILD ABOVE STUCK HERE

 SBI:    ; INTEGER SUBTRACT
         SUB     (SP)+,@SP
         MORE

 SBR:    ; REAL SUBTRACT
         .IF     DF,FPI
         FSUB    SP
         MORE
         .IFF
         JSR     R4,ENTFP
         .WORD   $SBR,XITFP
         .ENDC

         ; SGS IS BELOW THE SQUARE OPS

 SQI:    ; SQUARE INTEGER
         MOV     @SP,-(SP)
         BR      MPI

 SQR:    ; SQUARE REAL
         MOV     2(SP),-(SP)
         MOV     2(SP),-(SP)
         BR      MPR

 NULSET: CLR     -(SP)           ; ZERO WORD SET SIZE
         MORE

 SGS:    ; MAKE SINGLETON SET
         MOV     (SP)+,R0        ; GET THE SCALAR VALUE WANTED
         BMI     NULSET          ; IF NEGATIVE THEN GO BUILD A NULL SET
         CLR     -(SP)           ; PUT A WORD TO SET BIT INN
         MOV     R0,R1           ; NOW SET PROPER BIT IN TOS
         BIC     #177760,R1      ; ZAP ALL BUT LOW 4 BITS
         ASL     R1              ; MAKE A WORD INDEX IN BITTER
         BIS     BITTER(R1),@SP  ; NOW WE HAVE PROPER BIT SET
         BIC     #170017,R0      ; ZAP ALL BUT WORD BITS
         BEQ     2$              ; IF NO ZEROES NEEDED THEN DONE
         .IF     DF,EIS
         ASH     #-4,R0
         .IFF
         ASR     R0
         ASR     R0
         ASR     R0
         ASR     R0
         .ENDC
         MOV     R0,R1           ; SAVE WORD COUNT FOR LATER PUSH
 1$:     CLR     -(SP)           ; CLEAR A STACK WORD
         SOB     R1,1$
 2$:     INC     R0              ; SET R0 TO TOTAL SET SIZE
         MOV     R0,-(SP)        ; AND PUSH IT FINALLY
         MORE

 STO:    ; STORE INDIRECT
         MOV     (SP)+,@(SP)+
         MORE

 IXS:    ; STRING INDEX...DYNAMIC RANGE CHECK
         MOV     @SP,R0          ; GRAB INDEX VALOUE
         BEQ     IXSERR          ; ZERO INDEX IS AN ERROR
         CMP     R0,#255.        ; CHECK IF WAY TOO BIG
         BHI     IXSERR          ; BOMB IF SO
         CMPB    R0,@2(SP)       ; CHECK INDEX AGAINST STRING LENGTH
         BHI     IXSERR          ; AND BOMB FOR THAT TOO
         ADD     (SP)+,@SP       ; OK...ADD THE INDEX TO ADDR ON TOS
         MORE
 IXSERR: TRAP    INVNDX

 UNI:    ; SET UNION
         JSR     PC,SETADJ
         BEQ     2$
 1$:     BIS     (SP)+,(R0)+
         SOB     R1,1$
 2$:     MORE

 S2P:    ; STRING TO PACKED ARRAY CONVERT
         INC     2(SP)
         MORE

 LDCN:   ; LOAD CONSTANT NIL
         .IIF    EQ,NIL,                 CLR     -(SP)
         .IIF    NE,NIL,                 MOV     #NIL,-(SP)
         MORE

 ADJ:    ; SET ADJUST
         GETBYTE                 ; GRAB REQUESTED SET SIZE
         MOV     (SP)+,R1        ; GET SET SIZE FROM TOS
         CMP     R1,R0           ; COMPARE SET SIZE TO REQ SIZE
         BLT     EXPAND          ; IF SET TOO SMALL THEN EXPAND IT
         BGT     CRUNCH          ; IF TOO BIG THEN CRUNCH THE SET
         MORE                    ; ELSE ALL'S OK...NEXT INSTRUCTION
 CRUNCH:         MOV     R0,BK   ; SAVE REQUESTED LENGTH
         ASL     R0              ; NOW POINT R0 AT TOP OF VALID PART OF SET
         ADD     SP,R0
         ASL     R1              ; POINT R1 ABOVE ENTIRE SET...IS DEST
         ADD     SP,R1           ; FOR FUTURE MOVES TO CRUNCH OUT JUNK
 1$:     MOV     -(R0),-(R1)     ; COPY THE WORDS OF GOOD SEOT PART
         SOB     BK,1$
         MOV     R1,SP           ; R1 IS NEW TOS...CUT BACK STUFF
         BR      XITADJ
 EXPAND: MOV     SP,BASE         ; REMEMBER TOP OF SMALL SET
         SUB     R1,R0           ; R0 HAS SET SIZE DIFFERENCE NOW
         MOV     R0,BK           ; SAVE DIFF FOR LATER ZEROING
         ASL     R0              ; DOUBLE FOR WORD COUNT
         SUB     R0,SP           ; ADD JUNK ONTO STACK POINTER FOR ZERO FILL
         MOV     SP,R0           ; NOW DEST FOR SET COPYING
         TST     R1              ; CHECK IF OLD SET SIZE = 0!!
         BEQ     2$              ; IF SO THEN DONT DO LOOP...SYSBOMB!
 1$:     MOV     (BASE)+,(R0)+   ; COPY THE SET NOW
         SOB     R1,1$
 2$:     CLR     (R0)+           ; NOW ZERO IN THE REST OF SET
         SOB     BK,2$
         MOV     STKBAS,BASE     ; RESTORE SCRATCH REG
 XITADJ: MOV     #BACK,BK        ; RESTORE THIS TOO
         MORE

         ; FJP IS UP AHEAD WITH UJP

 INC:    ; INCREMENT TOS BY PARAM
         GETBIG
         ADD     R0,@SP
         MORE

 IND:    ; INDIRECT LOAD
         GETBIG
         ASL     R0
         ADD     R0,@SP
         MOV     @(SP)+,-(SP)
         MORE

 IXA:    ; INDEX ARRAY
         GETBIG  R1              ; GET # WORDS PER ELEMENT
         MOV     (SP)+,R0        ; GRAB USER'S INDEX VALUE
         BEQ     2$              ; IF ZERO, THEN DONE ALREADY!
         CMP     R1,#1           ; CHECK IF 1 WORD ELS
         BEQ     1$              ; IF SO THEN NO MULTIPLY
         JSR     PC,MLI
 1$:     ASL     R0              ; NOW DOUBLE INDEX VALUE FOR WORDS
         ADD     R0,@SP          ; NEW ADDRESS OFO ARRAY ELEMENT NOW
 2$:     MORE

 LAO:    ; LOAD GLOBAL ADDRESS
         GETBIG
         ASL     R0
         .IIF    NE,MSDLTA,      ADD     #MSDLTA,R0
         ADD     BASE,R0
         MOV     R0,-(SP)
         MORE

 LCA:    ; LOAD CONSTANT (STRING) ADDRESS
         MOV     IPC,-(SP)
         GETBYTE                 ; GRAB STRING LENGTH
         ADD     R0,IPC          ; AND SKIP IPC PAST STRING
         MORE

 LDO:    ; LOAD GLOBAL
         GETBIG
         ASL     R0
         .IIF    NE,MSDLTA,      ADD     #MSDLTA,R0
         ADD     BASE,R0
         MOV     @R0,-(SP)
         MORE

 MOV:    ; MOVE WORDS
         GETBIG  BK              ; GRAB # WORDS TO MOVE (ALWAYS > 0)
         MOV     (SP)+,R0        ; SOURCE ADDRESS
         MOV     (SP)+,R1        ; DESTINATION ADDRESS
 1$:     MOV     (R0)+,(R1)+     ; COPY EACH WORD
         SOB     BK,1$
         MOV     #BACK,BK
         MORE

 MVB:    ; MOVE BYTES
         GETBIG  BK              ; GRAB # BYTES TO MOVE (ALWAYS > 0)
         MOV     (SP)+,R0        ; SOURCE ADDRESS
         MOV     (SP)+,R1        ; DESTINATION ADDRESS
 1$:     MOVB    (R0)+,(R1)+     ; COPY EACH BYTE
         SOB     BK,1$
         MOV     #BACK,BK
         MORE

 SAS:    ; STRING ASSIGNMENT
         MOV     (SP)+,R0        ; GET SOURCE STRING ADDRESS
         CMP     R0,#255.        ; CHECK IF ITS REALLY A CHAR
         BHI     1$              ; IF NOT THEN SKIP TRICKYNESS
         MOVB    R0,LITCHR+1     ; LIT CHAR...MAKE IT A STRING
         MOV     #LITCHR,R0      ; NOW R0 HAS GOOD ADDRESS
 1$:     CMPB    @R0,(IPC)+      ; CHEOCK IF MAXLENG IS EXCEEDED BY SRC LENG
         BHI     SASERR          ; BOMB OUT IF SO
         MOV     (SP)+,R1        ; GRAB DESTINATION ADDRESS
         CLR     BK              ; SET UP LOOP COUNTER WITH SOURCE LENGTH
         BISB    @R0,BK          ; NOW BK HAS LENGTH COUNT OF SOURCE
         INC     BK              ; INCLUDE LENGTH BYTE IN LOOP COUNT
 2$:     MOVB    (R0)+,(R1)+     ; COPY EACH BYTE
         SOB     BK,2$           ; LOOP FOR CHARS+LENGTH BYTE
         MOV     #BACK,BK        ; RESTORE
         MORE
 LITCHR:         .WORD   1       ; DUMMY STRING OF LENGTH 1
 SASERR:         TRAP    INVNDX

 SRO:    ; STORE GLOBAL
         GETBIG
         ASL     R0
         .IIF    NE,MSDLTA,      ADD     #MSDLTA,R0
         ADD     BASE,R0
         MOV     (SP)+,@R0
         MORE

 XJP:    ; INDEX JUMP
         WORDBOUND
         MOV     (SP)+,R0        ; GRAB INDEX VALUE FROM TOS
         MOV     (IPC)+,R1       ; GET MIN CASE INDEX FROM CODE
         CMP     R0,R1           ; SEE IF INDEX IS TOO SMALL
         BLT     MINERR          ; SKIP OUT IF NOT IN RANGE
         CMP     R0,(IPC)+       ; CHECK IF LEQ MAX VALUE
         BGT     MAXERR          ; SKIP OUT HERE TOO
         TST     (IPC)+          ; SKIP OVER ELSE JUMP WORD
         SUB     R1,R0           ; ADJUST INDEX TO 0..N
         ASL     R0              ; DOUBLE INDEX FOR WORD STUFF
         ADD     R0,IPC          ; POINT IPC AT PROPER JUMP TABLE INDEX
         SUB     @IPC,IPC        ; NOW IPC POINTS AT STATEMENT SELECTED
         MORE
 MINERR: TST     (IPC)+          ; SKIP IPC TO ELSE JUMP LOCATION
 MAXERR: MORE                    ; IPC POINTS AT ELSE JUMP...ONWARD

 COMPAR: ; COMPARE COMPLEX THINGS
         ; RELOPS EQU, GRT, GEQ, LEQ, LES, & NEQ
         GETNEXT         R1      ; GRAB COMPARISON TYPE
         MOV     CMPTBL(R1),PC   ; NOW TRANSFER TO PROPER CODE

 REALCMP:; COMPARE REAL
         MOV     SBROPS(R0),1$
         .IF     DF,FPI
         FSUB    SP
 1$:     NOP
         BR      2$
         TST     (SP)+
         MOV     #1,@SP
         MORE
 2$:     TST     (SP)+
         CLR     @SP
         MORE
         .IFF
         JSR     R4,ENTFP
         .WORD   $CMR,1$,XITFP
 1$:     NOP
         BR      2$
         MOV     #1,-(SP)
         JMP     @(R4)+
 2$:     CLR     -(SP)
         JMP     @(R4)+
         .ENDC

 BYTECMP:; COMPARE BYTE STRING
         GETBIG  BK
 CMP.IT: MOV     UBROPS(R0),2$   ; PUT IN PROPER CMP OPERATOR
         MOV     (SP)+,R1        ; RIGHT HAND EXPRESSION ADDR
         MOV     (SP)+,R0        ; LEFT EXPRESSION
 1$:     CMPB    (R0)+,(R1)+     ; COMPARE BYTES
         BNE     2$              ; ANY NEQ STOPS LOOP
         SOB     BK,1$
 2$:     NOP
         BR      4$
         MOV     #1,-(SP)
 3$:     MOV     #BACK,BK
         MORE
 4$:     CLR     -(SP)
         BR      3$

 STRGCMP:; COMPARE STRING VARIABLES
         CLR     BK
         BISB    @2(SP),BK
         INC     BK              ; INCLUDE LENGTH
         BR      CMP.IT

 WORDCMP:; COMPARE WORDS
         GETBIG  BK
         ASL     BK
         BR      CMP.IT

 BOOLCMP:; COMPARE BOOLEAN OPERANDS
         BIC     #177776,@SP
         BIC     #177776,2(SP)
         MOV     XFRTBL+40.(R0),PC       ; DO INTEGER COMPARE

 POWRCMP:; COMPARE SETS
         JSR     PC,SETADJ       ; ENSURE SETS MAKE SENSE
         MOV     -(R0),BK        ; GET LOWER SET SIZE
         ADD     (R0)+,BK        ; DOUBLE FOR BYTE SIZE
         ADD     R0,BK           ; NOW BK POINTS AT FINAL TOP OF STACK
         MOV     BK,NEWSP
         MOVB    -2(IPC),BK      ; GRAB ORIGINAL INSTRUCTION BYTE
         ASL     BK              ; DOUBLE IT!! WORD INDEX IN XFRSET
         MOV     XFRSET(BK),-(SP) ; STASH TRANSFER ADDRESS...
         MOV     -2(R0),BK       ; ACTUAL OPS EXPECT BK=LOWER SET SIZE
         MOV     (SP)+,PC        ; TRANSFER NOW TO PROPER COMPARE OP

 EQUS:   ; COMPARE SETS EQUAL
         TST     R1              ; NUMBER OF WORDS IN TOP SERT
         BEQ     CHKZER
 1$:     CMP     (SP)+,(R0)+
         BNE     SFALSE
         DEC     BK
         SOB     R1,1$
 CHKZER:         TST     BK
         BEQ     STRUE
 1$:     TST     (R0)+
         BNE     SFALSE
         SOB     BK,1$
         BR      STRUE

 LEQS:   ; LESS THAN OR EQUAL SET COMPARE
         TST     R1
         BEQ     CHKZER
 1$:     BIC     (SP)+,(R0)+
         BNE     SFALSE
         DEC     BK
         SOB     R1,1$
         BR      CHKZER

 GEQS:   ; GREATER OR EQUAL SET COMPARE
         TST     R1
         BEQ     STRUE
 1$:     BIC     (R0)+,(SP)+
         BNE     SFALSE
         SOB     R1,1$
         BR      STRUE

 NEQS:   ; NOT EQUAL SET COMPARE
         TST     R1
         BEQ     2$
 1$:     CMP     (SP)+,(R0)+
         BNE     STRUE
         DEC     BK
         SOB     R1,1$
 2$:     TST     BK
         BEQ     SFALSE
 3$:     TST     (R0)+
         BNE     STRUE
         SOB     BK,3$
 SFALSE: MOV     NEWSP,SP
         CLR     -(SP)
 XITPWR: MOV     #BACK,BK
         MORE
 STRUE:  MOV     NEWSP,SP
         MOV     #1,-(SP)
         BR      XITPWR
 NEWSP:  .WORD

 LDA:    ; LOAD INTERMEDIATE ADDRESS
         GETNEXT                 ; THE DELTA LEX LEVEL
         MOV     MP,R1           ; POINT R1 AT STAT LINKS
 1$:     MOV     @R1,R1          ; LINK DOWN NOW UNTIL
         SOB     R0,1$           ; DELTA LL = 0 (NEVER START AT 0)
         GETBIG                  ; GET DISPLACMENT
         ASL     R0              ; DOUBLE FOR WORD INDEXING
         .IIF    NE,MSDLTA,      ADD     #MSDLTA,R0
         ADD     R1,R0           ; NOW R0 HAS ADDRESS
         MOV     R0,-(SP)        ; PUSH IT
         MORE

 LDC:    ; LOAD MULTIWORD CONSTANT
         GETNEXT                         ; NUMBER OF WORDS TO LOAD (ALWAYS > 0)
         WORDBOUND
 1$:     MOV     (IPC)+,-(SP)
         SOB     R0,1$
         MORE

 LOD:    ; LOAD INTERMEDIATE VALUE
         GETNEXT                 ; THE DELTA LEX LEVEL
         MOV     MP,R1           ; POINT R1 AT STAT LINKS
 1$:     MOV     @R1,R1          ; LINK DOWN NOW UNTIL
         SOB     R0,1$           ; DELTA LL = 0 (NEVER START AT 0)
         GETBIG                  ; GET DISPLACMENT
         ASL     R0              ; DOUBLE FOR WORD INDEXING
         .IIF    NE,MSDLTA,      ADD     #MSDLTA,R0
         ADD     R1,R0           ; NOW R0 HAS ADDRESS
         MOV     @R0,-(SP)       ; COPY VALUE FROM STACK
         MORE

 STR:    ; STORE INTERMEDIATE VALUE
         GETNEXT                 ; THE DELTA LEX LEVEL
         MOV     MP,R1           ; POINT R1 AT STAT LINKS
 1$:     MOV     @R1,R1          ; LINK DOWN NOW UNTIL
         SOB     R0,1$           ; DELTA LL = 0 (NEVER START AT 0)
         GETBIG                  ; GET DISPLACMENT
         ASL     R0              ; DOUBLE FOR WORD INDEXING
         .IIF    NE,MSDLTA,      ADD     #MSDLTA,R0
         ADD     R1,R0           ; NOW R0 HAS ADDRESS
         MOV     (SP)+,@R0       ; SAVE VALUE INTO STACK
         MORE

 NOJUMP: INC     IPC             ; GO HERE IF A TRUE WAS ON STACK
         MORE

 EFJ:    ; INTEGER = THEN FJP
         SUB     (SP)+,(SP)+
         BEQ     NOJUMP
         BR      UJP

 NFJ:    ; INTEGER <> THEN FJP
         SUB     (SP)+,(SP)+
         BNE     NOJUMP
         BR      UJP

 FJP:    ; BRANCH IF FALSE ON TOS
         ROR     (SP)+
         BCS     NOJUMP
         ; NOW FALL INTO UJP

 UJP:    ; BRANCH UNCONDITIONAL
         GETNEXT                 ; GET BRANCH PARAM
         BMI     1$              ; IF < 0 THEN A LONG JUMP
         ADD     R0,IPC          ; ELSE JUST A BYTE OFFSET FORWARD
         MORE
 1$:     MOV     JTAB,IPC        ; POINT IPC AT JTAB ENTRY SO OFFSET
         ADD     R0,IPC          ; IS GOOD...R0 IS < 0   REALLY A SUBTRACT
         SUB     @IPC,IPC        ; POINT IPC AT NEW OBJECT CODE
         MORE

 LDP:    ; LOAD PACKED FIELD
         MOV     @4(SP),R0       ; GET WORD WHICH HAS FIELD IN IT INTO R0
         MOV     (SP)+,R1        ; GET FIELD RIGHT-MOST BIT NUMBER
         .IF     DF,EIS
         NEG     R1
         ASH     R1,R0
         .IFF
         BEQ     NOASR           ; IF ZERO THEN NO SHIFTS NEEDED
 1$:     ASR     R0              ; SHIFT R0 UNTIL FIELD IN LOW BITS
         SOB     R1,1$
 NOASR:
         .ENDC
         MOV     (SP)+,R1        ; GRAB FIELD WIDTH FROM STACK
         ASL     R1              ; DOUBLE IT FOR WORD INDEXING
         BIC     CLRMSK(R1),R0   ; CLEAR SHIT BITS IN WORD
         MOV     R0,@SP          ; NOW PUT FIELD ON STACK
         MORE

 STP:    ; STORE PACKED FIELD
         MOV     4(SP),R1        ; GRAB FIELD WIDTH
         ASL     R1              ; DOUBLE FOR WORD INDEX
         MOV     CLRMSK(R1),R1   ; NOW WE HAVE A CLEARING MASK IN R1
         MOV     (SP)+,R0        ; GRAB INSERT VALUE FROM STACK
         BIC     R1,R0           ; ZAP JUNK BITS IN INSERT VALUE
         COM     R1              ; NOW R1 WILL ZAP THE FIELD ITSELF
         MOV     (SP)+,BK        ; GET FIELD RIGHT-MOST BIT
         .IF     DF,EIS
         ASH     BK,R0
         ASH     BK,R1
         .IFF
         BEQ     NOASL           ; IF IN RIGHT-MOST BIT THEN NO SHIFT
 1$:     ASL     R0              ; SHIFT INSERT VALUE BY ONE
         ASL     R1              ; AND SHIFT CLEAR MASK
         SOB     BK,1$           ; AND DO SO UNTIL LINED UP WITH FIELD
 NOASL:
         .ENDC
         TST     (SP)+           ; FORGET THE OLD FIELD WIDTH
         MOV     (SP)+,BK        ; BK NOW HAS ADDRESS OF PACKED FIELD WORD
         BIC     R1,@BK          ; SET FIELD IN WORD TO ZEROES
         BIS     R0,@BK          ; NOW OR IN THE INSERT VALUE
         MOV     #BACK,BK        ; RESTORE SCRATCH REG
         MORE

 LDM:    ; LOAD MULTIPLE WORDS
         MOV     (SP)+,R1        ; GET WORD LIST ADDRESS
         GETBYTE                 ; AND GET WORD COUNT
         BEQ     NOLOAD          ; MAY HAPPEN SOMEDAY
         ADD     R0,R1           ; SKIP LIST ADDRESS TO UPPER END
         ADD     R0,R1           ; R1 NOW POINTS ABOVE DATA BLOCK
 1$:     MOV     -(R1),-(SP)
         SOB     R0,1$
 NOLOAD:         MORE

 STM:    ; STORE MULTIPLE WORDS
         GETBYTE                 ; GET NUMBER OF WORDS
         BEQ     NOSTOR
         MOV     SP,R1           ; POINT R1 AT DATA BLOCK ON STACK
         ADD     R0,R1           ; SKIP R1 PAST THE DATA TO GET THE
         ADD     R0,R1           ; STORE ADDRESS BELOW IT
         MOV     @R1,R1          ; GET STORE ADDRESS NOW
 1$:     MOV     (SP)+,(R1)+
         SOB     R0,1$
 NOSTOR: TST     (SP)+           ; CHUCK ADDRESS WORD
         MORE

 LDB:    ; LOAD BYTE
         MOV     @SP,R0
         CLR     @SP
         BISB    @R0,@SP
         MORE

 STB:    ; STORE BYTE
         MOVB    (SP)+,@(SP)+
         MORE

 IXP:    ; INDEX PACKED ARRAY
         GETNEXT R1              ; GET # ELEMENTS PER WORD
         MOV     (SP)+,R0        ; GET USER'S INDEX VALUE
         JSR     PC,DIV          ; NOW DIVIDE OUT WORD INX AND BIT INX
         ADD     R0,@SP          ; ADD WORD INDEX TO BASE ADDR ON TOS
         ADD     R0,@SP          ; TO BUILD WORD ADDRESS FOR LDP
         GETNEXT                 ; GET ELEMENT WIDTH
         MOV     R0,-(SP)        ; NOW PUSH EL WIDTH FOR LDP STUFF
         CLR     -(SP)           ; NOW THE RIGHT-MOST BIT
 1$:     ASR     R1              ; NOW A SHORT MULTIPLY FOR SMALL VALUES
         BCC     2$              ; SKIP IF THE MULTIPLICAND BIT IS OFF
         ADD     R0,@SP
 2$:     ASL     R0              ; DOUBLE ADDEND
         TST     R1              ; ANY MULTIPLICATION AT ALL?
         BNE     1$              ; IF SO THEN KEEP LOOPING
         MORE

 EQUI:   ; INTEGER EQUAL COMPARE
         SUB     (SP)+,@SP
         BEQ     PSHTRU
 PSHFLS: CLR     @SP
         MORE
 PSHTRU: MOV     #1,@SP
         MORE

 GEQI:   ; INTEGER GREATER OR EQUAL COMPARE
         SUB     (SP)+,@SP
         BGE     PSHTRU
         BR      PSHFLS

 GRTI:   ; INTEGER GREATER THAN COMPARE
         SUB     (SP)+,@SP
         BGT     PSHTRU
         BR      PSHFLS

 LLA:    ; LOAD LOCAL ADDRESS
         GETBIG
         ASL     R0
         .IIF    NE,MSDLTA,      ADD     #MSDLTA,R0
         ADD     MP,R0
         MOV     R0,-(SP)
         MORE

 LDCI:   ; LOAD LONG INTEGER CONSTANT
         MOVB    (IPC)+,-(SP)
         MOVB    (IPC)+,1(SP)
         MORE

 LEQI:   ; INTEGER LESS THAN OR EQUAL COMPARE
         SUB     (SP)+,@SP
         BLE     PSHTRU
         BR      PSHFLS

 LESI:   ; INTEGER LESS THAN COMPARE
         SUB     (SP)+,@SP
         BLT     PSHTRU
         BR      PSHFLS

 LDL:    ; LOAD LOCAL
         GETBIG
         ASL     R0
         .IIF    NE,MSDLTA,      ADD     #MSDLTA,R0
         ADD     MP,R0
         MOV     @R0,-(SP)
         MORE

 NEQI:   ; INTEGER NOT EQUAL COMPARE
         SUB     (SP)+,@SP
         BNE     PSHTRU
         BR      PSHFLS

 STL:    ; STORE LOCAL
         GETBIG
         ASL     R0
         .IIF    NE,MSDLTA,      ADD     #MSDLTA,R0
         ADD     MP,R0
         MOV     (SP)+,@R0
         MORE

 S1P:    ; STRING TO PACKED ON TOS
         INC     @SP
         MORE

 IXB:    ; INDEX BYTE ARRAY
         ADD     (SP)+,@SP
         MORE

 BYT:    ; CONVERT WORD TO BYTE ADDR
         MORE

 ; EQUAL FJP AND NOT EQUAL FJP ARE AT FJP

 XIT:    ; EXIT SYSTEM
         HALT
         TRAP    SYSERR

 NOP:    ; NO OPERATION
         MORE

 ENTFP:  ; THIS SUBROUTINE STARTS THE THREADED CODE
         ; SEQUENCE A-LA FPMP $POLSH.  THE DIFFERENCE IS
         ; WE SAVE IPC REGISTER (R4)
         MOV     (SP)+,FPIPC     ; IPC MUST BE R4!!!
         JMP     @(R4)+          ; THREAD IT

 FPIPC:  .WORD   ; SAVE R4 (IPC) REG HERE

 XITFP:  ; HERE IS WHERE WE EXIT FROM FPMP BUSINESS
         MOV     LASTMP,MP
         MOV     #BACK,BK
         MOV     STKBAS,BASE
         MOV     FPIPC,IPC
         MORE

 SETADJ: ; THIS IS A SUBROUTINE CALLED BY SET OPERATIONS
         ; TO MASSAGE SET SIZES AND REGISTERS...SEE THOSE OPS
         MOV     (SP)+,RETADR    ; SAVE RETURN ADDRESS
 TRYAGN: MOV     (SP)+,R1        ; GRAB SET SIZE
         MOV     SP,R0           ; NOW POINT R0 AT NEXT SET
         ADD     R1,R0
         ADD     R1,R0
         CMP     (R0)+,R1        ; COMPARE FIRST SET SIZE WITH SECOND (TOP) SIZE
         BGE     SETSOK          ; QUIT IF SIZES ARE OK
         MOV     R1,-(SP)        ; ELSE EXPAND LOWER SET BY SHOVING IN 0-S
         MOV     -(R0),BK        ; GET SMALLER SET SIZE
         MOV     R1,@R0          ; CHANGE IT TO FINAL SIZE AFTER EXPAND
         MOV     R1,R0           ; CALCULATE NUMBER OF EXTRA ZEROES NEEDED
         SUB     BK,R0           ; R0 = TOPSIZE-LOWERSIZE
         MOV     R0,ZEROES       ; STASH IT FOR LATER USE
         ADD     BK,R1           ; NOW SET R1 TO TOTAL NUMBER OF WORDS TO COPY
         ADD     #2,R1           ; BE SURE TO INCLUDE SIZE WORDS
         MOV     SP,BK           ; POINT BK AT OLD TOS
         ASL     R0              ; DOUBLE SIZE DIF TO BYTES
         SUB     R0,SP           ; AND BUMP STACK TO MAKE ROOM
         MOV     SP,R0           ; NOW R0 IS DEST POINTER FOR COPY
 1$:     MOV     (BK)+,(R0)+     ; COPY EACH WORD IN STACK
         SOB     R1,1$           ; LOOP FOR TOTAL SET SIZES
         MOV     ZEROES,R1       ; NOW COPY IN ZEROES BELOW SETS
 2$:     CLR     (R0)+
         SOB     R1,2$
         MOV     #BACK,BK        ; RESTORE REG
         BR      TRYAGN          ; RESET REGISTERS AND EXIT
 ZEROES:         .WORD           ; TEMP FOR ABOVE EXPAND
 SETSOK: TST     R1              ; LEAVE CC WITH R1 VALUE
         JMP     @(PC)+          ; BACK TO CALLER...LEAVE CC ALONE
 RETADR:         .WORD

         .PAGE
         .CSECT  TABLES
         .GLOBL  XFRTBL
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;                                                                   ;
 ;                       OPERATOR TRANSFER TABLES                    ;
 ;                                                                   ;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

 XFRTBL  = . + 400       ; USE NEGATIVE INDEXES TO GET TO OPS
         .WORD   ABI
         .WORD   ABR
         .WORD   ADI
         .WORD   ADR
         .WORD   AND
         .WORD   DIF
         .WORD   DVI
         .WORD   DVR
         .WORD   CHK
         .WORD   FLO
         .WORD   FLT
         .WORD   INN
         .WORD   INT
         .WORD   IOR
         .WORD   MOD
         .WORD   MPI
         .WORD   MPR
         .WORD   NGI
         .WORD   NGR
         .WORD   NOT
         .WORD   SRS
         .WORD   SBI
         .WORD   SBR
         .WORD   SGS
         .WORD   SQI
         .WORD   SQR
         .WORD   STO
         .WORD   IXS
         .WORD   UNI
         .WORD   S2P
         .BLKW   1
         .WORD   LDCN
         .WORD   ADJ
         .WORD   FJP
         .WORD   INC
         .WORD   IND
         .WORD   IXA
         .WORD   LAO
         .WORD   LCA
         .WORD   LDO
         .WORD   MOV
         .WORD   MVB
         .WORD   SAS
         .WORD   SRO
         .WORD   XJP
         .BLKW   2
         .WORD   COMPAR
         .WORD   COMPAR
         .WORD   COMPAR
         .WORD   LDA
         .WORD   LDC
         .WORD   COMPAR
         .WORD   COMPAR
         .WORD   LOD
         .WORD   COMPAR
         .WORD   STR
         .WORD   UJP
         .WORD   LDP
         .WORD   STP
         .WORD   LDM
         .WORD   STM
         .WORD   LDB
         .WORD   STB
         .WORD   IXP
         .WORD   0,0
         .WORD   EQUI
         .WORD   GEQI
         .WORD   GRTI
         .WORD   LLA
         .WORD   LDCI
         .WORD   LEQI
         .WORD   LESI
         .WORD   LDL
         .WORD   NEQI
         .WORD   STL
         .BLKW   3.
         .WORD   S1P
         .WORD   IXB
         .WORD   BYT
         .WORD   EFJ
         .WORD   NFJ
         .WORD   BPT
         .WORD   XIT
         .WORD   NOP
         .LIST   ME
         .IRP    N,<1,2,3,4,5,6,7,10,11,12,13,14,15,16,17,20>
         .WORD   SLDLS+<6*<N-1>>
         .ENDR
         .IRP    N,<1,2,3,4,5,6,7,10,11,12,13,14,15,16,17,20>
         .WORD   SLDOS+<6*<N-1>>
         .ENDR
         .IRP    N,<0,1,2,3,4,5,6,7>
         .WORD   SINDS+<10*N>
         .ENDR
         .NLIST  ME

         .BLKW   3*<MAXUNT+1>    ; UNIT TABLE IN IOTRAP

 CMPTBL:         .WORD   0
         .WORD   REALCMP
         .WORD   STRGCMP
         .WORD   BOOLCMP
         .WORD   POWRCMP
         .WORD   BYTECMP
         .WORD   WORDCMP

 XFRSET  = . + 242
         .WORD   EQUS
         .WORD   GEQS
         .WORD   0,0,0
         .WORD   LEQS
         .WORD   0,0
         .WORD   NEQS

 SBROPS  = . + 242
         BEQ     .+4
         BGE     .+4
         BGT     .+4
         TRAP    SYSERR
         TRAP    SYSERR
         BLE     .+4
         BLT     .+4
         TRAP    SYSERR
         BNE     .+4

 UBROPS  = . + 242
         BEQ     .+4
         BHIS    .+4
         BHI     .+4
         TRAP    SYSERR
         TRAP    SYSERR
         BLOS    .+4
         BLO     .+4
         TRAP    SYSERR
         BNE     .+4

         .RADIX  2.

 BITTER: 0000000000000001
         0000000000000010
         0000000000000100
         0000000000001000
         0000000000010000
         0000000000100000
         0000000001000000
         0000000010000000
         0000000100000000
         0000001000000000
         0000010000000000
         0000100000000000
         0001000000000000
         0010000000000000
         0100000000000000
         1000000000000000

 CLRMSK: 1111111111111111
         1111111111111110
         1111111111111100
         1111111111111000
         1111111111110000
         1111111111100000
         1111111111000000
         1111111110000000
         1111111100000000
         1111111000000000
         1111110000000000
         1111100000000000
         1111000000000000
         1110000000000000
         1100000000000000
         1000000000000000
         0000000000000000

         .END



========================================================================================
DOCUMENT :usus Folder:VOL19:make_i.3.text
========================================================================================

MACRO/OBJ:MAINOP EIS+MACROS+MAINOP
MACRO/OBJ:PROCOP EIS+MACROS+PROCOP
MACRO/OBJ:TRAPS EIS+MACROS+TRAPS
MACRO/OBJ:LP11 EIS+MACROS+LP11
MACRO/OBJ:RX11 EIS+MACROS+RX11
LINK/EXEC:INTERP/PRO MAINOP
PROCOP
TRAPS
LP11
RX11
FORLIB.OBJ
//


========================================================================================
DOCUMENT :usus Folder:VOL19:modem.pas.text
========================================================================================

program modem;
{ Give control of the system to the MODEM }
var i : integer;
procedure gomodem ; external;
begin
        gomodem
end.


        .title  "GOMODEM - Modem redirector"
        .proc   gomodem
;       This function will:
;               1) Find the console register map
;               2) Change it to relfect the -odem
;               3) Point the modem vectors to the console driver
;               4) Point the console vectors to nil
;        This procedure will effectivly redirect control of the
;       P-system to the modem device.
        clr     r0              ; Point to bottom of memory
search:
        mov     (r0)+,r1        ; Get the word to test
        bic     #7,r1           ; Mask off the register select field
        cmp     #177560,r1      ; Test : is this a console pointer ?
        bne     search          ; Keep looking...
        sub     #40,-(r0)       ; Fix the register address
        tst     (r0)+           ; Point to the next cell to continue
        inc     count           ; Found one... only 4 exsist
        cmp     #4,count        ; Was this the last ?
        bne     search          ; No...keep looking
        mov     @#60,r0         ; Swap vectors
        mov     @#120,@#60
        mov     r0,@#120
        mov     @#64,r0
        mov     @#124,@#64
        mov     r0,@#124
        rts     pc
count   .word   0
        .end




========================================================================================
DOCUMENT :usus Folder:VOL19:patch.cont.text
========================================================================================


Problem #5: DLE expansion problems.

     This patch was supplied by Charles Rockwell and is also published in
NewsLetter #7.

     The problem is the console driver software.  For the benefit of those who
speak assembly language, the section of code that sends characters to the 
screen looks like:
        
        1$:     MOV     R0,-(SP)        ;push R0
                CLR     R0              ;get the next character
                BISB    @BUFPTR,R0      ;     cleanly
                TST     DFLAG           ;was last char a DLE
                BEQ     3$              ;     branch if no
                CLR     DFLAG           ;     if yes, R0 has the count
                SUB     #32.,R0         ;expansion count excess 32
                BLE     4$              ;branch if too big
                                        ;DLE expansion
                MTPS    #0              ;interrupts on
        2$:     TSTB    @ITPS           ;port busy?
                BPL     2$              ;branch if yes
                MOVB    #' ,@ITPS       ;send space to screen
                SOB     R0,2$           ;decrement R0, branch if not equal
                                        ;done - R0=0
                MTPS    #200            ;interrupts off
        3$:     CMPB    R0,#DLE         ;is this character a DLE?
                BNE     5$              ;branch if not
                COM     DFLAG           ;     set flag if yes
                CLR     R0              ;
                                        ;send R0 to screen
        5$:     MOVB    R0,@ITPB        ;with no test for busy
                CMPB    R0,#CR          ;was it a carriage return?

     The DLE expansion loop beginning a 2$ sends the required number of spaces
to the screen.  It then falls through the branch to 5$.  R0, (which is null at 
this point), is sent to the screen immediately, without a test for busy.  This 
null usually wipes out the final space of the DLE expansion.  However, there 
is a hardware FIFO buffer in the serial interface to the terminal.  If this 
buffer is empty, it can grab the final space before the null gets there.  This 
is why DLE expansions look good if they only require one or two spaces.

     The fix for the bug requires reassembly and relinking the the entire 
interpreter, and is not practical without DEC's RT-11 operating system.  The 
fix looks like:

        4$:     CLR     R0              ;check for done
        5$:     TSTB    @ITPS           ;   and only then
                MOVB    R0,@ITBP        ;send R0 to the screen
     
     The patch for the bug can be made on any LSI/PDP-11 interpreter.  It is 
installed in the loop that sends the spaces for the DLE expansion to the
screen.  The patch simply reverses the order of the test for busy and the 
sending of the space.  This means that the first space of the DLE expansion 
will be sent without a check for busy.  This shouldn't be a problem, because
the existing code already sends most characters to the screen without checking 
for busy.  (The implied assumption is that the serial interface generates an 
interrupt only if it is not busy).

     The patch changes the code at 2$ to:

                MTPS    #0              ;interrupts on
        2$:     MOVB    #' ,@ITPS       ;send the first space
        6$:     TSTB    @ITPS           ;   wait until not busy
                BPL     6$              ;   before sending next
                SOB     R0,2$           ;branch in not done

     Implementing the patch requires on operating version of PATCH, DISKREAD,
or some similar program that can change selected words on a disk file.  (The 
DEC Console ODT can be used to change the program in memory, but the change 
has to be made every time the system is booted.)

     STEP 1: Use the FILER to make a copy of yoyr system disk, and put your 
system disk in a safe place.  Use only the copy to perform the following 
steps.  After you are certain that all went well, you can call the unmodified 
copy of the system disk an archive copy if you wish, but leave it in a safe
place.  If all didn't go well, you can zero the new copy and start over.

     STEP 2: Boot the copy of the system disk, and execute PATCH or DISKREAD.  
Do whatever is necessary to display block 2 (or block 3 for IV.1) of
SYSTEM.PDP-11.  The result should be a screen full of hex words.  Find your
particular computer model and UCSD version in the table below, and make the
indicated changes.  If the sequence of hex characters is not EXACTLY as shown,
quit immediatly.  This section of the program is full of code sequences that
are almost the same, but almost isn't good enough in this case.  Note that
offsets in the block are decimal, while the code is in hex, per PATCH
convention. The presence or absence of the LSI EIS chip does not make a
difference in the offset.

                PDP-11          LSI-11          LSI-11          LSI-11
                UCSD I.4        UCSD I.4        UCSD IV.0       IV.1 (LS142B)
                UCSD I.5        UCSD I.5
                UCSD II.0       UCSD II.0
                                                                BLOCK 3
OFFSET          244             200             462             302

DATA            FROM    TO      FROM    TO      FROM    TO      FROM    TO
                
                FF8B    FF95    FF8B    FF95    FF8B    FF95    FF8B    FF95
                36FF    2000    4EFF    2000    F0FB    2000    98FA    2000
                FD80    36FF    FD80    4EFF    FD80    F0FB    FD80    98FA
                FF95    FF8B    FF95    FF8B    FF95    FF8B    FF95    FF8B
                2000    30FF    2000    48FF    2000    EAFB    2000    92FA
                30FF    FD80    48FF    FD80    EAFB    FD80    92FA    FD80

     STEP 3:  When the changes are satisfactory, write the block back out to 
the disk.  SYSTEM.PDP-11 is now either hopelessly corrupt, or successfully 
patched.  Reboot the disk, and execute SCREENTEST to find out which.  If the 
patch was successful, the screen patterns should be as advertised, although
there may well be problems remaining in the character set copying routines.

     For those who prefer to try the patch in memory before changing the disk, 
and for those who wich to check the patch in memory, the octal numbers for the 
console ODT are:

        PDP,I.4                 LSI,I.4/II.0            LSI,IV.0

ADDR    FROM    TO      ADDR    FROM    TO      ADDR    FROM    TO

2364    105777  112777  2310    105777  112777  2716    105777  112777
        177466      40          177516      40          175760      40
        100375  177466          100375  177516          100375  175760
        112777  105777          112777  105777          112777  105777
            40  177460              40  177510              40  175752
        177460  100375          177510  100375          175752  100375


     Patch #7, Tab Expansion

     The interp for the pdp-11 hasn't changed much since the days of I.3.  At
that time is was standard for the system to expand tabs to the printer as the
printer used at that time wouldn't do it on its own.  In newer implementations
of the p-system, this convention was dropped, but the -11 was never changed.

     This doesn't cause any problems unless you MUST send CHR ( 11 ), a tab
character to the printer as a control character.  For example, a Diablo printer
must be sent a tab character as part of a control sequence to make it do an
absolute tab.  This means that Diablo printer drivers which work on other p-
systems don't work on the -11.  However a simple fix is shown below.

     The actual printer detects the tab character and jumps to a subroutine to
expand the tab, using a current column count to go the the next 8 column tab
position.  If the character is not a tab, a branch is performed around the
subroutine call.  The patch is to change this conditional branch to a non-
conditional branch.

     This original code is:
     
                .
                .
                CMPB    R0,#HT                 ; is it a tab
                BNE     4$                     ; if not continue
                JSR     PC,LPTABR              ; if so, send some spaces
        4$      INC     LP.COL                 ; increment the column count
                .
                .
 
     We change the BNE to a BR and the patch is done.  To do the patch, follow
these instructions.

     1) Make a backup copy of system.pdp-11.

     2) Invoke PATCH and R(read SYSTEM.PDP-11.  V(erify block 0.

     3) Look at the contents of location 128 decimal (200 octal)  and note it.
This is the location of the beginning of the printer driver.  If you have done
the X-ON/X-OFF patch above, you will have to look at the contents of the last
word of that patch instead.  Convert this value to decimal (the program
HEXDECOCT.TEXT on volume 5 helps a lot here but remember to flip the bytes as
HEXDECOCT expects inputs non-flipped).  Divide the value by 512 (decimal). The
non-fractional part of the result is the block number of the block in which the
patch will be made and the remainder multiplied by 512 is the offset into the
block.  Add 124 decimal to the offset to get the offset into the printer driver
of the offending instruction.

     4) At this location you should see 0202 (hex) or 001002 (octal). This is
the BNE instruction.  The previous word should be 0900 (byte flipped hex) or
11 octal.  This is the value of a tab.  Change the 0202 to 0201 (byte flipped
hex for a BR) or 000402 (octal), a branch of two words.

     5) Save the block and you are done.  Test the patch by sending some tabs
to your printer.  If your printer does its own tabs, you will not see any
difference.  If your printer doesn't recognize tabs, it won't tab.
     
     


========================================================================================
DOCUMENT :usus Folder:VOL19:patches.text
========================================================================================

                        Patching Your LSI-11 Interpreter

                                  compiled by
                                        
                                George Schreyer

                                        
     The LSI-11 implementation of the UCSD p-system has some bugs which make 
it act differently than most other implementations.  The specific problems are 
described below.

     1) The system comes preconfigured for parallel printers (the
Printronix in particular).  This will cause the system to crash if a serial
interface is used at the printer port.  This problem occurs ONLY in
version II.0.

     2) If a serial printer is used, the interpreter cannot recognize the
standard X-ON/X-OFF protocol of typical serial (RS-232) printers.  The symptom
is the loss of printed data due to printer buffer overflows.

     3) The interpreter strips the parity bit off incoming characters at
the remote port, REMIN:.  This prevents 8 bit data (such as found in code and
data files) from being read from REMIN:.

     4) Your remote port doesn't work and you are using a DLV-11J.  The vectors
of the printer and remote port are not contigious even though the addresses are.
Since your DLV-11J requires that the three non-console devices have contigous
addresses and vectors, you have a hardware/software mismatch.  No one seems to
know why it was done this way, but you can fix it.  See Problem #4 for the
general method of moving port addresses and vectors around.  See Problem #4A for
specific (easy) modifications to get your DLV-11J to work with the remote port.

     5) DLE expansion problems.  If you use UNITWRITES to the console you may
find that the left margin of displayed text is shifted left by one character.
This is a bug in the interpreter which can be fixed so that the - 11 system will
work like any other.  

     6) The control code (5th parameter of UNITREAD and UNITWRITE) does not 
work as specified in the IV.0 internal archecture guide.  You cannot suppress 
the automatic LF after a CR and you cannot suppress special character handling 
on input.  There is no known object patch.

     7) The printer driver expands tabs, it will not send chr ( 9 ).  Instead
it sends 8 spaces.  This may be considered a "feature", but it is not done
on any other version of the p-system that I know of and it causes real problems
when you need an HT as a control character for your printer.  You must send
chr ( 128 + 9 ) instead or you may apply the patch listed below to fix the
problem forever.

     These are the patches that you can make to the interpreter to solve some
of these problems once and for all.

                           Problem #1 System Crashes

     If your system crashes with an unimplemented instruction error anytime
that you access the printer, you must patch the interpreter with a short 
Pascal program, shown below.  Key this program into your computer, compile and 
execute it.  This patch is necessary only in version II.0.

        {Printerfix modifies the interpreter so that the printer will
         work.  This program was obtained from Softech Microsystems}
        
        {You must hard boot to bring in the new version of the
         interpreter}
         
        VAR F: FILE OF PACKED ARRAY [0..255] OF INTEGER;
        BEGIN
        RESET (F,'SYSTEM.PDP-11');
        F^[66]:=F^[64];
        F^[67]:=F^[65];
        SEEK(F,0);
        PUT(F);
        CLOSE(F,LOCK);
        END.

                           Problem #2  Printer Overflows

     
     If your printer goes berserk or loses data after a few lines or pages
have been printed, then your interpreter and printer are not properly
coordinating the transmission of data.  One solution (the one most often used)
is to set the baud rate of the serial printer port to a slow rate so that the
computer cannot send data any faster than the printer can print it.  However
by doing this, you cannot run your printer at its maximum speed.  

     Many serial printers will send an X-OFF character (most often a control-
S) to the serial line when their internal buffers are nearly full.  This
character should be read by the computer and the computer should stop sending
until the printer indicates that it is ready to receive more data by sending
an X-ON character (most often a control-Q).  The UCSD p-system ignores those
control characters and keeps right on sending data to the printer.

     You can patch your interpreter to install a very short routine to cause 
your computer to respond to these characters.  The patch is done with the UCSD 
utility PATCH.  The patch can be done on both version II.0 and IV.0 
interpreters.  This patch was given to me by Eli Willner and is reproduced 
in part below (the original version is in NewsLetter #6).

     The patch described here was designed for the SYSTEM.PDP-11 configured 
for the EIS chip, using RX01 (distributed as LSI.EIS.RX).  However, it will 
not be difficult to discover the appropriate addresses to patch in other 
versions on SYSTEM.PDP-11.

     The patch:

     1) Make a backup copy of your entire system disk.  Be sure to install the 
          software bootstrap.  (This is Very Important!).
          
     2) Invoke the PATCH utility. G(et SYSTEM.PDP-11 and V(iew block 0
          (which has already been read as a result of the G(et).
          
     3) The assumption is made that the trap vector for the printer is at 
          location 128 (decimal).  Note the contents of location 128.  In the 
          version of SYSTEM.PDP-11 described above, the contents should be 
          4822.  After noting the contents, change location 128 to C000.  To 
          do this, go to T(ype mode, position the cursor over location 128, 
          enter H(ex mode and type C000. Type a control-c to accept the 
          change.
          
     4) Location 132 (decimal) should have the same original contents as 128.  
          Change that location to C000 as well and Q(uit the type mode to re-
          enter the main command mode of PATCH.
          
     5) You have just installed a jump to location 192 (decimal).  This
          location contains the copyright message which you are going to
          overwrite with the routine to check for the X-ON/X-OFF characters.
          Make sure that location 192 really is the start of your copyright 
          message.  Do this by typing M(ixed and V(iewing the block.  The 
          first character of the copyright message should be visible at 
          location 192.
          
     6) Change the contents of locations 192-227 to the following:
          DFB5 8000 4CFF 0C03 DFA5 9300 4EFF 0802 DFB5 8000 4CFF FC03 DFA5 
          9100 4EFF F802 5F00 4822
          
     7) Note the number that was formerly in locations 128 and 132 before they 
          were changed.  If is is NOT 4822 then change the last grouping of 
          hex digits from 4822 to the number that you noted.  This causes the 
          patch to jump back to wherever the jump from 128 or 132 went.
          
     8) The presumption is made that your printer sends the X-ON/X-OFF 
          characters with the parity bit set.  If your parity bit is cleared, 
          then change the 9300 to 1300 and the 9100 to 1100.  If your printer
          uses different handshake characters, install the approproate hex
          values instead the of the ones listed.
          
     9) S(ave the block and re-boot your system.  Your printer should not 
          overflow any more.  If the system crashes or your printer still 
          overflows, carefully make sure that you typed the patch in correctly 
          and make sure that your printer is sending the X-ON/X-OFF characters 
          as control-Q/control-S.
                           
                           Problem #3 REMIN: troubles
     
     This patch was supplied by Peter A. Mason and is also published in 
newsletter #6.  

     The remote port, REMIN:, strips the parity bit.  If you just read ASCII
data from REMIN: then you will never notice any trouble.  But if you want to
read 8 bit data from REMIN:, the loss of the 8th bit is a disaster.  The patch
to fix this is quite simple, you just have to locate and change only one byte
in SYSTEM.PDP-11.

     1) Make a backup copy of your entire system disk.  Be sure to install the 
          software bootstrap.  (This is Very Important!).
          
     2) Invoke the PATCH utility and G(et SYSTEM.PDP-11.  R(read block 18 for
          version IV.0 or block 15 for version II.0.  V(eiw the block.  For IV.1
          you may have to calculate the offset of the start of the REMOTE driver
          from the contents of the vector at 80 decimal (120 octal) in block 0,
          that is, unless that you have changed it.  This value is the byte
          flipped hex address of the start of the REMIN: handler.  Refer to the
          section on tab expansion for an explaintion on how to calculate the
          offset.
          
     3) You are looking for the hex grouping FFC5 8000.  Look through the 
          block for this grouping.  IF you calculate it from the value in
          the REMIN: vector, the offending word will be offset 14 bytes from
          the start of the handler.  When you find it, enter T(ype mode and 
          position the cursor over the 8 in 8000.  Enter H(ex mode and type 
          00. Type control-C to make the change and the Q(uit type mode.
          S(ave the block and you are done.
          
     If you have any communications software which uses REMIN:, you should not 
notice any problems unless data is received with the parity bit set.  Since 
the interpreter removed the parity bit, your communications software 
probably never assumed that the bit could be set.  You may have to include a 
statement in your software to check if the ordinal value of received 
characters are above 127 and if they are you must subtract 128 from their 
ordinal value as shown below.

 if ord ( ch ) > 127 then ch := chr ( ord ( ch ) - 128 ) );

     
     Problem #4  REMIN:/REMOUT: address and vector changes

     This patch was supplied by Eli Willner and is also published in NL#7.

     One of the consequences of the current unfortunate lack of an adaptable p-
System for the LSI/PDP-11 computers, is the inablilty of the user to custom 
configure the device and vector addresses of the various Q-bus peripherals.

     Presently, the LSI/PDP-11 p-System has all vector and device addresses 
"hard-wired" to certain "standard" values.  The user who requires different 
addresses (eg. the system may be running other operating systems >shudder< 
besides the p-System) has no recourse.

     This causes problems most frequently with the remote serial port, whose 
address are perhaps the least "standard" of Q-bus devices.  Herewith, we 
describe a patch to SYSTEM.PDP-11 to allow the user to set the remote serial 
port device and vector addresses to whatever values are required.  I am 
indebted to Walt Farrell for supplying this patch.

     We assume for purposes of illustration that the current device address is 
177520 and the current vector address is 120 (the "standard" values) and it is 
desired to change the device address to 177570 and the vector address to 320.

     1.  Make a backup copy of your system disk, including SYSTEM.PDP-11.  
VERY IMPORTANT!!!

     2. E(xecute the Patch utility, and G(et block 0 to the SYSTEM.PDP-11.

     3. V(iew block 0.  At the current vector location of 120 (octal), which 
is 80 (decimal), are 4 words containing the REMIN and REMOUT interrupt 
vectors.  These consist of the REMIN interrupt address and its priority, 
followed by the REMOUT interrupt address and its priority.  These values may 
differ from one version of SYSTEM.PDP-11 to another; in any case note them.  
For purposes of illustration, assume that these values to be 6424 8000 9C23 
8000 in byte-flipped hex.

     4. After noting the values, get into T(ype mode, and change all four 
words to zeros.

     5. We are going to change the vector to 320 (octal), or 208 (decimal), so
V(iew the value there in character mode.  That location should be within the 
copyright notice.  MAKE SURE THAT THE FOUR WORDS AT YOUR NEW VECTOR LOCATION 
ARE IN A "DEAD CODE" AREA OF THE INTERPRETER!  If you neglect to do this, you
may be wrecking some vital interpreter code. [Note that this patch location
will interfere with the XON/XOFF patch described above.  If you are using that
patch, you will have to relocate it to some other "dead code" area, if you can 
find one.  Good luck to you!]

     6. Get into T(ype mode, and copy the four words you noted earlier to the 
area beginning at 203 (decimal) [in this example].  S(ave block 0 to disk.  
You have just completed the modification to the interrupt vector.

     7. We must now modify the device address.  Examine the first and third 
words of the four previously noted (the REMIN and REMOUT interrupt routine
address, respectively) and find the lower of those two numbers.  (This 
procedure is easiest if the values are first converted from byte-flipped hex 
to decimal.) In our example case, this value is 9C23, or 9116 (decimal).

     8. This value must now be converted into a block number and offset into
SYSTEM.PDP-11.  Divide it by 512.  The quotient is the block number; the 
remainder is the offset.  In our example case we get block number 17, offset 
412.

     9. G(et block 17 and V(iew it.  Subtract 44 from the remainder, yielding 
[in our example] 368.  Examine byte 368 in block 17.  It and the three words
beyond it should contain 50FF 52FF 54FF 56FF in byte-flipped hex, which are
177520, 177522, 177524, 177526 (octal), the address of the REMOTE ports.

     10.  IF THESE ARE THE VALUES YOU GET (or the equivalent for your system) 
change the four words to 78FF 7AFF 7CFF 7EFF, which are 177570 177572 177574 
177576 (octal) (or your equivalent).  IF THESE ARE NOT THE VALUES YOU GET then 
you are at the wrong location in the interperter.  Do NOT make any changes.  
If you did make a change and want to keep it, S(ave it to disk.

     Note: You must also change the jumpers or switches on your serial card to 
correspond to whatever vector and addresses you patch into your interpreter.


     Problem 4A.  Getting your DLV-11J to work with the remote port.

     The problem with the DLV-11J is that three of the ports require contigous
addresses and vectors.  The "standard" UCSD printer address is 177510 and the
"standard" remote address is 177520.  These are already contigous so no problem
occurs here.  The problem is that the "standard" printer vector is 200 and the
"standard" remote vector is 120.  These are not contigous!

     The solution would seem easy, move the remote vector to 220, and all is
well.  Not so.  DEC has done a number on you.  If you investigate the problem in
the Interfaces Handbook a little, you will realize that there are not enough
pins available on the DLV-11J to put the address and vectors anywhere you want.
The address must start on even 100's and the vectors must start on even 40's as
the least significant bits of the fields are pre-set.  

     However, the solution is still not too complicated.  You must set port 0 of
the DLV-11J at 177500 and the vector for that port at 200.  Then port 1 comes at
177510 (for the printer) and port 2 comes at 177520 (for the remote).  Port 3 is
the independant port and is probably set at 177560, vector 60, for your
console.  The vector for port 1 is 210 (which will be your new printer vector)
and the vector for port 2 is 220 (which will be your new remote vector).  Note
that if you have an RK05, you are out-of-luck at this point as the standard
vector for the RK05 is also 220.

     Changing vectors is easy.  It is all done in block 0 of your interpreter.
First locate the printer vector at location 200 octal (128 decimal).  Note the
contents of the four words starting at 128 (decimal) and copy them into the four
words immediatly following (starting at 136 decimal).  This moves your printer
vectors.  Next, locate the contents of the four words starting at 120 octal (80
decimal).  Copy these into the four locations starting at 144 decimal.  This
moves your remote vectors.  If you have an RK05, this also wipes out its
vectors, so don't expect it to work.  

     You may also be able to move the vectors to 100, 110, and 120 octal without
damaging anything.  In this case you will only have to copy the printer vector
as the remote vector is already in the right spot.  Unfortunatly, 100 octal is
your clock vector.  This dissallows the use of port 0 of the DLV-11J as
everytime it generates an interrupt, the clock will tick instead.  If nothing is
hooked to that port, you might get away with it, but I haven't tried it.

(*$I patch.cont.text*)





========================================================================================
DOCUMENT :usus Folder:VOL19:procop.text
========================================================================================

         .TITLE  PROCEDURE OPERATORS
         .CSECT  PROCOP
         .GLOBL  CSPTBL
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;                                                                   ;
 ;                       PROCEDURE OPERATORS                         ;
 ;                                                                   ;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 
 OLDSEG: .WORD   ; SEG VALUE TO BE SAVED IN MSCW
 OLDSP:  .WORD   ; SP VALUE ABOVE LOADED CODE IN READIT

 READIT: ; END UP HERE IF SEGMENT IS NOT IN CORE...MAKE ROOM
         ; IN THE STACK AND READ IT.  THEN FALL INTO CIP.
         MOV     R0,R1
         ASL     R0              ; MULTIPLY BY 6 TO INDEX INTO SEGTBL
         ADD     R1,R0
         ASL     R0
         TST     SEGTBL+4(R0)    ; CHECK IF THERE IS CODE IN SEG
         BNE     1$              ; IF SO THEN WE CAN READ IT IN
         TRAP    NOPROC          ; ELSE BOMB FOR SYSTEM ERROR
 1$:     MOV     SP,OLDSP        ; SAVE TOP OF PARAM STACK FOR LATER
         SUB     SEGTBL+4(R0),SP ; OPEN UP GAP LARGE ENOUGH FOR CODE
         MOV     SP,R1           ; REMEMBER MEM ADDR FOR SYIORQ
         UREAD   SEGTBL(R0),R1,SEGTBL+4(R0),SEGTBL+2(R0)
         MOV     OLDSP,R1        ; RETRIEVE POINTER AT PARAM ON STACK
         MOV     R1,R0           ; R0 MUST POINT AT THEM
         TST     -(R1)           ; NOW POINT R1 AT TOP WORD IN PROCTBL
         MOV     R1,SEG          ; WHICH IS THE NEW SEG POINTER VALUE
         CLR     BK              ; NOW OPEN EXTRA STACK SPACE FOR PARAMS...
         BISB    @IPC,BK         ; GET PROCEDURE NUMBER FROM CODE
         ASL     BK              ; DOUBLE FOR WORD INDEXING
         SUB     BK,R1           ; R1 NOW POINTS AT PROCTBL(P#)
         SUB     @R1,R1          ; R1 NOW POINTS AT JTAB FOR CALLED PROC
         SUB     PARMSZ(R1),SP   ; OPEN SOME SPACE FOR DUPLICATE PARAMS
         MOV     #ENDCIP,BK      ; AFTER XCLP...END UP IN CIP
         BR      XCLP

 CXP:    ; CALL EXTERNAL (OTHER SEGMENT) PROCEDURE
         GETNEXT                 ; GRAB SEGMENT # OF CALLED PROC
         BNE     4$              ; IF SEG 0 THEN FAST HANDLING
         MOV     SEG,OLDSEG
         MOV     @#MEMTOP,SEG
         BR      3$
 4$:     CMPB    @SEG,R0         ; ARE WE IN THAT SEGMENT ALREADY?
         BEQ     CIP             ; IF SO THEN DO A NORMAL CALL
         MOV     SEG,OLDSEG      ; HAVE TO FIND NEW SEG...SAVE OLD ONE
         MOV     MP,R1           ; LOOK DOWN MSCW STAT LINKS FOR THE SEG
 1$:     CMPB    @MSSEG(R1),R0   ; IS SEG IN MSCW THE ONE WE WANT?
         BEQ     2$              ; IF SO THEN GO CALL IT
         MOV     MSDYN(R1),R1    ; ELSE LINK DOWN TO NEXT LEVEL
         CMP     R1,@BASE        ; HAVE WE REACHED THE OUTER BLOCK?
         BNE     1$              ; IF NOT THEN GO FOR NEXT LOOP
         BR      READIT          ; ELSE READ IN CODE FROM DISK
 2$:     MOV     MSSEG(R1),SEG   ; SET SEG POINTER TO REQUEST SEG
 3$:     MOV     SP,R0           ; SET UP STUFF FOR CLP
         MOV     #ENDCIP,BK      ; RETURN TO CIP (VERY GENERAL PROC CALLS)
         BR      XCLP            ; AND CALL LOCAL PROC

 CLPERR: TSTB    @SEG            ; CHECK IF CALLING EXECERROR...
         BNE     1$              ; IF NOT SEG 0 THEN CANT BE
         CMPB    @R1,#2          ; PROCEDURE # 2?
         BEQ     NOCARE          ; IF SO THEN DONT CARE ABOUT STCK OVER
 1$:     ADD     DATASZ(R1),SP   ; RESTORE STACK W/O DAMAGE HOPEFULLY
         TRAP    STKOVR

 CLP:    ; CALL LOCAL PROCEDURE
         MOV     SEG,OLDSEG      ; NO SEG CHANGE...SET UP TO SAVE CUR SEG
         MOV     SP,R0           ; NO CODE...LEAVE R0 AT PARAM LIST
 XCLP:   ; ENTER HERE FOR EXTERNAL CALLS...R0 AND OLDSEG DIFFERENT
         GETBYTE R1              ; GET PROCEDURE #
         ASL     R1              ; CHANGE FOR WORD INDEXING
         NEG     R1              ; ENSURE NEGATIVE SINCE SEGP IS ABOVE TABLE
         ADD     SEG,R1          ; NOW R1 POINT AT SEGTABLE ENTRY FOR PROC
         SUB     @R1,R1          ; NOW R1 POINTS AT JTAB FOR PROC
         SUB     DATASZ(R1),SP   ; OPEN UP HOLE IN STACK FOR LOCAL VARS
         CMP     SP,NP           ; SEE IF WE ARE OVERFLOWING INTO HEAP
         BLOS    CLPERR          ; AAAAUUUUGGGGHHH STACK OVERFLOW!!!
 NOCARE: TST     -(SP)           ; HOLE FOR FUTURE SP SAVE
         MOV     IPC,-(SP)       ; SAVE PROCESSOR STATE REGS
         MOV     OLDSEG,-(SP)    ; THUS BUILDING MSCW
         MOV     JTAB,-(SP)
         MOV     MP,-(SP)
         MOV     MP,-(SP)
         MOV     PARMSZ(R1),IPC  ; NOW COPY PARAMS (IF ANY)
         BEQ     2$              ; IF NONE, THEN SKIP MESSINESS
         ASR     IPC             ; WAS NUMBER OF BYTES...NOW WORDS
         MOV     SP,MP           ; SET UP MP TO PARAM COPY PLACE
         ADD     #MSDLTA+2,MP    ; MP NOW POINTS ABOVE MSCW...
 1$:     MOV     (R0)+,(MP)+     ; LOOP AND COPY EACH PARAM WORD
         SOB     IPC,1$
 2$:     MOV     SP,MP           ; NOW FINALLY POINT MP AT STAT LINK
         MOV     MP,LASTMP       ; SAVE THIS FOR EXECUTION ERROR
         MOV     R0,MSSP(MP)     ; STASH OLD SP VALUE
         MOV     R1,JTAB         ; NEW JUMP TABLE POINTER
         MOV     R1,IPC          ; SET UP CODE ENTRY POINT
         ADD     #ENTRIC,IPC     ; POINT IPC AT ENTRY OFFSET WORD
         SUB     @IPC,IPC        ; NOW IPC POINTS AT FIRST CODE BYTE
         MORE                    ; RETURN NOW

 CGP:    ; CALL GLOBAL PROCEDURE
         MOV     #ENDCGP,BK      ; SET UP MAGIC RETURN
         BR      CLP             ; AND CALL LOCAL PROC
 ENDCGP: MOV     BASE,@MP        ; CHANGE STAT LINK TO BASE
         MOV     #BACK,BK        ; RESTORE REGS
         MORE

 CBP:    ; CALL BASE PROCEDURE
         MOV     #ENDCBP,BK
         BR      CLP
 ENDCBP: MOV     BASE,-(SP)      ; ADD ON EXTRA MSCW WORD
         MOV     @BASE,@MP       ; POINT STAT LINK AT OUTER BLOCK
         MOV     MP,BASE         ; SET BASE REG TO THIS NEW PROC
         MOV     BASE,STKBAS     ; BE SURE TO UPDATE PERM BASE REG
         MOV     #BACK,BK        ; RESTORE
         MORE

 CIP:    ; CALL INTERMEDIATE PROCEDURE
         MOV     #ENDCIP,BK
         BR      CLP
 ENDCIP: MOVB    1(R1),BK        ; GRAB LEX LEVEL OF CALLED PROC
         BLE     ENDCBP          ; IF <= 0 THEN A BASE PROC CALL
         MOV     MP,R0           ; NOW SEARCH DOWN DYN LINKS FOR PARENT
 1$:     MOV     MSJTAB(R0),R1   ; GRAB JTAB SAVED IN MSCW
         CMPB    1(R1),BK        ; COMPARE LEX LEVELS
         BLT     2$              ; IS IT LOWER? IF SO THEN FOUND PARENT
         MOV     MSDYN(R0),R0    ; ELSE LINK DOWN TO CALLER OF CURRENT
         BR      1$              ; AND LOOP UNTIL FOUND
 2$:     MOV     @R0,@MP         ; SET UP FOUND STAT LINK
         MOV     #BACK,BK        ; RESTORE AND
         MORE

 RBP:    ; RETURN FROM BASE LEVEL PROCEDURE
         MOV     MSBASE(MP),BASE ; GET BASE FROM MSCW
         MOV     BASE,STKBAS     ; AND SAVE IN PERM WORD
 RNP:    ; RETURN FROM NORMAL PROCEDURE
         MOV     MSSP(MP),R0     ; POP OLD SP VALUE
         GETNEXT R1              ; GRAB # OF WORDS TO RETURN
         BEQ     2$              ; IF NONE THEN SKIP RETURN CODE
         ADD     #MSDLTA+2,MP
         ADD     R1,MP           ; POINT MP ABOVE FUNCTION VALUE
         ADD     R1,MP           ; R1 IS WORDS
 1$:     MOV     -(MP),-(R0)     ; PUSH RETURN WORDS ONTO STACK
         SOB     R1,1$           ; AND LOOP FOR TOTAL WORD COUNT
         MOV     LASTMP,MP       ; RESTORE OLD MP VALUE
 2$:     MOV     MP,R1           ; NOW RESTORE STATE FROM MSCW
         TST     (R1)+           ; CHUCK STAT LINK
         MOV     (R1)+,MP        ; DYNAMIC LINK
         MOV     (R1)+,JTAB
         MOV     (R1)+,SEG
         MOV     (R1)+,IPC
         MOV     MP,LASTMP
         MOV     R0,SP           ; NOW BACK IN STATE AT CALL TIME
         MORE

 CSP:    ; CALL STANDARD PROCEDURE
         GETNEXT                 ; GET STANDARD PROC #
         ASL     R0              ; SET FOR WORD INDEXING
         MOV     CSPTBL(R0),PC   ; TRANSFER TO PROPER SUBROUTINE

 IOC:    ; IO CHECK
         TST     @#IORSLT
         BEQ     1$
         TRAP    UIOERR
 1$:     MORE

 NEW:    ; ALLOCATE DYNAMIC MEMORY
         CMP     @#GDIRP,#NIL    ; IS GLOB DIR NIL?
         BEQ     2$
         MOV     @#GDIRP,@#NP    ; RELEASE ITS SPACE
         MOV     #NIL,@#GDIRP    ; ZAP CURRENT DIRECTORY BUFFER
 2$:     MOV     (SP)+,R1        ; GET NUMBER OF WORDS INTO R1
         MOV     @#NP,R0         ; GET CURRENT HEAP TOP IN R0
         MOV     R0,@(SP)+       ; SET POINTER PARAM TO NEW MEM SPACE
         ADD     R1,R0           ; POINT R0 ABOVE DYN MEM AREA
         ADD     R1,R0           ; BYTE WISE
         MOV     SP,R1           ; NOW CHECK FOR STK OVERFLOW
         SUB     #40.,R1         ; GIVE A 20 WORD BUFFER ZONE
         CMP     R0,R1           ; CHECK IF OVERLAPPING
         BLOS    1$              ; IF NEW HEAP TOP LOWER THEN OK
         TRAP    STKOVR          ; ELSE BOMB FOR STACK OVERFLOW
 1$:     MOV     R0,@#NP         ; SAVE NEW HEAP TOP
         MORE

 FLC:    ; FILL CHAR INTRIN...KB GROSSNESS
         MOV     (SP)+,R1        ; CHAR TO FILL WITH
         MOV     @SP,BK          ; # CHARS TO FILL
         BLE     NOMOVE          ; LEAVE TWO THINGS ON STACK IN THIS CASE
         TST     (SP)+           ; NOW GET RID OF IT
         MOV     (SP)+,R0        ; ADDRESS TO FILL INTO
 1$:     MOVB    R1,(R0)+        ; FILL EACH CHAR W/ CHAR PARAM
         SOB     BK,1$
         BR      XITMOV

 MVL:    ; MOVE LEFT BYTES
         MOV     (SP)+,BK        ; GRAB # BYTES TO MOVE
         BLE     NOMOVE          ; QUIT IF LENGTH <= 0
         MOV     (SP)+,R1        ; GET DESTINATION ADDR
         MOV     (SP)+,R0        ; GRAB SOURCE ADDRESS
 1$:     MOVB    (R0)+,(R1)+     ; COPY BYTES
         SOB     BK,1$
         BR      XITMOV

 NOMOVE: ; GO HERE FOR A BAD MOVE REQUEST
         CMP     (SP)+,(SP)+     ; CHUCK ADDRESSES ON STACK
 XITMOV: MOV     #BACK,BK
         MORE

 MVR:    ; MOVE RIGHT BYTES
         MOV     (SP)+,BK        ; GRAB # BYTES TO MOVE RIGHT
         BLE     NOMOVE          ; QUIT IF <= 0
         MOV     (SP)+,R1        ; DESTATION ADDR
         MOV     (SP)+,R0        ; SOURCE ADDR
         ADD     BK,R0           ; POINT SOURCE AND DESTINATION
         ADD     BK,R1           ; AT END OF THE ARRAYS
 1$:     MOVB    -(R0),-(R1)     ; BYTE COPY BACKWARDS
         SOB     BK,1$
         BR      XITMOV

 XIT:    ; EXIT PROCEDURE
         MOV     JTAB,IPC        ; FIRST SET IPC TO EXIT FROM CURRENT
         ADD     #EXITIC,IPC     ; PROC ... GET INFO FROM CUR JTAB
         SUB     @IPC,IPC        ; NOW IPC IS SET TO EXIT MY CALLER
         CMPB    @JTAB,@SP       ; IS IT THE PROC # TO EXIT ANYWAY?
         BNE     XCHAIN          ; IF NOT THEN CHAIN DYN LINKS TO FIND
         CMPB    @SEG,2(SP)      ; IF PROC OK, HOW ABOUT SEG#?
         BNE     XCHAIN          ; IF WRONG, THEN CHAIN DYN TOO
         CMP     (SP)+,(SP)+     ; ELSE CHUCK STACK STUFF
         MORE                    ; AND DO THE RETURN CODE
 XCHAIN: MOV     MP,R0           ; OK...START EXITING STACKED PROCS
 XLOOP:  CMP     R0,@BASE        ; ARE WE ABOUT TO EXIT SYSTEM BLOCK?
         BEQ     XBOMB           ; IF SO THEN BIG BOOBOO
         MOV     MSJTAB(R0),R1   ; ELSE OK...GRAB JTAB AND FUDGE MS IPC
         ADD     #EXITIC,R1      ; TO EXIT CODE RATHER THAN NORMAL REENTRY
         SUB     @R1,R1          ; R1 NOW HAS EXIT POINT IPC
         MOV     R1,MSIPC(R0)    ; SO PLACE IN STACK FRAME
         CMPB    @MSJTAB(R0),@SP ; IS THIS THE PROC# TO EXIT FROM?
         BNE     1$              ; IF NOT THEN GO TO NEXT CALLED PROC
         CMPB    @MSSEG(R0),2(SP); AND RIGHT SEG#
         BNE     1$
         CMP     (SP)+,(SP)+     ; WELL, FOUND IT...CHUCK PARAMS
         MORE                    ; AND FALL OUT OF PROC
 1$:     MOV     MSDYN(R0),R0    ; CHAIN DOWN DYNAMIC LINKS!
         BR      XLOOP
 XBOMB:  TRAP    NOEXIT

         ;TREESEARCH (TREEROOTP, VAR FOUNDP, VAR TARGETNAME)
         ;-SEARCHS A BINARY TREE, EACH OF WHOSE NODES CONTAIN
         ; AT LEAST THE FOLLOWING COMPONENTS, IN ORDER SHOWN:
         ;       A)  CODEWD: ALPHA (8 CHAR NODE NAME)
         ;       B)  RLINK: CTP  (POINTER TO RIGHT SUBTREE)
         ;       C)  LLINK: CTP  (POINTER TO LEFT SUBTREE)

         ;-RETURNS POINTER TO TARGET NODE THROUGH CALL BY NAME PARA-
         ; METER AND DESCRIPTION OF SEARCH RESULTS AS INTEGER FUNCTION
         ; VALUE WITH 3 POSSIBLE VALUES:
         ;       A)  0:  TARGET NAME WAS FOUND; FOUNDP POINTS TO IT
         ;       B)  1:  NO MATCH; TARGET > LEAF NODE; FOUNDP => LEAF
         ;       C) -1:  NO MATCH; TARGET < LEAF NODE; FOUNDP => LEAF
         ;-ROOT POINTER ASSUMED TO BE NON NIL.

 TRS:    MOV     (SP)+,R0        ; GET ADDR OF TARGET NAME
         MOV     2(SP),R1        ;GET ROOT OF TREE
 TRLOOP: CMP     @R0,@R1         ;FIRST WORD COMPARE
         BNE     TRNEXT
         CMP     2(R0),2(R1)
         BNE     TRNEXT
         CMP     4(R0),4(R1)
         BNE     TRNEXT
         CMP     6(R0),6(R1)
         BNE     TRNEXT
         MOV     R1,@(SP)+       ;FOUND IT!  TELL USER WHERE
         CLR     @SP             ;RETURN ZERO VALUE
         MORE

 TRNEXT: BHI     TRRIGHT         ;WHICH SUBTREE NEXT?
         BIT     #177776,12(R1)  ;LEFT- IS IT NIL?
         BNE     NEXTL           ;NOPE, CARRY ON
         MOV     R1,@(SP)+       ;YES- RETURN POINTER
         MOV     #177777,(SP)    ;AND FUNCTION VALUE
         MORE
 NEXTL:  MOV     12(R1),R1       ;ON TO POSTERITY
         BR      TRLOOP

 TRRIGHT:BIT     #177776,10(R1)  ;RIGHT TREE NIL?
         BNE     NEXTR
         MOV     R1,@(SP)+       ;POINTER
         MOV     #1,(SP)         ;AND FUNCTION VALUE
         MORE

 NEXTR:  MOV     10(R1),R1       ;POSTERITY AGAIN...
         BR      TRLOOP

         ;IDSEARCH(SYMCURSUR[START OF SYM INFO BUFF],SYMBUF[SOURCE BUF])
         ;ORDER OF SYMBOL INFO BLOCK IS
         ;       A) SYMCURSUR    (POINTER IN SYMBOLIC BUFFER)
         ;       B) SY           (SYMBOL)
         ;       C) OP           (OPERATOR)
         ;       D) IDCODE       (8 CHAR ID NAME)
         ;IDSEARCH EXITS WITH SYMCURUSR UPDATED TO POINT TO THE END OF
         ;NEXT ID. SY AND OP DESCRIBE THE TOKEN FOUND, AND IDCODE CON-
         ;TAINS THE FIRST 8 CHARACTERS (BLANK FILLED) IF TOKEN WAS AN IDENT-
         ;TIFIER.

         ;ON ENTRY, SYMCURUSR POINTS TO FIRST CHARACTER OF  ID, WHICH
         ;IS ASSUMED TO BE ALPHABETIC.  ALSO ON ENTRY, TOS-1 IS ADDRESS OF
         ;SYMCURSUR AND TOS IS ADDR OF SYMBUF

 IDS:    MOV     (SP)+,R0        ;GET ADDR OF BUFFER
         ADD     @(SP),R0        ;CALC INDEXED BUFFER ADDR
         MOVB    (R0)+,R1        ;FIRST CHAR OF ID
         ASL     R1              ; DOUBLE CHAR ORD FOR WORD INDEX
         MOV     RWLOOK-'A-'A(R1),R1     ; POINTS R1 AT START OF RW'S
         MOV     R0,-(SP)        ; REMEMBER SECOND LETTER ADDRESS
 RWLOOP: MOVB    (R1)+,BK        ;GET LENGTH OF REWORD
         BEQ     NORW            ;0 SIGNALS END OF LIST
 1$:     CMPB    (R0)+,(R1)+     ;COMPARE..STARING AT SECOND BYTE
         BNE     NEXTRW          ;EQUAL?
         SOB     BK,1$
         MOVB    @R0,BK          ; GRAB FOLLOWING CHAR IN SYMBUF
         CMPB    BK,#'0
         BLO     GOTRW
         CMPB    BK,#'Z
         BHI     GOTRW
         CMPB    BK,#'A
         BHIS    2$
         CMPB    BK,#'9
         BHI     GOTRW
 2$:     ADD     #2,R1           ;NO--POINT TO START OF NEXT RW
         MOV     @SP,R0          ;RESTORE SOURCE POINTER
         BR      RWLOOP          ;AND TRY NEXT GUY

 NEXTRW: ADD     BK,R1           ;BUMP TO NEXT RW
         INC     R1              ;EXACTLY
         MOV     @SP,R0          ;RESTORE SOURCE POINTER
         BR      RWLOOP

 GOTRW:  SUB     (SP)+,R0        ; R0 HAS LENGTH-1 OF RW NOW
         MOV     (SP)+,BK        ; BK HAS SYMCURSOR ADDR NOW
         ADD     R0,(BK)+        ; BUMP SYMCURSOR...BK -> SY
         MOVB    (R1)+,@BK       ; PUT SY VALUE IN COMP STACK
         MOVB    (R1)+,2(BK)     ; AND OP VALUE TOO
         MOV     #BACK,BK
         MORE

 NORW:   MOV     @SP,R0          ; ADDR OF SECOND LETTER IN SYMBUF AGAIN
 1$:     MOVB    (R0)+,R1        ; GRAB EACH LETTER UNTIL DELIM FOUND
         CMPB    R1,#'0
         BLO     2$
         CMPB    R1,#'Z
         BHI     2$
         CMPB    R1,#'A
         BHIS    1$
         CMPB    R1,#'9
         BLOS    1$
 2$:     SUB     #2,R0           ; POINT R0 AT LAST CHAR IN ID
         MOV     (SP)+,R1        ; GRAB SECOND LETTER ADDR
         MOV     (SP)+,BK        ; AND SYMCURSORS ADDR
         DEC     R1              ; POINT R1 @ FIRST CHAR IN SYMBUF ID
         SUB     R1,R0           ; R0 IS # CHARS IN ID-1
         ADD     R0,(BK)+        ; BUMP SYMCURSOR TO LAST CH IN ID
         CLR     (BK)+           ; SY := IDENT (A ZERO)
         MOV     #15.,(BK)+      ; OP := NOOP
         INC     R0              ; NOW R0 IS TOTAL # CHARS IN ID
         CMP     R0,#8.          ; IS ID TOO LONG?
         BLT     3$
         MOV     #8.,R0          ; IF SO THEN COPY MAX 8 CHARS
         BR      4$
 3$:     MOV     #"  ,@BK        ; ELSE BLANK ENTIRE ID FIELD
         MOV     (BK)+,@BK
         MOV     (BK)+,@BK
         MOV     (BK)+,@BK
         SUB     #6.,BK          ; RESET BK TO ITS START AND
 4$:     MOVB    (R1)+,(BK)+     ; COPY R0 COUNT OF CHARS INTO ID
         SOB     R0,4$
         MOV     #BACK,BK
         MORE

         ;MACROS FOR RESERVED WORD TABLE
 .MACRO  RW      NAME,SY,OP
         .NCHR   NUMCH,NAME
         .BYTE   NUMCH
         .ASCII  /NAME/
         .BYTE   SY
         .IF     NB,OP
         .BYTE   OP
         .IFF	
         .BYTE   15.             ;NOOP CHARACTER
         .ENDC
 .ENDM   RW

 .MACRO  RWENT   CHAR
         .BYTE   0               ;TERMINATE PREVIOUS LIST OF IDS
 IDS.'CHAR = .
 .ENDM   RWENT

         RWENT   A
         RW      ND,39.,2.
         RW      RRAY,44.
         RWENT   B
         RW      EGIN,19.
         RWENT   C
         RW      ASE,21.
         RW      ONST,28.
         RWENT   D
         RW      IV,39.,3.
         RW      O,6.
         RW      OWNTO,8.
         RWENT   E
         RW      LSE,13.
         RW      ND,9.
         RWENT   F
         RW      OR,24.
         RW      ILE,46.
         RW      ORWARD,34.
         RW      UNCTION,32.
         RWENT   G
         RW      OTO,26.
         RWENT   I
         RW      F,20.
         RW      N,41.,14.
         RWENT   L
         RW      ABEL,27.
         RWENT   M
         RW      OD,39.,4.
         RWENT   N
         RW      OT,38.
         RWENT   O
         RW      F,11.
         RW      R,40.,7.
         RWENT   P
         RW      ACKED,43.
         RW      ROCEDURE,31.
         RW      ROGRAM,33.
         RWENT   R
         RW      ECORD,45.
         RW      EPEAT,22.
         RWENT   S
         RW      ET,42.
         RW      EGMENT,33.
         RWENT   T
         RW      HEN,12.
         RW      O,7.
         RW      YPE,29.
         RWENT   U
         RW      NTIL,10.
         RWENT   V
         RW      AR,30.
         RWENT   W
         RW      HILE,23.
         RW      ITH,25.
         RWENT   Z
         .BYTE   0               ;FOR UNUSED LETTERS
         .EVEN

 RWLOOK: .IRPC   X,ABCDEFGHIJKLMNOPQRSTUVWXYZ
         .IF     DF,IDS.'X
         .WORD   IDS.'X
         .IFF
         .WORD   IDS.Z
         .ENDC
         .ENDR

 TIM:    ; RETURN TIME OF DAY WORDS
         MOV     LOTIME,@(SP)+
         MOV     HITIME,@(SP)+
         MORE

 SCN:    ; SCAN ARRAY
         TST     (SP)+           ; EXTRA MASK PARAM...NOT USED YET
         MOV     @SP,R0          ; GRAB ADDR TO START SCAN
         MOV     2(SP),BK        ; CHAR TO SCAN FOR
         MOV     6(SP),R1        ; LENGTH TO SCAN FOR
         BEQ     NOTFND          ; IF NULL SCAN THEN RETURN 0
         BMI     BCKSCN          ; IF NEGATIVE THEN BACKWARD SCAN
         TST     4(SP)           ; ELSE FORWARD SCAN...CHECK RELOP
         BNE     2$              ; NEQ 0 MEANS NEQ SCAN
 1$:     CMPB    (R0)+,BK        ; ELSE EQUAL COMPARE BYTES
         BEQ     3$              ; UNTIL ONE IS EQUAL
         SOB     R1,1$
         BR      NOTFND
 2$:     CMPB    (R0)+,BK        ; DO NEQ COMPARE
         BNE     3$
         SOB     R1,2$
         BR      NOTFND
 3$:     DEC     R0              ; POINT R0 AT CHAR FOR FIX.R0
 FIX.R0: SUB     (SP)+,R0        ; MAKE R0 THE DISPLACEMENT FROM SCAN START
         CMP     (SP)+,(SP)+     ; CHUCK CHAR & RELOP PARAMS
         MOV     R0,@SP          ; RETURN DISP ON TOS
         MOV     #BACK,BK
         MORE
 BCKSCN: NEG     R1              ; MAKE A NUMBER SUITABLE FOR SOB OP
         INC     R0              ; PRE-DEC SETTUP
         TST     4(SP)           ; CHECK OP TYPE
         BNE     2$
 1$:     CMPB    -(R0),BK        ; SCAN BACKWARD EQUAL COMPARE
         BEQ     FIX.R0          ; WHEN FOUND THEN RETURN DISP
         SOB     R1,1$
         BR      NOTFND
 2$:     CMPB    -(R0),BK
         BNE     FIX.R0
         SOB     R1,2$
 NOTFND: MOV     6(SP),R0        ; RETURN SCAN LENGTH IN THIS CASE
         ADD     @SP,R0          ; THAT SIGNIFIES UNSUCCESSFUL SCAN
         BR      FIX.R0

 TRC:    ; REAL TRUNCATE
         JSR     R4,ENTFP
         .WORD   $RI,XITFP

 RND:    ; REAL ROUND
         MOV     @SP,R0          ; GET SIGN WORD OF PARAM TO ADD + OR - .5
         CLR     -(SP)           ; LOW ORDER REAL 0.5
         MOV     #100000,-(SP)   ; HIGH ORDER SHIFTED ONE LEFT
         ROL     R0              ; SHIFT SIGN OF PARAM INT.O C-BIT
         ROR     @SP             ; AND PLACE IN SIGN OF THE 0.5
         .IF     DF,FPI
         FADD    SP
         .ENDC
         JSR     R4,ENTFP
         .IF     NDF,FPI
         .WORD   $ADR
         .ENDC
         .WORD   $RI,XITFP

 SINCSP: ; REAL SINE
         JSR     R4,ENTFP
         .WORD   CALJR5,SIN

 COSCSP: ; REAL COSINE
         JSR     R4,ENTFP
         .WORD   CALJR5,COS

 LOGCSP: ; BASE-10 LOGARITHM
         JSR     R4,ENTFP
         .WORD   CALJR5,ALOG10

 ATNCSP: ; REAL ARCTANGENT
         JSR     R4,ENTFP
         .WORD   CALJR5,ATAN

 LNCSP:  ; NATURAL LOGARITHM
         JSR     R4,ENTFP
         .WORD   CALJR5,ALOG

 EXPCSP: ; EXPONENTIAL FUNCTION
         JSR     R4,ENTFP
         .WORD   CALJR5,EXP

 SQTCSP: ; REAL SQUARE ROOT
         JSR     R4,ENTFP
         .WORD   CALJR5,SQRT

 CALJR5: ; THIS SUBROUTINE MAGICALLY CALLS FPMP STUFF
         MOV     SP,1$           ; PUT REAL PARAM ADDR INTO CODE
         JSR     R5,@(R4)+       ; ENTER THE ROUTINE DESIRED
         BR      2$              ; PLEASE SEE CALL SEQUENCE IN FPMP DOC
 1$:     .WORD   ; ADDR OF PARAM GOES HERE
 2$:     MOV     R1,2(SP)        ; PUT LOW ORDER RESULT IN STACK
         MOV     R0,@SP          ; AND THEN HIGH ORDER
         JMP     XITFP           ; FINALLY EXIT

 MRK:    ; MARK HEAP
         CMP     @#GDIRP,#NIL    ; IS THE GLOB DIR NIL?
         BEQ     1$
         MOV     @#GDIRP,@#NP
         MOV     #NIL,@#GDIRP
 1$:     MOV     @#NP,@(SP)+     ; SAVE TOP OF HEAP IN POINTER PARAM
         MORE

 RLS:    ; RELEASE HEAP
         MOV     @(SP)+,@#NP     ; CUT BACK HEAP POINTER
         MOV     #NIL,@#GDIRP    ; ZAP GLOBAL DIR THING
         MORE

 IOR:    ; RETURN IO RESULT
         MOV     @#IORSLT,-(SP)
         MORE

 ;. BUILD A POWER OF TEN TABLE
 EXPON = 0
 .MACRO  PWR10   EXP
         .FLT2   1.0E'EXP
 .ENDM
 TENTBL:         .REPT   38.
         PWR10   EXPON
         EXPON = EXPON+1
         .ENDR

 POT:    ; POWER OF TEN
         MOV     (SP)+,R0        ; GET POWER DESIRED
         BMI     BADPOT          ; NO NEGATIVE POWER ALLOWED
         CMP     R0,#EXPON       ; SEE IF INDEX IS TOO BIG
         BGE     BADPOT          ; CROAK FOR THAT TOO
         ASL     R0              ; ELSE MAKE A REAL ARRAY INDEX
         ASL     R0              ; MULTIPLY BY 4
         MOV     TENTBL+2(R0),-(SP)      ; LOW ORDER WORD
         MOV     TENTBL(R0),-(SP)        ; AND HIGH ORDER WORD
         MORE
 BADPOT: TRAP    INVNDX

 HLT:    ; HALT AND/OR BREAKPOINT...EXECERROR KNOWS
         MOV     (PC)+,@BK       ; STASH TRAP HLTBPT INTO OP FETCH
         TRAP    HLTBPT
         MORE

 UBUSY:  JSR     R4,ENTFP
         .WORD   BSYSTRT,IOSTRT,BSYTST,CHKERR,IODONE

 UWAIT:  JSR     R4,ENTFP
         .WORD   WATSTRT,IOSTRT,BSYWAIT,CHKERR,IODONE

 UCLEAR: JSR     R4,ENTFP
         .WORD   WATSTRT,IOSTRT,CLRUNT,IODONE

 UREAD:  JSR     R4,ENTFP
         .WORD   IOSTRT,INMODE,BSYWAIT,CHKERR,STRTIN
         .WORD   CHKWAIT,BSYWAIT,CHKERR,IODONE

 UWRITE: JSR     R4,ENTFP
         .WORD   IOSTRT,OUTMODE,BSYWAIT,CHKERR,STRTOUT
         .WORD   CHKWAIT,BSYWAIT,CHKERR,IODONE

         ; BELOW ARE THE THREAD MODULES FOR THE ABOVE
         ; OPERATIONS..  IT IS SUGGESTED THAT YOU LOOK
         ; HERE BEFORE TRYING TO FIGURE OUT THE INTERRUPT
         ; HANDLER INTERFACE TO THIS SECTION.

 BSYSTRT:MOV     (SP),-(SP)      ; DUPL UNIT# PARAM
         CLR     2(SP)           ; SHOVE A FALSE INTO STACK FOR RETURN
 WATSTRT:SUB     #8.,SP          ; MAKE STACK LOOK OK FOR IODONE
         JMP     @(R4)+          ; AND ONWARD WE GO

 BSYTST: TST     (R1)            ; SEE IF UNIT IS IN FACT BUSY
         BPL     THRUR4          ; IF NOT, CONTINUE SEQUENCE
         INC     <UUNIT+2>(SP)   ; SET RETURN VALUE TO 1 (TRUE)
         BR      IODONE          ; AND QUIT NOW

 CLRUNT: JSR     PC,@4(R1)
         CLRB    @R1
         JMP     @(R4)+

 IOSTRT: CLR     R5              ; ERROR REGISTER, NO ERROR YET
         MOV     UUNIT(SP),R1    ; GRAB RAW UNIT #
         BLE     1$              ; IF <= ZERO, GIVE BADUNIT ERROR
         CMP     R1,#MAXUNT      ; SEE IF NUMBER IS TOO BIG
         BGT     1$              ; UNITBL INDEXED 1..MAXUNT
         ASL     R1              ; ITS OK, MULTIPLY BY 6
         ADD     UUNIT(SP),R1
         ASL     R1              ; TO GET AN ACTUAL ADDR IN
         ADD     #UNITBL,R1      ; UNITBL, R1 NOW IS ABS ADDR OF UNIT
         BIT     #INBIT!OUTBIT,@R1
         BEQ     1$              ; IF NOT IO ALLOWED AT ALL THEN ERROR
         JMP     @(R4)+          ; SO CONTINUE WITH SEQUENCE
 1$:     MOV     #UNTERR,R5      ; ERROR RESULT FOR JUNK UNIT #
                                 ; AND FALL INTO IO DONE
 IODONE: MOV     R5,@#IORSLT     ; GIVE ANY ERROR RESULTS TO SYSTEM
         ADD     #10.,SP         ; GET RID OF PARAMS ON STACK
         JMP     XITFP           ; AND RETURN TO PROGRAM

 INMODE: BIT     #INBIT,(R1)     ; SEE IF INPUT ALLOWED ON THE UNIT
 MODTST: BNE     THRUR4          ; IF ONE BIT, THEN GO AHEAD
         MOV     #MODERR,R5      ; ELSE GIVE BAD MODE ERROR
         BR      IODONE

 OUTMODE:BIT     #OUTBIT,(R1)    ; SEE IF OUTPUT ALLOWED ON UNIT
         BR      MODTST          ; AND SKIP TO ACTUAL TEST CODE

 BSYHANG:MTPS    #0              ; ENSURE LOW PRIORITY BEFORE WAIT
         WAIT                    ; WAIT UNTIL AN INTERRUPT OCCURS
 BSYWAIT:MTPS    #340            ; NO INTERRUPTS IN HERE...TIMING PROBS
         TST     (R1)            ; HIGH ORDER BIT TELLS IF BUSY
         BMI     BSYHANG         ; SO WAIT AROUND UNTIL THE BIT IS OFF
         MTPS    #0              ; OK...ALLOW INTERRUPTS
 THRUR4: JMP     @(R4)+          ; CONVENIENT LOCATION FOR CONDITIONAL JMP

 CHKERR: TSTB    (R1)            ; LOW BYTE IS HARD IO RSLT
         BEQ     THRUR4          ; IF NO ERROR, THEN KEEP GOING
         MOVB    (R1),R5         ; ELSE GIVE TO IORSLT AND QUIT NOT
         CLRB    (R1)            ; BE SURE TO CLEAR UNIT OR SYSTEM BOMB
         BR      IODONE

 CHKWAIT:BIT     #1,UNOWAIT(SP)  ; SEE IF USER WANTS TO WAIT FOR IO
         BNE     IODONE          ; IF PARAM IS TRUE, THEN GO BACK TO CALLER
         JMP     @(R4)+          ; ELSE D.O BUSYWAIT ETC

 STRTIN: JSR     R3,@2(R1)       ; JUMP INTO INTERRUPT HANDLER TO START IO
         .WORD   1               ; ONE HERE SAYS READ OP
         JMP     @(R4)+

 STRTOUT:JSR     R3,@2(R1)       ; JUMP TO INTERRUPT HANDLER
         .WORD   0               ; ZERO MEANS WRITE OP
         JMP     @(R4)+          ; AND CONTINUE

 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

 SYIORQ: ; THIS CODE IS FOR SYSTEM IO REQUESTS VIA UREAD AND
         ; UWRITE MACROS...NO PARAM CHECKING IS DONE
         ; AND ALL IO'S MUST BE SYNCHRONOUS (I DIDNT WANT TO BOTHER)
         MOV     (SP)+,SYIOR1    ; SAVE OLD R1 VALUE
         MOV     R3,SYIOR3       ; AND R3 (ALL OTHERS SAVED BY CONVENTION)
         MOV     (R1)+,IOTYPE    ; SAVE THE READ OR WRITE WORD FOR HANDLERS
         MOV     R1,XTSYIO       ; SAVE RETURN ADDRESS
         MOV     UUNIT(SP),R1    ; GET UNIT #
         ASL     R1              ; MULTIPLY BY 6
         ADD     UUNIT(SP),R1
         ASL     R1              ; FOR UNIT(*) INDEX
         ADD     #UNITBL,R1      ; R1 SHOULD BE ABS ADDR OF UNIT ENTRY
         JSR     R3,@2(R1)       ; ENTER HANDLER FOR PARTICULAR UNIT
 IOTYPE: .WORD   0               ; 0 OR 1 STORED HERE
 1$:     TST     (R1)            ; NOW WAIT UNTIL UNIT IS NOT BUSY
         BMI     1$              ; BUSY WAIT UNTIL IO IS COMPLETE
         TSTB    @R1             ; CHECK IO RESULT FOR UNIT
         BEQ     2$
         TRAP    SYIOER          ; BOMB SYSTEM IO ERROR
 2$:     MOV     (PC)+,R1        ; RESTORE REGISTERS...FI.RST R1
 SYIOR1: .WORD
         MOV     (PC)+,R3        ; RESTORE R3
 SYIOR3: .WORD
         ADD     #12,SP          ; CHUCK PARAMETERS
         MOV     (PC),PC         ; AND RETURN IN A KLUDGY MANNER
 XTSYIO: .WORD   0               ; RETURN ADDR STORED HERE

 ; HERE WE STICK A FEW MISCELLANEOS THINGS

 DIV:    .IF     DF,EIS
         MOV     R1,DENOM        ; STASH DENOM INTO OP FIELD
         ASHC    #-16.,R0        ; SHIFT R0 INTO R1 WITH SIGN EXT
         DIV     (PC)+,R0        ; PERFORM DIVID OP
 DENOM:  .WORD   0               ; DENOMINTOR GOES HERE
         BCC     1$              ; C-BIT IS ON FOR DIV BY ZERO
         TRAP    DIVZER
 1$:     RTS     PC
         .IFF
         CLR     -(SP)           ;CLEAR SIGN FLAG
         TST     R1              ;EXAMINE DENOMINATOR
         BGT     1$              ;PLUS
         BNE     3$              ;GIVE EXECERR IF DIV 0
         TRAP    DIVZER
 3$:     INC     (SP)            ;REMEMBER IF NEGATIVE
         NEG     R1              ;AND MAKE IT POS
 1$:     TST     R0              ;TEST NUMERATOR
         BGT     2$              ;PLUS?
         BNE     4$              ;NOT ZERO, THEN HAVE TO DO WORK
         CLR     BK              ;MAKE REMAINDER ZERO
         TST     (SP)+           ;THROW AWAY SIGN INFORMATION
         BR      DONED           ;AND THEN JUMP TO END
 4$:     INC     (SP)            ;ELSE NEGATIVE
         NEG     R0
 2$:     MOV     #8.,-(SP)       ;8 ITERATIONS
         CLR     BK              ;HIGH ORDER DIVIDEND
         SWAB    R0              ;ANY HIGH ORDER NUMERATOR?
         BEQ     DIVD            ;NO, THEN PROCEED TO DIVIDE
         ASL     @SP             ;ELSE NEED 16 ITERATIONS
         SWAB    R0              ;AND RESTORE NUMERATOR
 DIVD:   ASL     R0              ;DOUBLE DIVIDEND
         ROL     BK
         BEQ     LOP             ;JUMP IF NO CHANCE THIS TIME
         INC     R0              ;QUOTIENT BIT
         SUB     R1,BK           ;TRIAL STEP
         BHIS    LOP             ;OK
         ADD     R1,BK           ;DIVIDEND NOT BIG ENOUGH
         DEC     R0              ;RETRACT QUOTIENT BIT
 LOP:    DEC     @SP             ;COUNT THIS LOOP
         BGT     DIVD            ;CONTINUE TIL DONE
         NEG     R0              ;NEGMAX CHECK
         TST     (SP)+
         ASR     (SP)+           ;GET SIGN OF QUOTIENT
         BCS     DONED           ;JUMP IF NEG
         NEG     R0              ;ANSWER POSITIVE
         BVS     OVR             ;GIVE OVERFLOW ERROR
 DONED:  MOV     BK,R1           ;REMAINDER IN R1
         MOV     #BACK,BK
         RTS     PC
         .ENDC

         .IF     DF,EIS
 MLI:    MUL     R0,R1
         MOV     R1,R0           ; EXPECTS RESULTS IN R0
         RTS     PC
         .IFF
 OVR:    TRAP    INTOVR

 MLI:    CLR     -(SP)           ; SIGN STORAGE
         TST     R1              ;CHECK MULTIPLICAND
         BGT     1$              ;SKIP FOLLOWING IF +
         BEQ     ZEROM           ;ANSWER IS ZERO
         INC     @SP             ;REMEMBER -
         NEG     R1
 1$:     TST     R0              ;TEST MULTIPLIER
         BGT     2$	
         BEQ     ZEROM
         INC     @SP
         NEG     R0
 2$:     MOV     #8.,-(SP)       ; SET UP ITERATION COUNT
         CMP     R1,R0           ;MAKE SURE
         BGE     CLR             ;MULTIPLIER
         MOV     R1,BK           ;IS
         MOV     R0,R1           ;SMALLER
         MOV     BK,R0
 CLR:    CLR     BK              ;CLEAR HIGH ORDER PRODUCT
 MUL:    ROR     BK              ;SHIFT PRODUCT
         ROR     R0
         BCC     CYC             ;MULTIPLIER BIT = 0?
         ADD     R1,BK           ;NO,ADD IN MULTIPLICAND
 CYC:    DEC     @SP             ;COUNT LOOP
         BGT     MUL
         TST     (SP)+
         TSTB    R0              ;TEST HIGH MULTI
         BNE     OVR             ;ERROR .IF MULTIPLIER NOT GONE
         BISB    BK,R0           ;MOVE PRODECT RIGHT
         SWAB    R0
         CLRB    BK
         SWAB    BK
         ASR     BK              ;ONE MROE SHIFT
         BNE     OVR             ;PRODUCT EXCEEDED 15 BITS
         ROR     R0
         NEG     R0              ;MAKE NEG
         BPL     OVR             ;TOO BIG
         ROR     (SP)+           ;DETERMINE SIGN OF PRODUCT
         BCS     OUTM
         NEG     R0              ;SHOULD BE +
         BVS     OVR
 OUTM:   MOV     #BACK,BK
         RTS     PC

 ZEROM:  CLR     R0
         TST     (SP)+
         BR      OUTM            ;AND CLEAN UP
         .ENDC

 CSPTBL: .WORD   IOC
         .WORD   NEW
         .WORD   MVL
         .WORD   MVR
         .WORD   XIT
         .WORD   UREAD
         .WORD   UWRITE
         .WORD   IDS
         .WORD   TRS
         .WORD   TIM
         .WORD   FLC
         .WORD   SCN
         .IF     DF,TERAK
         .WORD   DRAWLINE
         .WORD   DRAWBLOCK
         .IFF
         .WORD   0,0
         .ENDC
         .WORD   0,0,0,0,0,0,0,0,0
         .WORD   TRC
         .WORD   RND
         .WORD   SINCSP
         .WORD   COSCSP
         .WORD   LOGCSP
         .WORD   ATNCSP
         .WORD   LNCSP
         .WORD   EXPCSP
         .WORD   SQTCSP
         .WORD   MRK
         .WORD   RLS
         .WORD   IOR
         .WORD   UBUSY
         .WORD   POT
         .WORD   UWAIT
         .WORD   UCLEAR
         .WORD   HLT
         .CSECT  TABLES
         .BLKW   30.
         .WORD   CSP
         .BLKW   14.
         .WORD   RNP
         .WORD   CIP
         .BLKW   18.
         .WORD   RBP
         .WORD   CBP
         .BLKW   10.
         .WORD   CXP
         .WORD   CLP
         .WORD   CGP
         .BLKW   48.

         .END


========================================================================================
DOCUMENT :usus Folder:VOL19:pvm.mac.text
========================================================================================

.TITLE  VM  p-System KT11 Disk Driver
;
; Submitted to the USUS Library by Eliakim Willner
;                                  USUS DEC SIG Chairman
;
.ENABL  LC

; p-System KT11 Disk Driver
; For Version II.0 Interpreters
;




.SBTTL  General comments

; "Faster than a speeding bullet..."
;                       -Clark Kent

;+
; VM.MAC is a handler to access extended memory on PDP 11's with the
; KT11 memory management unit as a disk device.
; 
; This handler was originally written by DEC personnel and contributed
; by DEC to DECUS. It was adapted to the p-System by Eliakim Willner.
;
; Author:
;       RB      01-May-75
;       With random assistance from A(C and HJ
;
; Edits:
;       CG      15-Aug-79       V04 format and bootstrap
;       EGW     31-Dec-82       p-System Version II.0 adaptation
;-

        .ASECT             
.=250
        VMINT
        340

        .CSECT  TABLES
        .BLKW   128.   
        .REPT   11.
        .BLKW   3
        .ENDR
        .WORD   INBIT!OUTBIT,VMSTRT,VMABRT
        
        
        .CSECT VMDRVR

VMUNIT: .WORD   0
VMOFST  = 14

DUMCSW: .WORD
        .WORD   DUMCSW
DUMIOQ: .WORD
        .WORD
        .WORD
        .WORD
        .WORD   1
        
VMSTRT:
        TST     VMUNIT
        BNE     VMSTRT
        MOV     R1,VMUNIT
        BIS     #BSYBIT,@R1
        TST     (R3)+
        MOV     R3,@SP
        MOV     R0,-(SP)
        MOV     R1,-(SP)
        MOV     R2,-(SP)
        MOV     R4,-(SP)
        MOV     R5,-(SP)
        CLR     DUMCSW
        MOV     #DUMIOQ,R5
        MOV     <UBLOCK+VMOFST>(SP),(R5)+
        MOV     @R1,(R5)+
        MOV     <UBUFFR+VMOFST>(SP),(R5)+
        MOV     <URLENG+VMOFST>(SP),R0
        ROR     R0
        TST     -(R3)
        BNE     1$
        NEG     R0
1$:     MOV     R0,(R5)+
        JSR     PC,QENTRY
        MOV     (SP)+,R5
        MOV     (SP)+,R4
        MOV     (SP)+,R2
        MOV     (SP)+,R1
        MOV     (SP)+,R0
        MOVB    DUMCSW,@R1
        JMP     @(SP)+

$INTEN:
        MOV     R4,-(SP)
        JSR     PC,@R5
        MOV     (SP)+,R4
        MOV     (SP)+,R5
        JMP     @#INTRTN

VMQUIT:
        MOVB    DUMCSW,@VMUNIT
        BIC     #BSYBIT,@VMUNIT
        CLR     VMUNIT
        RTS     PC
        
VMABRT: TST     VMUNIT
        BNE     VMABRT
        RTS     PC
        


.SBTTL  Macros and Definitions

; Memory management registers

MMSR0   = 177572                ;STATUS REG 0
MMSR1   = 177574                ;STATUS REG 1
MMSR2   = 177576                ;STATUS REG 2
MMSR3   = 172516                ;STATUS REG 3
UISDR0  = 177600                ;USER I DESC REG 0
UISDR7  = 177616                ;USER I DESC REG 7
UISAR0  = 177640                ;USER I ADDR REG 0
UISAR7  = 177656                ;USER I ADDR REG 7
KISDR0  = 172300                ;KERNEL I DESC REG 0
KISDR7  = 172316                ;KERNEL I DESC REG 7
KISAR0  = 172340                ;KERNEL I ADDR REG 0
KISAR7  = 172356                ;KERNEL I ADDR REG 7

; Miscellaneous definitions

V.TRP4  = 4                     ;Trap to 4 vector
PS      = 177776                ;PROCESSOR STATUS WORD
UMODE   = 140000                ;CURRENT MODE = USER (IN PS)
ADRS22  = 000020                ;22-BIT ADDRESSING MODE FOR 11/70
PUMODE  = 030000                ;PREVIOUS MODE = USER MODE (IN PS)


.SBTTL  Driver entry

.ENABL  LSB
VMCQE:  .WORD   DUMIOQ
QENTRY:
        MOV     VMCQE,R3        ;R3 -> QUEUE ELEMENT
        MOV     (R3)+,R2        ;R2 = BLOCK NUMBER
        ASL     R2
        ASL     R2
        ASL     R2              ;R2 = VM MEMORY BLOCK #
        ADD     #1600,R2        ;   + 28K WORDS
        CLR     R4              ;R4 = MEMORY BLK #
        MOV     #UISAR0,R1      ;R1 -> USER I ADDRESS REGS
        MOV     #8.,R0          ;8 REGS TO LOAD
1$:     MOV     #77406,UISDR0-UISAR0(R1) ;LOAD USER DESC REG
        MOV     #77406,KISDR0-UISAR0(R1) ;LOAD KERNEL DESC REG
        MOV     R4,KISAR0-UISAR0(R1) ;LOAD KERNEL I ADDR REG
        MOV     R4,(R1)+        ;AND USER I ADDR REG
        ADD     #200,R4         ;BUMP ADDR BY 4K
        SOB     R0,1$           ;AND LOOP TO SET UP ALL 8
        MOV     R2,-(R1)        ;MAP VM BLK OVER USER I/O PAGE
        MOV     #37406,@#UISDR7 ;WITH A LENGTH OF 2K WORDS
        MOV     #177600,@#KISAR7 ;MAP I/O PAGE TO KERNEL
        MOV     #160000,R5      ;R5 -> BASE OF I/O PAGE
VMHPAT: NOP                     ;NOMODE22 ;Filler
        NOP                     ;NOMODE22
        NOP                     ;NOMODE22
;       BIS     #ADRS22,@#MMSR3 ;MODE22   ;SET 22-BIT MODE FOR 11/70
        BIS     #UMODE,@#PS     ;GO INTO USER MODE
        BIS     #1,@#MMSR0      ;ENABLE MANAGEMENT
        TST     (R3)+           ;SKIP UNIT NUMBER IN Q ELEMENT
        MOV     (R3)+,R0        ;R0 = BUFFER ADDRESS
        MOV     @R3,R4          ;R4 = WORD COUNT
        BMI     VMWRT           ;IF NEGATIVE, WRITE REQUEST
        BEQ     VMTRAP          ;IF SEEK THEN DONE IMMEDIATELY
        INC     R4              ;FOLD WORD COUNT TO SPEED TRANSFER
        ASR     R4
        BCC     2$
VMREAD: MOV     (R5)+,(R0)+     ;COPY TO USER BUFFER
2$:     MOV     (R5)+,(R0)+
        SOB     R4,VMREAD       ;LOOP UNTIL TRANSFER COMPLETE
        BR      VMTRAP          ;THEN GO TO COMMON EXIT

VMWRT:  NEG     R4              ;MAKE WORD COUNT POSITIVE
        INC     R4              ;FOLD WORD COUNT TO SPEED TRANSFER
        ASR     R4
        BCC     4$
3$:     MOV     (R0)+,(R5)+     ;MOVE A WORD FROM USER BUFFER
4$:     MOV     (R0)+,(R5)+
        SOB     R4,3$           ;LOOP UNTIL TRANSFER COMPLETE
        MOVB    @R3,R4          ;CHECK IF ZERO-FILL REQ'D
        BEQ     VMTRAP          ;NOPE - MULTIPLE OF A BLOCK
5$:     CLR     (R5)+           ;ELSE CLEAR A WORD
        DECB    R4              ;UNTIL REACH A BLOCK BOUNDARY
        BNE     5$
VMTRAP: CLR     @#MMSR0         ;TRY TO TURN OFF MANAGEMENT
        MOV     PC,R4           ;POINT TO Q ELEMENT AGAIN
        ADD     #VMCQE-.,R4
;       MOV     @#54,R0         ;GET BASE OF RMON
;       JMP     @270(R0)        ;AND DISPATCH ELEMENT
        JMP     VMQUIT

; ABORT ENTRY

        BR      VMTRAP          ;ABORT BY DISABLING MANAGEMENT

; INTERRUPT SERVICE

VMINT:  MOV     #160000,R5      ;RESET TO POINT TO BASE OF I/O PAGE
        ADD     #100,@#UISAR7   ;AND REMAP TO NEXT 2K CHUNK
        MOV     @#MMSR2,R1      ;R1 = VIRTUAL PC OF ERROR
        CMP     @R1,(PC)+       ;CHECK FOR R0 MODIFICATION
        MOV    (R0)+,(R5)+      ;  ON THIS INSTRUCTION ONLY!
        BNE     6$              ;NOT THIS ONE, SO SKIP CORRECTION
        TST     -(R0)           ;ELSE UPDATE
6$:     BIC     R5,@#MMSR0      ;CLEAR SEGMENT LENGTH FAULT
        MOV     PC,R2           ;GET ADDR OF EXIT CODE
        ADD     #VMTRAP-.,R2    ;  IN R2
        CMP     R1,R2           ;TRYING TO EXIT?
        BNE     7$              ;NOPE
        BIC     R5,2(SP)        ;ELSE RETURN TO KERNEL MODE
7$:     MOV     R1,@SP          ;RESTART INSTRUCTION
        RTI                     ;AND EXIT
.DSABL  LSB

.END


========================================================================================
DOCUMENT :usus Folder:VOL19:rx11.text
========================================================================================





 ;************************************************;
 ;*                                              *;
 ;*    UCSD PASCAL INTERPRETER FOR PDP-11'S      *;
 ;*                                              *;
 ;*    WRITTEN BY ROGER T. SUMNER                *;
 ;*    AND MARK OVERGAARD, 1977                  *;
 ;*                                              *;
 ;*    INSTITUTE FOR INFORMATION SYSTEMS         *;
 ;*    UC SAN DIEGO, LA JOLLA, CA                *;
 ;*                                              *;
 ;*    KENNETH L. BOWLES, DIRECTOR               *;
 ;*                                              *;
 ;*    THIS SOFTWARE IS THE PROPERTY OF THE      *;
 ;*  REGENTS OF THE UNIVERSITY OF CALIFORNIA.    *;
 ;*                                              *;
 ;************************************************;

        .TITLE RX-11 FLOPPY DRIVER

         .ASECT
.=264
         RX$INT         ; RX FLOPPY INTERRUPT HANDLER
         240            ; MAX PRIORITY
        
         .CSECT  TABLES
         .BLKW 128.     ; OPERATOR TRANSFER TABLES
         .REPT 4
         .BLKW 3
         .ENDR
         .WORD INBIT!OUTBIT,RXSTRT,RXABRT
         .WORD INBIT!OUTBIT!10000,RXSTRT,RXABRT
         .PAGE
         .CSECT RXDRVR

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;                                                         ;
;                                                         ;
;             rx - 11 floppy handler                      ;
;                                                         ;
;                                                         ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

RXUNIT:  .WORD   0       ; ADDRESS OF UNIT TABLE ENTRY FOR I/O
RXBUFA:  .WORD   0       ; ADDRESS OF CURRENT BYTE BUCKET
RXSECT:  .WORD   0       ; CURRENT LOGICAL SECTOR ON DISK
RXTRYS:  .WORD   0       ; RETRY COUNT FOR CRC ERRORS
RXLENG:  .WORD   0       ; NUMBER OF BYTE REMAINING TO BE MOVED

RXCS     =  177170       ; ADDRESS OF RX CONTROL AND STATUS REG
RXDB     =  RXCS+2       ; ADDRESS OF RX DATA REGISTER
RXGO     =       1       ; GO BIT IN RXCS
RXFILL   =  0*2          ; FILL BUFFER COMMAND
RXMPTY   =  1*2          ; EMPTY BUFFER COMMAND
RXRORW   =  2*2          ; COMMAND FOR READ OR WRITE, LOW BIT DETERMINES
RXERRF   =  7*2          ; COMMAND FOR READ ERROR REGISTER
RXINTS   =  100          ; INTERRUPTS OK BIT
RXOFST   =   14          ; NUMBER OF WORDS OUR STACK DIFFERS
                         ; FROM UNIT-IO STACK (CAUSE OF SAVED REGISTERS)
RXSTRT: ;THIS IS THE ENTRY POINT OF THE ROUTINE TO START
        ; I/O'S TO FLOPPIES.  THE CALLING SEQUENCE IS
        ;       JSR     R3,RXSTRT
        ;       .WORD   (1 FOR READ, 0 FOR WRITE)
        ; WE ASSUME THAT R1 CONTAINS THE ADDRESS OF THE UNIT TABLE
        ; ELEMENT AND THE FLOPPY IS NOT INTERRUPT ENABLED.  GP REGISTERS
        ; ARE SAVED EXCEPT R3 WHICH WE ASSUME TO BE SCRATCH AT ENTRY.
        ; ALL EXITS ARE DONE VIA INTRTN INSTRUCTIONS.

        TST     RXUNIT          ; CAN'T DO TWO FLOPPY I/O'S AT ONCE
        BNE     RXSTRT          ; WAIT UNITL WE CAN TST IO UNIT AGAIN
        MOV     R1,RXUNIT       ; STASH UNIT TABLE ADDR, NOW BUSY
        BIS     #BSYBIT,(R1)    ; MARK UNIT AS BUSY
        CLR     (SP)            ; NEW PSW AT PR-0 WHEN WE RTI
        TST     (R3)+           ; POINT R3 AT RETURN ADDR
        MOV     R3,-(SP)        ; SET UP FOR AN RTI AFTER FIRST TRANSFER START
        MOV     -(R3),R3        ; GRAB I/O CODE.. 1 READ.. 0 WRITE IN R3
        MOV     R0,-(SP)        ; SAVE ALL REGISTERS FOR EXIT
        MOV     R2,-(SP)
        CLR     -(SP)           ; R3'S LOCATION.. CLEAR IT FOR NO REASON
        MOV     R5,-(SP)        ; ALL SET TO START UP
        MOV     #RXCS,R0        ; R0 HAS RXCS ADDRESS IN IT (CONVENTION)
        ASL     R3              ; REFORMAT INTO FLOPPY OPERATION
        BIS     #<RXGO+RXRORW>,R3
        BISB    1(R1),R3        ; SET UNIT BIT FROM TABLE
        BIC     #177740,R3      ; GET RID OF JUNK INFO
        MOV     R3,RXFUNC       ; THE ACTUAL IO CONTROL WORD TO RXCS
        MOV     <UBUFFR+RXOFST>(SP),RXBUFA      ; STASH BUFFER ADDRESS
        MOV     <UBLOCK+RXOFST>(SP),R3   ; GRAB USER BLOCK # FROM STACK
        ASL     R3              ; MULTIPLY IT BY 4 TO GET
        ASL     R3              ; A LOGICAL SECTOR NUMBER
        MOV     R3,RXSECT       ; AND SAVE IT FOR I/O LATER
        MOV     <URLENG+RXOFST>(SP),R5  ; GRAB NUMBER OF BYTES
        BEQ     RXQUIT          ; IF NO BYTES, FORGET IT
RXNEXT: ; THIS IS WHERE WE START THE I/O'S FROM
        MOV     #5,RXTRYS       ; RETRY CRC ERRS AT MOST 3 TIMES
        BIT     #2,RXFUNC       ; SEE IF DOING A WRITE SO FILL BUFF
        BNE     RXRTRY          ; SLIP OVER FILL IF READ.. START I/O
        MOV     #<RXGO+RXFILL>,(R0)     ; SEND FILL BUFF COMMAND TO FLOPPY
        JSR     R2,RXMOVE       ; TRANSFER IN 128 BYTES INTO RX BUFFER
        MOVB    (R3)+,(R2)      ; PARAM 1..INSTRUC IF BYTES>0
        CLRB    (R2)            ; PARAM 2..DO THIS IF BYTES <= 0
RXRTRY: MOV     RXSECT,R3       ; NOW PERFORM MAGIC ALGOTITHM FOR
        MOV     #8.,R2          ; LOOP COUNT
1$:     CMP     #6400,R3        ; DOES 26 GO INTO DIVIDEND
        BHI     2$              ; BRANCH IF NOT, C CLEAR
        ADD     #171400,R3      ; SUBTRACT 26 FROM DIVIDEND, SETS C
2$:     ROL     R3              ; SHIFT DIVIDEND AND QUOTIENT
        DEC     R2              ; DEC BRANCH COUNT
        BGT     1$              ; BRANCH TILL DIVIDE DONE
        MOVB    R3,R2           ; COPY TRACK NUMBER
        CLRB    R3              ; REMOVE TRACK NUMBER FROM REMAINDER
        SWAB    R3              ; GET REMAINDER
        CMP     #12.,R3         ; C=1 OF 13<=R3<=26, ELSE C=0
        ROL     R3              ; DOUBLE FOR 2 TO 1 INTERLEAVE
                                ; C-BIT COMES IN FOR SECTOR GROUP
        ASL     R2              ; ADD TRACK TO TRACK SKEW TO SECTOR
        ADD     R2,R3           ; SKEW BY 2* TRACK
        ADD     R2,R3           ; SKEW BY 4* TRACK
        ADD     R2,R3           ; SKEW BY 6* TRACK
        ASR     R2              ; REFIX TRACK NUMBER
        INC     R2              ; PUT TRACK # IN RANGE 1-76 TO HANDLE
                                ; ANSI FLOPPY, TRACK 0 IS LEFT ALONE
3$:     SUB     #26.,R3         ; MODULO SECTOR INTO RANGE -26, -1
        BGE     3$              ; LOOP TILL REMAINDER GOES NEGATIVE
        ADD     #27.,R3         ; PUT SECTOR IN RANGE 1,26
        MOV     (PC)+,(R0)      ; SEND ACTUAL IO OP TO RX-11
RXFUNC: .WORD   0               ; SET UP IN INITIALIZE
1$:     TSTB    (R0)            ; NOW WAIT UNTIL TR FLAG
        BEQ     1$              ; LOOP UNTIL FLOPPY ANSWERS
        BPL     RXERR           ; WHOOPS..DONE BUT NOT TR
        MOV     R3,@#RXDB       ; SEND SECTOR NUMBER
2$:     TSTB    (R0)            ; NOW WAIT UNTIL SECOND TR
        BEQ     2$              ; TO SEND TRACK #
        BPL     RXERR           ; ANOTHER SCREW UP
        MOV     R2,@#RXDB       ; NOW OPERATION BEGINS
        BIS     #RXINTS,(R0)    ; ALLOW INTERRUPT AT COMPLETION
RXEXIT: ; GO BACK TO USER NOW..RESTORE RETISTERS
        MOV     R5,RXLENG       ; SAVE NUMBER OF BYTES FOR RE-ENTRY
        MOV     (SP)+,R5
        MOV     (SP)+,R3
        MOV     (SP)+,R2
        MOV     (SP)+,R0
        JMP     INTRTN          ; RETURN NOW
RXQUIT: BIC     #BSYBIT,@RXUNIT ; MARK UNIT AS NOT BUSY
        CLR     RXUNIT          ; AND RX INTERFACE NOT BUSY EITHER
        BR      RXEXIT          ; AND WE ARE DONE WITH IT
        ; HERE IS THE RE-ENTRY POINT THAT IS PLACED IN THE TRAP
        ; VECTOR FOR THE RX-11
RX$INT: MOV     R0,-(SP)
        MOV     R2,-(SP)
        MOV     R3,-(SP)
        MOV     R5,-(SP)
        MOV     #RXCS,R0        ; SET UP STATE FOR CONTINUED OPERATION
        MOV     RXLENG,R5       ; NOW SET TO GO ON
        BIC     #RXINTS,(R0)    ; NO UNEXPECTED INTERRUPTS PLEASE
        BMI     RXERR           ; HIGH BIT ON..GO TO ERROR THING
        BIT     #2,RXFUNC       ; SEE IF A READ..IF SO THEN
        BEQ     RXISWT          ; WE WANT TO EMPTY BUFFER
        MOV     #<RXGO+RXMPTY>,(R0)    ; EMPTY COMMAND
        JSR     R2,RXMOVE       ; ENTER SUBROUTINE WHICH DOES MOVES
        MOVB    (R2),(R3)+      ; OP FOR NUMBYTES > 0
        TSTB    (R2)            ; OP FOR NUMBYTES <= 0
        TST     R5              ; IF READING AND NO MORE CHARS
        BEQ     RXQUIT          ; THEN QUIT READING NOW
RXISWT: MOV     RXSECT,R3       ; SET UP FOR NEXT LOGICAL SECTOR I/O
        INC     R3
        MOV     R3,RXSECT       ; FOR FUTURE REFERENCE
        BIT     #3,R3           ; SEE IF AT BLOCK BOUNDERY
        BNE     RXAHED          ; IF NOT AT BLOCK, I/O ANYWAY
        TST     R5              ; IF A BLOCK THOUGH, SEE FI ANY MORE
        BEQ     RXQUIT          ; BYTES..IF NOT, THEN TIME TO QUIT
RXAHED: JMP     RXNEXT          ; NEXT SECTOR PLEASE

RXERR:  ; WE END UP HERE IF NAY PROBLEMS CAME UP DURING
        ; ANY OPERATION.  WE MAY CHOOSE TO RETRY, BUT MORE LIKELY
        ; JUST QUIT AND RETURN THE ERROR
        MOV     #<RXGO+RXERRF>,(R0)     ; ASK FOR DETAILED ERROR INFO
1$:     TSTB    (R0)            ; HANG UNTIL DONE BIT
        BEQ     1$
        MOV     @#RXDB,R2       ; GET DETAIL ERROR INFO
        CMP     #040,R2         ; SEE OF BAD TRACK ADDRESS
        BEQ     4$
        CMP     #120,R2         ; SEE OF DISK SURFACE INACCESIBLE
        BEQ     4$
        CMP     #210,R2         ; SEE IF PARITY ERROR
        BEQ     4$              ; GIVE SAME ERROR AS CRC, NO RETRY
        DEC     RXTRYS
        BLE     4$
        JMP     RXRTRY          ; GIVE IT ANOTHER SHOT
4$:     MOV     #PARERR,R3
RXSPLT: MOVB    R3,@RXUNIT
        JMP     RXQUIT          ; FORGET IT, UNIT RAUNCHY

RXMOVE: ; THIS SUBROUTINE TRANSFERS 128 BYTES TO OR FROM THE
        ; RX-11 INTERFACE RXDB.  THE TWO WORD PARAMETERS
        ; ARE THE INSTRUCTION I PERFORM FOR THE DATA MOVE ITSELF.
        ; R2 AND R3 ARE SCRATCH (R2 IS LINKAGE REGISTER THOUGH)

        MOV     (R2)+,RXDOIT    ; INSTRUCTION FOR BYTES > 0
        MOV     (R2)+,RXDONT    ; INSTRUCTION FOR BYTES <=0
        MOV     R2,(SP)         ; RETURN ADDRESS..RTS PC
1$:     TSTB    (R0)            ; WAIT UNTIL TR IS UP
        BEQ     1$              ; LOOP UNTIL RX ANSWERS
        MOV     #RXDB,R2        ; OUR PARAMS EXPECT R2=#RXDB
        MOV     RXBUFA,R3       ; AND R3=CURRENT BYTE BUFFER
        TST     R5              ; IF ALREADY ZERO, DONT MOVE
        BEQ     RXDONT          ; ANYTHING AT ALL
RXDOIT: .WORD 0                 ; USER INSTRUCTION GOES HERE
1$:     TSTB    (R0)            ; WAIT UNTIL TR OR DONE
        BEQ     1$
        BPL     RXDNMV          ; IF NOT TR, THEN MUST BE DONE
        SOB     R5,RXDOIT       ; DEC AND BNE UNTIL ALL BYTES TRANSFERED
RXDONT: .WORD 0                 ; USERS EAT CHAR INSTRUCTION
1$:     TSTB    (R0)            ; WAIT UNTIL TR OR DONE
        BEQ     1$              ; LOOP HERE UNTIL SOME RESULT
        BMI     RXDONT          ; TR WAS STILL UP, EAT JUNK CHARS
        INC     R5              ; TO FOOSET DEC DONE NEXT
RXDNMV: DEC     R5              ; BE SURE TO COUNT THE LAST BYTE
        TST     (R0)            ; SEE OF WE HAD AN ERROR INSIDE
        BPL     1$              ; SKIP ERROR RETURN FO BIT 15 IS FOO
        MOV     #RXERR,(SP)     ; NOW RTS WILL DUMP RIGHT INTO ERROR
1$:     MOV     R3,RXBUFA       ; SAVE THE CURRENT BYTE BUCKET
        RTS     PC              ; GO BACK TO NEXT I/O OR ERROR EXIT

RXABRT: CLR     RXLENG
1$:     TST     RXUNIT
        BNE     1$
        RTS     PC

        .END


========================================================================================
DOCUMENT :usus Folder:VOL19:setup.code
========================================================================================

< binary file -- not listed >

========================================================================================
DOCUMENT :usus Folder:VOL19:system.interp
========================================================================================

< binary file -- not listed >

========================================================================================
DOCUMENT :usus Folder:VOL19:system.pascal
========================================================================================

< binary file -- not listed >

========================================================================================
DOCUMENT :usus Folder:VOL19:traps.text
========================================================================================

         .TITLE  INTERRUPT AND TRAP SUBSYSTEM
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;                                                                   ;
 ;                       TRAP VECTOR CONTENTS                        ;
 ;                                                                   ;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
         .ASECT          ; INTERRUPT HANDLER LOCATION IN VECTORS
 .=0
         TRAP    SYSERR  ; BAD BRANCH...MOST LIKELY BAD OBJECT CODE
         0
         T4$INT          ; 4-TRAP HANDLER
         0
         T10$INT         ; 10-TRAP HANDLER
         0
 .=24
         173000          ; POWER UP LOCATION
         0
 .=34
         TP$INT          ; TRAP HANDLER
         0               ; PR-0
         BACK            ; ENTRY POINT FOR BOOT LOADER
 .=60
         TR$INT          ; KEYBOARD INTERRUPT HANDLER
         200             ; PR-4
         TX$INT          ; CONSOLE PRINTER HANDLER
         200             ; PR-4
 .=100
         KW$INT          ; KW-11 (MAYBE REFRESH HARDWARE!) CLOCK HANDLER
         301             ; PR-6...CARRY SET FOR ADC OP
 .=244
         FP$INT          ; FLOATING POINT EXCEPTIONS
         0
         .PAGE
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;                                                                   ;
 ;                       SYSCOM CONTENTS                             ;
 ;                                                                   ;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

 .=400

 IORSLT: .WORD   0
 XEQERR: .WORD   0
 SYSUNT: .WORD   0
 BUGSTA: .WORD   0
 GDIRP:  .WORD   NIL
 BOMBP:  .WORD   NIL
 STKBAS: .WORD   NIL
 LASTMP: .WORD   NIL
 JTAB:   .WORD   NIL
 SEG:    .WORD   NIL
 MEMTOP: .WORD   157776
 BOMBIPC:.WORD   0
 HLTLIN: .WORD   NIL
 BRKPTS: .BLKW   4
         .BLKW   10.
 LOTIME: .WORD   0
 HITIME: .WORD   0
 NOBREAK=100     ;NO BREAK BIT IN MISCINFO
 MSCNFO: .WORD   ^B0000000
 CRTTYP: .WORD   3       ;TELETYPE
 CRTESC: .BYTE   0,CR,0,0,0,0,0
 FILCNT: .BYTE   10.
         .BLKB   4
 CRTNFO: .WORD   0.,72.
         .BYTE   0,0,0,0
 EOF:    .BYTE   3
 FLUSH:  .BYTE   6
 BREAK:  .BYTE   0
 STOP:   .BYTE   23
 CHRDEL: .BYTE   '_
 BADCHR: .BYTE   '?
 LINDEL: .BYTE   177
 ALTMOD: .BYTE   33
         .BLKB   6
 SEGTBL: .BLKW   3*<MAXSEG+1>
         .PAGE
         .CSECT  IOTRAP

 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;                                                                   ;
 ;               KW-11, 4 & 10 TRAP HANDLERS                         ;
 ;                                                                   ;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

 T4$INT:         TRAP    BADMEM

 T10$INT:TRAP    NOTIMP  ; CROAK SYSTEM FOR ILLEGAL OPCODE

 FP$INT:         TRAP    FPIERR  ; EXECUTION ERROR!

 KW$INT:         ADC     @#LOTIME ; IN 60-TH'S...CARRY IS SET IN TRAP VECTOR
         ADC     @#HITIME
         RTI

 INTRTN: ; ALL IO DRIVERS MUST USE JUMP HERE INSTEAD OF
         ; DOING THEIR OWN RTI...THE SYSTEM MAY HANG IN THE WAIT
         ; INSTRUCTION OF UNITIO IF THIS IS NOT DONE!!
         CMP     @(SP),(PC)+     ; IS THE NEXT INSTRUCTION A WAIT??
         WAIT
         BNE     1$              ; IF NOT THEN DO IT
         ADD     #2,@SP          ; ELSE SKIP THE WAIT OPCODE AND THEN
 1$:     RTI                     ; RETURN
         .PAGE
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;                                                                   ;
 ;               "TRAP"  INTERRUPT  HANDLER                          ;
 ;                                                                   ;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

 TP$INT: ; ENTRY POINT FOR "TRAP" INSTRUCTION INTERRUPTS.  THESE
         ; ARE USED FOR EXECUTION ERRORS AND SOME SYSTEM REQUESTS.
         MOV     R1,-(SP)        ; R1 IS USED FOR DETERMINING TRAP TYPE
         MOV     2(SP),R1        ; GRAB OLD PC OFF THE STACK
         MOV     -(R1),R1        ; NOW R1 HAS TRAP INSTRUCTION FROM CORE
         MOVB    R1,R1           ; ISOLATE LOW BYTE WITH SIGN EXTEND
         BLT     TPRQST          ; A MINUS PARAM IS A SYSTEM REQUEST
         BGT     XQ.ERR          ; GREATER THAN IS EXECUTION ERROR
         RESET                   ; ZERO IS FATAL SYSTEM ERROR...REBOOT!
         JMP     @24             ; USE POWER-UP VECTOR FOR BOOT ADDR
 XQ.ERR: ; HERE WE ARE FOR AN EXECUTION ERROR...RESTORE A VALID
         ; ENVIRONMENT FOR THE SYSTEM AND CXP 0,2...EXECERROR
         MOV     LASTMP,MP
         MOV     STKBAS,BASE
         MOV     #BACK,BK
         MOV     (PC)+,@BK       ; ENSURE OP FETCH IS OK...STOP BREAKING
         GETNEXT
         MOVB    R1,XEQERR       ; SET UP PARAMS IN SYSCOM TO ERR HANDLERS
         MOV     SP,BOMBP        ; SET UP BOMB MCSWP FOR DEBUGGER
         SUB     #MSDLTA+4,BOMBP
         MOV     IPC,BOMBIPC
         CLR     -(SP)
         MOV     BK,-(SP)
         MOV     #CXP0.2,IPC
         RTI
 CXP0.2: .BYTE   77.+128.,0,2,326

 TPRQST: ASL     R1              ; DOUBLE FOR WORD ADDRESSING
         SUB     R1,PC           ; CASE STMT, R1 NEGATIVE...REALLY ADDS R1
         TRAP    SYSERR          ; SHOULD NEVER DO THIS
         BR      TTYOUT          ; -1 IS TTYOUT REQUEST

 TTYOUT: TST     TXCHAR          ; SEE IF ANY CHAR WAITING ALREADY
         BPL     TTYOUT          ; >=0 -> BUSY...HANG UNTIL NEG
         MOV     R0,TXCHAR       ; PLACE THE CHAR IN HIGH PRIOR BUFFER
         MOV     (SP)+,R1        ; RESTORE REG
         TSTB    @TXCSR          ; SEE IF DL-11 IS READY FOR A CHAR
         BPL     1$              ; IF NOT THEN RETURN ELSE
         JMP     TX$INT          ; MAKE TX THINK AN IO IS COMPLETED
 1$:     RTI
         .PAGE
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;                                                                   ;
 ;               CRT INPUT-OUTPUT HANDLER                            ;
 ;                                                                   ;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


 TRCSR:  .WORD   177560
 TRBUF:  .WORD   177562
 TRBFSZ  =  64.                  ; BYTES IN TT INPUT BUFFER
 TRBUFR: .BLKB   TRBFSZ          ; RING BUFFER FOR TTY INPUT
 TRHEAD: .WORD   0               ; INDEX OF CURRENT QUEUE HEAD
 TRTAIL: .WORD   0               ; INDEX OF CURRENT QUEUE TAIL
 TRQUED: .WORD   0               ; CHARS IN QUEUE WAITING TO BE READ
 TRUNIT: .WORD   0               ; UNIT # OF CURRENT IO (ZERO MEANS NONE)
 TRBUFA: .WORD   0               ; ADDRESS OF USERS BUFFER (BYTE ADDR)
 TRLENG: .WORD   0               ; NUMBER OF BYTES USER WANTS READ IN
 TROFST  =  6                    ; OFFSET FROM MY STACK TO PARAMS
 BUZZ    = 07
 SFLAG:  .WORD   0               ; NON-ZERO IF OUTPUT TO BE STOPPED
 OFLAG:  .WORD   0               ; NON-ZERO IF OUTPUT TO BE FLUSHED
 ALOCK:  .WORD   0               ; ZERO -> ALPHA LOCK ON

 TR$INT:         ; ENTRY POINT FOR KEYBOARD INTERRUPTS
         MOV     R0,-(SP)        ; SAVE R0, R0 IS USED FOR CHAR
         MOVB    @TRBUF,R0       ; GRAB CHAR FROM DL-11
         BIC     #177600,R0      ; CHUCK PARITY AND ANY JUNK BITS
         CMPB    R0,BREAK        ; IS IT THE STANDARD BREAK CHAR
         BNE     1$
         BIT     #NOBREAK,MSCNFO         ; BREAK DISABLED??
         BNE     TREXIT          ; IF SO THEN NO BLOWUP
         MOV     (PC)+,R0        ; STICK TRAP OP INTO R0
         TRAP    UBREAK
         MOV     R0,@#BACK       ; STICK TRAP INTO FETCH SEQUENCE
         BR      TREXIT
 1$:     CMPB    R0,STOP         ; IS IT A CONTROL S? (START-STOP)
         BNE     2$
         COM     SFLAG           ; FLIP STATE OF STOPPED FLAG (0 MEANS GOING)
         BR      TREXIT          ; AND SPLIT
 2$:     CMPB    R0,FLUSH        ; A CONTROL F? (FLUSH REQUEST?)
         BNE     3$
         COM     OFLAG           ; FLIP FLUSH STATE
         CLR     TXLENG          ; HALT ANY IO IN PROGRESS
         BR      TREXIT          ; AND THEN GO AWAY
 3$:     CMPB    R0,#DC2         ; ALPHALOC/K SWAP?
         BNE     TRQCHR
         COM     ALOCK
         BR      TREXIT
 TRQCHR: CMP     TRQUED,#TRBFSZ  ; OVERFLOW BUFFER?
         BLT     1$              ; IF NOT THEN OK TO QUEUE CHAR
         .TTYOUT #BUZZ           ; TELL THE USER HIS INPUT WAS CHUCKED
         BR      TREXIT          ; AND FORGET IT (LIFE'S A BITCH)
 1$:     TST     ALOCK           ; CHECK OUT ALHPA LOCK TOGGLE
         BNE     5$              ; ZERO SIGNALS ALOCK ON
         CMPB    R0,#'A!40       ; COMPARE TO A LOWER CASE A
         BLT     5$              ; IF LESS THEN PASS ON THOUGH
         CMPB    R0,#'Z!40       ; NOW SEE IF LEQ LC Z
         BHI     5$              ; IF > Z THEN PASS THROUGH
         BIC     #40,R0          ; ELSE ZAP LC BIT FOR 'A..'Z
 5$:     MOV     R3,-(SP)        ; SAVE R3 FOR USE AS SCRATCH
         MOV     TRTAIL,R3       ; POINTER TO TAIL OF INPUT QUEUE
         MOVB    R0,TRBUFR(R3)   ; PLACE THE CHAR INTO TAIL OF QUEUE
         INC     R3              ; POINT AT NEXT POSITION IN QUEUE
         BIC     #TRBFSZ,R3      ; CHECK FOR WRAPAROUND
         INC     TRQUED          ; COUNT THE CHAR AS QUEUED
         MOV     R3,TRTAIL       ; AND SAVE FOR NEXT INPUT
         MOV     (SP)+,R3        ; RESTORE R3
         TST     TRUNIT          ; ANY IO'S IN PROGRESS TO KEYBOARD?
         BEQ     TREXIT          ; EQUAL ZERO IF NOT...QUIT
 TRFLBF: MOV     R3,-(SP)        ; WELL, PUT SOME CHARS INTO INPUT BUFFER
         MOV     TRHEAD,R3       ; POINTER TO HEAD OF INPUT QUEUE
         MOVB    TRBUFR(R3),R0   ; MOVE A QUEUED CHAR TO USER BUFFER
         MOVB    R0,@TRBUFA      ; BUT WE WANT IT IN R0 FOR ECHO TOO
         INC     R3              ; BUMP QUEUE HEAD POINTER
         BIC     #TRBFSZ,R3      ; WRAPAROUND AGAIN (MAYBE)
         MOV     R3,TRHEAD       ; AND STASH NEW HEAD POINTER
         DEC     TRQUED          ;ONE LESS CHAR IN INPUT QUEUE
         MOV     (SP)+,R3        ; AND RESTORE R3
         CMP     TRUNIT,#UNITBL+6 ; SEE IF WE WANT TO ECHO AS WE READ IN
         BNE     2$              ; IF NOT INPUT UNIT, SKIP ECHO STUFF
         CMPB    R0,EOF          ; INPUT EOF CHAR?
         BNE     3$              ; IF NOT THEN SKIP
         MOV     TRLENG,R0       ; USE R0 FOR LOOP COUNTER
 1$:     CLRB    @TRBUFA         ; ELSE NULL FILL INPUT BUFFER
         INC     TRBUFA
         SOB     R0,1$           ; FOR ALL REMAINING CHARS
         BR      TRQUIT          ; AND CONSIDER IO COMPLETE
 3$:     CMPB    R0,#177         ; A DEL???
         BEQ     2$              ; DONT ECHO IT...TERAK BUG
         CMPB    R0,CRTESC       ; IS IT THE ESCAPE CHAR?
         BEQ     2$              ; DONT ECHO...MAY MESS UP FORMATTING
         BIC     #100,@TRCSR     ; PREVENT INPUT WHILE ECHOING (FUNNY WINDOW)
         .TTYOUT                 ; SEND R0 TO TTY AS ECHO
 2$:     BIS     #100,@TRCSR     ; RESTORE INPUT ENABLE
         INC     TRBUFA          ; BUMP BUFFER ADDRESS
         DEC     TRLENG          ; ONE FEWER CHARS TO READ INTO BUFFER
         BEQ     TRQUIT          ; WE ARE DONE IF IT GOES TO ZERO
         TST     TRQUED          ; WE CAN TRANSFER MORE CHARS IF ANY IN BUFFER
         BGT     TRFLBF          ; SO GO TO FILL BUFFER LOCATION
         BR      TREXIT          ; WELL, NO CHARS, RETURN TO USER NOT DONE
 TRQUIT: BIC     #BSYBIT,@TRUNIT ; MARK OUR UNIT AS NOT BUSY
         CLR     TRUNIT          ; AND NOW HANDLER IS NOT BUSY EITHER
 TREXIT: MOV     (SP)+,R0        ; RESTORE R0
         JMP     INTRTN          ; AND RETURN TO WHEREVER

 TRSTRT: ; THIS IS THE ENTRY POINT FOR STARTING I-O'S TO THE
         ; KEYBOARD DEVICE.  NOTE THE REASON THIS CODE IS HERE
         ; IS TO MAKE BRANCHING EASY.  ALSO PLEASE FORGIVE
         ; THE DIDLING TO SAVE REGISTERS ACROSS TRFLBF ETC.
         TST     TRUNIT          ; SEE IF ANY IO'S IN PROGRESS
         BNE     TRSTRT          ; AND HANG IF SO
         MTPS    #200            ; PREVENT ANY INTERRUPTS NOW
         MOV     R1,TRUNIT       ; MARK AS IO IN PROGRESS
         BIS     #BSYBIT,(R1)    ; MARK UNIT AS BUSY
         CLR     (SP)            ; ON RTI, BE AT PR0
         TST     (R3)+           ; GET RETURN ADDRESS AND
         MOV     R3,-(SP)        ; PLACE ON STACK FOR RTI AT TREXIT
         MOV     R0,-(SP)        ; NOW STACK LOOKS LIKE INSIDE OF TRINT
         MOV     <UBUFFR+TROFST>(SP),TRBUFA      ; SAVE USER BUF ADDR
         MOV     <URLENG+TROFST>(SP),TRLENG      ; AND REQUESTED TRANSFER LENG
         BEQ     TRQUIT          ; IF NOTHING, THEN QUIT NOW
         TST     TRQUED          ; IF SOME CHARS WAITING, THEN GET EM
         BNE     TRFLBF          ; AND PUT EM IN USERS BUFFER
         BR      TREXIT          ; ELSE RETURN TO SYSTEM

 TRMSTRT:; THIS ROUTINE JUST FIGURES IF INPUT OR OUTPUT
         ; REQUEST AND TRANSFERS TO THE PROPER HANDLER.
         TST     @R3             ; ZERO MEANS A WRITE REQUEST...SEE UWRITE
         BEQ     TXSTRT          ; SO START TERM TRANSMIT
         BR      TRSTRT          ; ELSE A READ START

 TRMABRT:; ENTERED TO CANCEL ANY IO'S PENDING
         ; OR IN PROGRESS ON CRT DEVICE
         MTPS    #200
         CLR     SFLAG
         CLR     OFLAG
         CLR     TRQUED
         MOV     TRTAIL,TRHEAD
         TST     TRUNIT
         BEQ     1$
         CLR     TRLENG
         BIC     #BSYBIT,@TRUNIT
         CLR     TRUNIT
 1$:     TST     TXUNIT
         BEQ     2$
         CLR     TXLENG
         BIC     #BSYBIT,@TXUNIT
         CLR     TXUNIT
 2$:     MTPS    #0
         RTS     PC

 TXCSR:  .WORD   177564
 TXBUF:  .WORD   177566
 TXUNIT: .WORD   0       ; UNIT TABLE ADDRESS OF IO IN PROGRESS
 TXLENG: .WORD   0       ; NUMBER OF BYTES LEFT TO BE SENT TO TERMINAL
 TXBUFA: .WORD   0       ; BYTE ADDRESS OF NEXT CHAR TO SEND
 TXCHAR: .WORD   -1      ; HIGH PRIORITY CHAR TO SEND...FROM TTYOUT

 TXOFST  = 4
 TXSTRT: ; THIS CODE STARTS IO'S TO THE CONSOLE DEVICE
         ; ACCORDING TO STANDARD IO.OPS PROTOCOL
         TST     TXUNIT          ; SEE IF AN IO ALREADY IN PROGRESS
         BNE     TXSTRT          ; IF SO LOOP UNTIL THE IO IS COMPLETE
         MTPS    #200            ; NO INTERRUPTS PLEASE
         MOV     R1,TXUNIT       ; MARK HANDLER AS BUSY
         BIS     #BSYBIT,(R1)    ; MARK LOGICAL UNIT AS BUSY
         CLR     (SP)            ; SET UP RETURN STUFF ON STACK...PR-0 PS
         TST     (R3)+           ; SKIP R3 OVER IO INFO WORD
         MOV     R3,-(SP)        ; NOW THE RETURN ADDRESS
         CMP     R1,#UNITBL+14   ; IS THE WRITE TO SYSTERM??
         BNE     1$              ; IF NOT THEN LEAVE OUTPUT FLAGS ALONE
         CLR     SFLAG           ; ELSE CLEAR THE STOP FLAG
         CLR     OFLAG           ; AND FLUSH FLAG
 1$:     TST     OFLAG           ; IF OUTPUT TO BE FLUSHED?
         BNE     TXQUIT          ; IF SO THEN MARK IO AS COMPLETE NOW
         MOV     <UBUFFR+TXOFST>(SP),TXBUFA      ; GRAB USER BUFFER ADDR
         MOV     <URLENG+TXOFST>(SP),TXLENG      ; AND REQUESTED IO LENGTH
 TX$INT: BIC     #100,@TXCSR     ; NO INTERRUPTS PLEASE
         TST     TXCHAR          ; SEE IF ANY CHARS TO SEND RIGHT NOW
         BMI     NOCHAR          ; IF NEG THEN NO CHAR TO SEND
         MOV     R0,-(SP)        ; STASH A REG FOR NULLING
         MOV     TXCHAR,R0       ; GRAB THE ACTUAL CHAR
         MOVB    R0,@TXBUF
         CMP     R0,#CR          ; IS IT ACR (MUST FILL AND LF)
         BNE     1$
         JSR     PC,NULLER       ; SEND STUFF FOR FILL COUNT
 1$:     COM     TXCHAR          ; FLIP NEG BIT...NO DATA ANYMORE
         MOV     (SP)+,R0        ; RESTORE
         BIS     #100,@TXCSR     ; OK TO INTERRUPT NOW
         JMP     INTRTN          ; AND GO ON AS IF NOTHING HAPPENED
 NOCHAR: TST     TXUNIT          ; ANY IO'S IN PROGRESS
         BEQ     TXEXIT          ; IF NOT JUST FORGET IT
         TST     TXLENG          ; ANY CHARS LEFT TO BE SENT?
         BEQ     TXQUIT          ; IF NOT THEN FINISH UP IO
         TST     SFLAG           ; SEE IF OUTPUT IS STOPPED
         BEQ     1$              ; IF NOT THEN SKIP THE WAITING STATE
         MTPS    #0              ; LEAVE CRITICAL REGION FOR DEVICE
         MTPS    #200            ; BACK UP TO PR-4
         BR      NOCHAR          ; AND GO TEST SFLAG AGAIN
 1$:     MOV     R0,-(SP)        ; STASH REG
         CLR     R0
         BISB    @TXBUFA,R0      ; GRAB CHAR FROM USER BUFFER
         MOVB    R0,@TXBUF       ; SEND CHAR TO DL
         CMPB    R0,#CR          ; IS IT A CR??
         BNE     2$              ; IF NOT THEN....SKIP
         JSR     PC,NULLER       ; SEND FILL AND LF
 2$:     MOV     (SP)+,R0        ; RESTORE TEMP REG
         BIS     #100,@TXCSR     ; ENABLE FOR NEXT COMPLETE
         INC     TXBUFA          ; BUMP BUFFER POINTER TO NEXT CHAR
         DEC     TXLENG          ; ALSO REFLECT ONE FEWER CHAR TO SEND
         JMP     INTRTN          ; THIS STRUCTURE IMPLIES AN IO IS NOT
                                 ; DONE UNTIL THE LAST INTERRUPT IS RECEIVED
 TXQUIT: BIC     #BSYBIT,@TXUNIT ; CLEAR BUSY BIT IN IO UNIT TABLE
         CLR     TXUNIT          ; MARK HANDLER AS NOT BUSY NOW
 TXEXIT: JMP     INTRTN          ; AND BACK NOW TO WHEREVER

 NULLER: ; HANDY SUBROUTINE FOR NULL FILLING AND LF AFTER CR
         ; ASSUME R0 SCRATCH (WELL...=CR) AND INTERRUPTS DISABLED
         MTPS    #0
         .IF     NDF,TERAK
         MOVB    FILCNT,R0       ; GRAB NILL COUNT (IF ANY)
         BEQ     2$
 1$:     TSTB    @TXCSR          ; HANG UNTIL DL READY
         BPL     1$
         CLRB    @TXBUF
         SOB     R0,1$
         .ENDC
 2$:     TSTB    @TXCSR          ; HANG UNTIL READY FOR LF SEND
         BPL     2$
         MOVB    #LF,@TXBUF
         MTPS    #200
         RTS     PC
         .PAGE
         .CSECT  TABLES

         .BLKW   128.    ; ROOM FOR OP XFER TABLE

 UNITBL: .WORD   0,0,0   ; UNIT 0 NOT USED
         .WORD   INBIT!OUTBIT,TRMSTRT,TRMABRT
         .WORD   INBIT!OUTBIT,TRMSTRT,TRMABRT
         .REPT   <MAXUNT-2>
         .WORD   0,0,0
         .ENDR

         .END


========================================================================================
DOCUMENT :usus Folder:VOL19:vol19.doc.text
========================================================================================

                                USUS Volume #19
                                  
                         ---> DEC & RX01 Specific <---
                             
            UCSD Version I.3 bootable run-time system and DEC notes

VOL19:
MODEM.PAS.TEXT     6   A simple routine to redirect I/O 
DEC.INDEX.TEXT     6   An index of the DEC specific software already
                                   in the USUS Library
2K.KEY.TEXT       12   Some patches for the 2k Key                    
PATCHES.TEXT      30   A summary of the patches to the UCSD DEC
PATCH.CONT.TEXT   20     interpreters to make them work right
SYSTEM.INTERP     18   The interpreter for I.3
SYSTEM.PASCAL    110   The operating system for I.3
XFER.CODE          3   A single drive file transfer program for I.3
BOOTER.CODE        2   The I.3 bootstrap copier
SETUP.CODE        13   The I.3 Setup utility
MAKE_I.3.TEXT      4   An RT-11 command file to assemble and link
                                the I.3 interpreter
RX11.TEXT         26   The I.3 floppy driver
EIS.TEXT           4   A conditional assembly definition
MACROS.TEXT       14   Macro definitions for the I.3 interp
MAINOP.TEXT       64   Part of the guts of the I.3 interp
TRAPS.TEXT        36     ditto
PROCOP.TEXT       64     ditto
LP11.TEXT         10   The printer driver for I.3
RXBOOT             2   The boot block for I.3
PVM.MAC.TEXT      16   A RAMDISK handler for II.0
ZAPRAM.TEXT        6   A utility to initialize RAMDISK on boot
VOL19.DOC.TEXT    10   You're reading it
__________________________________________________________________________
                         
Please transfer the text below to a disk label if you copy this volume.

    USUS Volume 19 -***- USUS Software Library
                         
   For not-for-profit use by USUS members only.
  May be used and distributed only according to 
      stated policy and the author's wishes.



This volume was assembled by George Schreyer from material collected by
the Library committee.

__________________________________________________________________________

Some notes from the editor:


                          I.3 bootable run-time system

     This disk should boot on an RX01.  It will not work with an RX02.  If you
are lucky and it does boot, then welcome to the wonderful world of I.3.  Read
up on YALOE as I.3 doesn't have a screen editor.  There is documentation
available in the USUS archive, but not in soft form.  I am going to try to get
the users manual in soft form into the Library sometime.  In the meanwhile,
you'll have to fake it.  The system is marginally set up for an H-19.

     The sources for the operating system are on volume 17, with the source to
the debugger on volume 18.  The interpreter sources are on this disk, but you
must have RT-11 or HT-11 to assemble them and FORLIB.OBJ or SYSLIB.OBJ to link
them.  The file MAKE_I.3 is an RT-11 command file to assemble and link the
interpreter.  You can use EDITTORT11.CODE (in your UCSD distribution kit) to
move the sources over to RT-11 and the interpreter back to UCSD.  You must use
the B(inary option to move the interpreter. 
     
                                    PATCHES

     The UCSD interpreter was never implemented "right" for the LSI-11.  This
file lists some of the most common problems and object patches that you can do
with PATCH, DISKREAD, UNLPATCH or some other patch utility to "fix" the
problems.

                                     2K_KEY

     This is a description of the bootstrap patches necessary to make the 2K_KEY
ROM (for an H-27) be able to recognize the 4k bytes extra memory that you bought
it for.
                                        
                                   DEC_INDEX

     This is a short index of all of the DEC specific software published in
previous volumes of the USUS Software Library.

                                   MODEM.PAS

     This simple routine redirects the remote port to the console port so
that you can control your p-system from a remote terminal.  It works on both
IV.0 and II.0.  You have to cold boot to switch it back.

                                    PVM.MAC

     This is an adaption of the VM.MAC RAMDISK handler in DECUS.  It is
supposed to work with II.0 and an LSI-11/23 with the KT-11 MMU and extended
memory. There will be an upcoming article in the newsletter by Eli Willner
about RAMDISK.  ZAPRAM is a Pascal program which you can install as
SYSTEM.STARTUP to initialize RAMDISK on bootup.  You need RT-11 and the II.0 
building kit or sources to install it.



========================================================================================
DOCUMENT :usus Folder:VOL19:xfer.code
========================================================================================

< binary file -- not listed >

========================================================================================
DOCUMENT :usus Folder:VOL19:zapram.text
========================================================================================

program zapramdisk;
 
{ Creates a directory for RAMDISK, assumed to be device #11:
  Note the constant values and change as desired or appropriate.
  Compile and rename .CODE file to SYSTEM.STARTUP
  
  By Eliakim Willner
     USUS DEC SIG Chairman                                        }
 
 
const dirblk = 2;
      RamUnit = 11;  {If you changed this in the macro file, change here too}
      UnitName = 'RAMDISK';  {Change to your taste}
      NumOfBlocks = 374;     {Valid for systems with 256kb. Adjust as needed}
 
type
   daterec = packed record
                      month: 0..12;
                      day: 0..31;
                      year: 0..100
                    end;
                    
   filkind = (untypedfil,xdskfil,codefil,textfil,
              infofil,datafil,graffil,fotofil,securedir);
 
   direntry = packed record
                dfirstblk: integer;   { first physical disk addr }
                dlastblk: integer;    { points at block following dir }
                case dfkind: filkind of
                  securedir,
                  untypedfil: { only in beginning of dir; volume info }
                     (somejunk : 0..2048;
                      dvid: string[7];        { volume name }
                      deovblk: integer;       { lastblk of volume }
                      dnumfils: 0..77;        { number of files in dir }
                      dloadtime: integer;
                      dlastboot: daterec);
                  xdskfil,codefil,textfil,infofil,
                  datafil,graffil,fotofil:
                     (morejunk : 0..1024;
                      status : boolean;
                      dtid: string[15];
                      dlastbyte: 1..512;
                      daccess: daterec)
              end;
 
var
   dir0 : direntry;
   
begin
   with dir0 do
      begin
         dfirstblk := 0; 
         dlastblk := 6;
         dfkind := untypedfil; 
         dvid := UnitName;
         deovblk := NumOfBlocks;
      end;
   unitwrite (RamUnit, dir0, sizeof(dir0), dirblk);
end.
 


========================================================================================
DOCUMENT :usus Folder:VOL20:autopsy.text
========================================================================================

PROGRAM AUTOPSY;    (*Version 1.0, 20 Oct 81*)

USES (*$U screen.code*) SCREEN;

CONST FILESIZE = 23;  (*23+1 blocks/file (22 of text)*)
      checking = true;

TYPE  FNAME = STRING[24];

VAR   FIN, FOUT : FILE;
      BLANK,BUFFER : PACKED ARRAY [0..511] OF CHAR;
      BLKNO,BLKSXFERRED,I,J,TOTALBLKS,RSLT : INTEGER;
      BADIO : BOOLEAN;
      SFIN,SFOUT,STEMP : FNAME;
      REPLY : CHAR;
      ISTRG : STRING;
      
(*$I-*)
  
  PROCEDURE RSTFILE(VAR S : FNAME; X,Y : INTEGER);
    BEGIN
      REPEAT
        READLN(S);
        RESET(FIN,S);
        RSLT := IORESULT;
        IF (RSLT <> 0) THEN
          BEGIN
            IF (RSLT = 10) THEN
              BEGIN
                S := CONCAT(S,'.TEXT');
                RESET(FIN,S);
                RSLT := IORESULT
              END;
            IF (RSLT = 12) THEN
              BEGIN
                CLOSE(FIN,LOCK)
              END;
            IF (RSLT <> 0) THEN
              BEGIN
                GOTOXY(0,22);
WRITE('IO error ',RSLT,'.  Correct and type <SP> to continue or Q(uit');
                REPEAT READ(KEYBOARD,REPLY) UNTIL REPLY IN ['Q','q',' '];
                CLEARSPACE(0,22,80);
                IF (REPLY IN ['Q','q']) THEN EXIT(PROGRAM)
                ELSE CLEARSPACE(X,Y,LENGTH(S))
              END
          END
        UNTIL RSLT = 0
      END;
      
  PROCEDURE RWRFILE;
    BEGIN
      REPEAT
        REWRITE(FOUT,SFOUT);
        RSLT := IORESULT;
        IF (RSLT <> 0) THEN
          BEGIN
            GOTOXY(0,22);
WRITE('Ouput file IO error ',RSLT,'. Correct and type <SP> to continue or Q(uit.');
            REPEAT READ(KEYBOARD,REPLY) UNTIL REPLY IN [' ','Q','q'];
            IF REPLY IN ['Q','q'] THEN
              BEGIN
                CLEARSCREEN;
                EXIT(PROGRAM)
              END
            ELSE CLEARSPACE(0,23,80)
        END
      UNTIL (RSLT = 0)
    END;
    
  Procedure checkit(inblock : boolean);
    begin
      if checking then
        if inblock then
          begin
            badio := ((blksxferred < 1) or (ioresult > 0));
            if badio then
              writeln('Inblock ',BLKNO,' Ioresult = ',IORESULT,'.   Blksxferred = ',BLKSXFERRED);
          end
        else 
          begin
            badio := ((blksxferred < 1) or (ioresult > 0));
            if badio then
              writeln('Outblock ',BLKNO,' Ioresult = ',IORESULT,'.   Blksxferred = ',BLKSXFERRED);
          end
    end;
    
  BEGIN (*program*)
    CLEARSCREEN;
    BADIO := FALSE;
    WRITE('Enter name of input file (file to be divided): ');
    RSTFILE(SFIN,47,0);
    WRITELN;
    WRITE('Enter base name (VOL:XXXXXXXX (8 digits max) of output files: ');
    REPEAT
      READLN(STEMP);
      IF (LENGTH(STEMP)-POS(':',STEMP) > 8) OR (LENGTH(STEMP) = 0) THEN
        BEGIN
          GOTOXY(0,22);
          WRITE('Improper file name.  Type <SP> to continue, Q(uit.');
          REPEAT READ(KEYBOARD,REPLY) UNTIL REPLY IN [' ','Q','q'];
          IF REPLY IN ['Q','q'] THEN EXIT(PROGRAM);
          CLEARSPACE(0,22,80);
          CLEARSPACE(45,2,24);
        END;
      UNTIL (LENGTH(STEMP)-POS(':',STEMP) <= 8) AND (LENGTH(STEMP) > 0);
    WRITELN;
    FOR J := 0 TO 511 DO BLANK[J] := CHR(0);
    I := 1;
    BLKNO := 2;
    REPEAT
      STR(I,ISTRG);
      SFOUT := CONCAT(STEMP,'.',ISTRG,'.TEXT');
      RWRFILE;
      TOTALBLKS := 0;
      FOR J := 1 TO 2 DO
        BEGIN
          BLKSXFERRED := BLOCKWRITE(FOUT,BLANK,1,TOTALBLKS);
          checkit(false);
          TOTALBLKS := TOTALBLKS+1
        END;
      BLKSXFERRED := BLOCKREAD(FIN,BUFFER,1,BLKNO);
      checkit(true);
      WHILE NOT EOF(FIN) AND (TOTALBLKS<=FILESIZE) AND (IORESULT=0) AND
       (NOT BADIO) AND (BLKSXFERRED=1) DO
        BEGIN
          BLKSXFERRED := BLOCKWRITE(FOUT,BUFFER,1,TOTALBLKS);
          BADIO := ((BLKSXFERRED < 1) OR (IORESULT > 0));
          if checking then
              writeln('Outblock ',TOTALBLKS,' Ioresult = ',IORESULT,'.   Blksxferred = ',BLKSXFERRED);
          BLKNO := BLKNO+1;
          TOTALBLKS := TOTALBLKS+1;
          IF (TOTALBLKS <= FILESIZE) THEN
            BEGIN
              BLKSXFERRED := BLOCKREAD(FIN,BUFFER,1,BLKNO);
              checkit(true)
            END;
        END;
      I := I+1;
      IF EOF(FIN) THEN
        BEGIN
          BLKSXFERRED := BLOCKWRITE(FOUT,BUFFER,1,TOTALBLKS);
          TOTALBLKS := TOTALBLKS +1;
          checkit(false)
        END;
      CLOSE(FOUT,LOCK);
    UNTIL EOF(FIN) OR (BADIO) OR (IORESULT <> 0);
    WRITELN(BLKNO-1,' blocks transferred; ',I-1,' files created.');
  END.

========================================================================================
DOCUMENT :usus Folder:VOL20:base.text
========================================================================================

PROGRAM BASE;      (*Version 2.1 - 10 Feb 83*)

USES {$U H19UTIL.CODE} H19UTIL, {$U NUMBER2.CODE} NUMBER2;

VAR     DATA : INTEGER;
        REPLY : CHAR;
        S : STRING;
        FIRSTTIME : BOOLEAN;
        
PROCEDURE GETDEC(VAR DATA : INTEGER);
  VAR   RL : REAL;
  PROCEDURE ERRHNDLR;
    CONST BELL = 7;
    BEGIN
      CLEARSPACE(0,0,80);
      WRITE(CHR(BELL),'Improper number. Retype.');
      GOTOXY(XCUR,YCUR);
      CLEAR_EOL;
      GETDEC(DATA);
      SAVECURSOR(XCUR,YCUR);
      CLEARSPACE(0,0,80);
      GOTOXY(XCUR,YCUR);
      EXIT(GETDEC)
    END;
    
  BEGIN
    SAVECURSOR(XCUR,YCUR);
    RL := INREAL(INPUT,INPT);
    IF (RL>32767.0) OR (RL<-32768.0) THEN ERRHNDLR;
    DATA := TRUNC(RL)
  END;
  
PROCEDURE ASKFORIT(S : STRING);
  BEGIN
    WRITE('Enter ',S,' number: ');
  END;
  
BEGIN
  FIRSTTIME := TRUE;
  REPEAT
    CLEARSCREEN;
    IF NOT(FIRSTTIME) THEN
      BEGIN
        GOTOXY(0,6);
        CASE REPLY OF
          'B' : BEGIN
                  S := 'binary';
                  ASKFORIT(S);
                  GETBINARY(DATA);
                END;
          'D' : BEGIN
                  S := 'decimal';
                  ASKFORIT(S);
                  GETDEC(DATA);
                END;
          'F' : BEGIN
                  S := 'fliphex';
                  ASKFORIT(S);
                  GETFLIP(DATA);
                END;
          'H' : BEGIN
                  S := 'hex';
                  ASKFORIT(S);
                  GETHEX(DATA);
                END;
          'O' : BEGIN
                  S := 'octal';
                  ASKFORIT(S);
                  GETOCTAL(DATA);
                END;
          'Q' : BEGIN
                  CLEARSCREEN;
                  EXIT(PROGRAM)
                END
        END;
        WRITELN('   Decimal value = ',DATA);
        WRITE('   Binary value = ');
        WRITEBIN(DATA);
        WRITELN;
        WRITE('   Octal value = ');
        WRITEOCTAL(DATA);
        WRITELN;
        WRITE('   Hex value = ');
        WRITEHEX(DATA);
        WRITE('   Flipped hex value = ');
        WRITEFLIP(DATA);
        WRITELN;
        WRITELN;
        WRITELN;
        WRITELN;
      END
    ELSE
      BEGIN
        FIRSTTIME := FALSE;
        GOTOXY(0,14)
      END;
REPLY := COMMAND('D(ecimal, O(ctal, H(exadecimal, B(inary, F(lipbyte, Q(uit',
             ['B','D','F','H','O','Q']);
  UNTIL FALSE
END.

========================================================================================
DOCUMENT :usus Folder:VOL20:bios.const.text
========================================================================================


;  This section defines the constants used to identify ports, bits, 
;  and other constant elements of the BIOS environment.



;  Port assignments
;  ---- -----------

CNT_MDM   .EQU  8BH                ;  Clock divider for serial
;                                     port controllers.

CNT_REG_0 .EQU  88H                ;  Counter register 0.

CNT_REG_1 .EQU  89H                ;  Counter register 1.

CNT_REG_2 .EQU  8AH                ;  Counter register 2.

CRT_DATA  .EQU  0A8H               ;  CRT data port.

CRT_STAT  .EQU  0A9H               ;  CRT status port.

DIA_DATA  .EQU  86H                ;  Output to printer.

DIA_STAT  .EQU  87H                ;  Printer status register.

DMA_CTL   .EQU  0B8H               ;  DMA mode port.

DMA_ADR   .EQU  0B0H               ;  DMA address entry port.

DMA_TCNT  .EQU  0B1H               ;  DMA terminal count.

FDC_DATA  .EQU  0A1H               ;  FDC command and results.

FDC_INT   .EQU  0A2H               ;  [7] indicates FDC command
;                                     completion.

FDC_STAT  .EQU  0A0H               ;  FDC status.

PRT_DIA   .EQU  86H               ;  Diablo printer port address, KGB
;                                     config.

PRT_MODEM .EQU  84H                ;  Modem controller address, cur-
;                                  rently not implemented.

;  Disk Control Parameters
;  ---- ------- ----------

FDC_ONLIN .EQU  5                  ;  Ready in SR3.

FMT_SKEW  .EQU  7                  ;  Sector skew to apply to disk
                                   ;  formatting--Pascal interleave and
                                   ;  skew are [1:0].

MFD_INTL  .EQU  1                  ;  Interleave for single-sided disks.

MFD_SKEW  .EQU  0                  ;  Skew for single-sided disks.

DSK_RETRY .EQU  5                  ;  Number of errors to allow before
                                   ;  reporting CRC failure.

;  Serial Board Control Parameters
;  ------ ----- ------- ----------

DIA_SPEED .EQU  13                 ; Speed divisor for Diablo 630 printer
                                   ; --9600 Baud.

PRT_DSR   .EQU  7                  ; Device on-line flag.

MDM_SPEED .EQU  13                 ; Dummy: no current modem device.

PRT_RRDY  .EQU  1                  ; Receive register full.

STAT_PRT  .EQU  1                  ; Offset of Status serial port.

PRT_RTSB  .EQU  0                  ; Ready to send.

PRT_THBE  .EQU  2                  ; Transmit buffer empty.


;  Disk Control Block Offsets
;  ---- ------- ----- -------


;  Phone Port Offsets
;  ----- ---- -------


;  Phone Control Parameters
;  ----- ------- ----------


;  ASCII Character Codes
;  ----- --------- -----

ACR       .EQU  0DH                ;  <Carriage return>.
AESC      .EQU  1BH                ;  <Escape>.



========================================================================================
DOCUMENT :usus Folder:VOL20:bios.data.text
========================================================================================


;  This section defines the working storage data blocks used by the 
;  BIOS for its own purposes.

;  Disk Command Tables
;  ---- ------- ------

SIS_CMD_TB:
;  Table to define Sense Interrupt Status command.
.BYTE     08H

FDC_CMD_TBL:
;  Table of control parameters needed by FDC.  Symboled entries
;  are variable.  Not all commands require the full table, but all
;  need an ordered subset.

FDC_CMD   .BYTE 0                  ;  Command.

FDC_DRVNO .BYTE 0                  ;  Disk number.

FDC_TRACK .BYTE 0                  ;  Track number of track to which disk
                                   ;  is currently positioned, or 0FFH if
                                   ;  position is not known.
          
          .BYTE 0                  ;  Head number.

FDC_SECTR .BYTE 0                  ;  Sector number.
          
          .BYTE 2                  ;  Sector size = 2 for 512.
          
          .BYTE 9                  ;  Sectors / track.
          
          .BYTE 27                 ;  Gap-3 read/write length.  Format
                                   ;  length is 84 bytes for Sony disks.
          .BYTE 0FFH               ;  Data length (superseded
                                   ;  by sector size.
          
FDC_FMT_TBL:
;  Command list for formatting a track.

          .BYTE 4DH                ;  Format command byte.

          .BYTE 1                  ;  Disk number (always 1).

          .BYTE 2                  ;  Bytes/sector (2 => 512).

          .BYTE 9                  ;  Sectors/track.

          .BYTE 84                 ;  Gap 3 length for formatting.

          .BYTE 4EH                ;  Formatted disk filler byte.

;  Formatting Sector Definition Lists
;  ---------- ------ ---------- -----

FMT_0_LST:
;  Sector sequence for track 0, to optimize access to bootstrap.
          .BYTE 0, 0, 1, 2
          .BYTE 0, 0, 6, 2
          .BYTE 0, 0, 7, 2
          .BYTE 0, 0, 8, 2
          .BYTE 0, 0, 9, 2
          .BYTE 0, 0, 2, 2
          .BYTE 0, 0, 3, 2
          .BYTE 0, 0, 4, 2
          .BYTE 0, 0, 5, 2

FMT_I_LST:
;  Sector sequence for track 1, to optimize access
;  through BIOS per format change study.

          .BYTE 0, 0, 1, 2
          .BYTE 0, 0, 6, 2
          .BYTE 0, 0, 2, 2
          .BYTE 0, 0, 7, 2
          .BYTE 0, 0, 3, 2
          .BYTE 0, 0, 8, 2
          .BYTE 0, 0, 4, 2
          .BYTE 0, 0, 9, 2
          .BYTE 0, 0, 5, 2

;  Operating System Link Storage
;  --------- ------ ---- -------

PASDCH    .BLOCK  2                ;  Address of disk change routine.

PASEVENT  .BLOCK  2                ;  Address of event signal acceptor.

;  Disk Control Storage
;  ---- ------- -------

FDC_DMADR       .BLOCK    2        ;  Address of sector buffer.

FDC_DMA_LEN     .BLOCK    2        ;  Termination count for DMA.

FDC_XFR_CMD     .BLOCK    1        ;  Storage for read/write command
                                   ;  until needed.

FDC_TGT_TK      .BLOCK    1        ;  Target track of next seek command.

R_W_MSK         .BLOCK    1        ;  Error selection byte which
                                   ;  prevents Write Only errors
                                   ;  in the read operation.

;  Disk Formatting Storage
;  ---- ---------- -------

FMT_D_LST       .BLOCK   FMT_SKEW * 4
                                   ;  Pre-sector-table extension for
                                   ;  rotating sector list through skew
                                   ;  of 4.

FMT_N_LST       .BLOCK   36        ;  Working copy of format list
                                   ;  rotated to match skew requirements.
                                   ;  NOTICE!  This table MUST follow
                                   ;  FMT_D_LST immediately!

FMT_X_BLK       .BLOCK   512       ;  Block for moving bootstrap from
                                   ;  one disk to another during format.



========================================================================================
DOCUMENT :usus Folder:VOL20:bios.disks.text
========================================================================================


FMT_DISK:
; This service, available through an addition to the Pascal jump
; table, formats the disk in Drive 1 and copies the bootstrap on
; the disk on drive 0 to drive 1.

; On Exit:
;         (A) = IO_RESULT.

; Interaction with the operator is through a Pascal program which uses
; this service.

; This SBIOS assumes that the interleave and skew are adjusted during
; formatting, so that the Pascal interleave is 1 and skew is 0.

; Recalibrate drive 1.
          LD    C, 1
          CALL  DSKDKN

          CALL  FDC_RECAL
          RET   NZ

; Set track 0 format to optimize bootstrap loading.
          LD    HL, FMT_0_LST
          CALL  SEND_F_LST

; Format track 0.
          CALL  SEND_FMT
          AND   A
          RET   NZ

; Other tracks are set to interleave 2, skew 2.  Set up base
; format list for track 1.
          LD    HL, FMT_I_LST
          LD    DE, FMT_N_LST
          LD    BC, 36
          LDIR

          LD    B, 69
          LD    C, 1

$1:
          PUSH  BC

; Set track number into FMT_N_LST.
          LD    B, 9
          LD    HL, FMT_N_LST

$2:
          LD    (HL), C
          INC   HL
          INC   HL
          INC   HL
          INC   HL
          DJNZ  $2
          
          CALL  DSKDKT
          CALL  FDC_SEK

          LD    HL, FMT_N_LST
          CALL  SEND_F_LST

          CALL  SEND_FMT

; Rotate the sector list to produce desired skew.
          LD    DE, FMT_D_LST
          LD    HL, FMT_N_LST
          LD    BC, 36
          LDIR

          LD    HL, FMT_D_LST
          LD    BC, FMT_SKEW * 4
          LDIR

; Analyze the result of the format command and report errors.
          POP   BC
          AND   A
          RET   NZ
          INC   C
          DJNZ  $1

; Read sectors of drive 0, track 0, and copy to drive 1, track 0.
          LD    C, 0
          CALL  DSKDKT
          
          LD    BC, FMT_X_BLK
          CALL  DSKDKB
          
          LD    B, 9
          LD    C, 1

$3:
; Set the sector.  Note that transfer is not done in optimal
; sequence for track 0.
          PUSH  BC
          CALL  DSKDKS
          
; Read sector from Disk 0.
          LD    C, 0
          CALL  DSKDKN

          CALL  DSKDKR
          AND   A
          JR    NZ, $4

; No read errors.  Write sector onto disk 1.
          LD    C, 1
          CALL  DSKDKN
          
          CALL  DSKDKW
          AND   A

$4:
          POP   BC
          RET   NZ
          
          INC   C
          DJNZ  $3

; Return to call.
          RET


SEND_F_LST:
; This service prepares the DMA controller to send a format parameter
; list to the FDC as needed during track formatting.

; On Entry:
;         (HL) => Format Control list.

          LD    C, DMA_ADR
          OUT   (C), L
          OUT   (C), H
          INC   C                   ; DMA_TMCNT
          LD    HL, 8023H
          OUT   (C), L
          OUT   (C), H
          LD    A, 41H
          OUT   (DMA_CTL), A
          RET


SEND_FMT:
; This service sends the format command list to the FDC and interprets
; its response.
          LD    HL, FDC_FMT_TBL
          LD    B, 6
          CALL  SEND_CMD
          CALL  POLL_INT
          CALL  INT_R_W_ST
          RET


SEND_CMD:
; Write a command to the disk.

; On Entry:
;         (B) = Command Table Length.
;         (HL) => Command Table.

; On Exit:
;         (B), (C), (HL) spoiled.

          LD    C, FDC_DATA

$1:
; Wait for FDC to be ready.
          IN    A, (FDC_STAT)
          AND   0C0H
          CP    080H
          JR    NZ, $1

; Send next character.
          OUTI
          RET   Z
          JR    $1
          

DED_DSK:
; Report disastrous disk error (unrecoverable protocol conflict).
          LD    HL, RPTDER
$1:
          LD    A, (HL)
          CP    0FFH
          JR    Z, $
          LD    C, A
          CALL  DR_CRO
          INC   HL
          JR    $1

RPTDER:
; Clear screen, home cursor and report error.
          .BYTE 1AH, 1EH
          .ASCII "Unrecoverable disk protocol error."
          .BYTE 0DH, 0AH, 0FFH


VRFY_DRIV:
; This service tests the drive number against the floppy disk unit
; numbers and returns an off-line status if the unit is too large.
          
          LD    A, (FDC_DRVNO)
          CP    2
          LD    A, 9
          RET

FDC_RECAL:
; This service restores the active drive to track 0.

; On Exit:
;         (A) = 0  |  if recalibration successful.
;         (ZF) set |

;         (A) = IO_RESULT if recalibration unsuccessful, or
;               drive off line.
          
          LD    HL, FDC_CMD_TBL
          LD    (HL), 07H           ; Recalibrate command.
          LD    B, 2
          CALL  SEND_CMD
          
; Wait for recalibration to complete.
          CALL  POLL_INT
          
; Sense status and interpret.
          CALL  SNS_INT_ST
          AND   A
          PUSH  AF
          LD    HL, FDC_TRACK
          JR    Z, $1
          LD    A, 0FFH

$1:
          LD    (HL), A
          POP   AF
          RET


CLR_DISK:
; This service clears all of the disk drives, restoring them to track
; 0, and thereby synchronizing them with the initialized control tables.

; Drive 0.
          LD    C, 0
          CALL  DSKDKN
          CALL  DSKDKI

; Drive 1.
          LD    C, 1
          CALL  DSKDKN
          CALL  DSKDKI
          RET

DSKDKI:
; This service initializes a Pascal disk drive.

; Filter for Semi-Disks.
          CALL  VRFY_DRIV
          RET   NC

;  Recalibrate the drive.  Recalibration will diagnose off-line
;  condition, if present.
          CALL  FDC_RECAL
          RET


DSKDKN:
; This service sets the number of the active disk.

; On Entry:
;         (C) = Disk number.
          
          LD    A, C
          LD    (FDC_DRVNO), A
          
; Set the current track number to impossible value to cause seek on
; next read or write.
          LD    HL, FDC_TRACK
          LD    (HL), 0FFH
          RET


DSKDKT:
; This service sets the number of the track to be selected on the next 
; read or write.

; On Entry:
;         (C) = Track number.

          LD    A, C
          LD    (FDC_TGT_TK), A
          RET


DSKDKS:
; This service records the number of the sector selected for use with 
; the next read or write.

; On entry:
;         (C) = Sector Number.

          LD    A, C
          LD    (FDC_SECTR), A
          RET


DSKDKB:
; This service sets the active buffer location.

; On Entry:
;         (BC) = Buffer address.

          LD    (FDC_DMADR), BC
          RET


FDC_SEK:
; This service positions the disk drives.

; On Exit:
;      (A) = 0  |  if seek successful.
;      (ZF) set |

; Check for too large track number.
          LD    A, (FDC_TGT_TK)
          CP    70
          JR    C, $2

; Track number too high.  Discard immediate return and exit read or
; write procedure with final status.
          POP   HL
          LD    A, 3
          AND   A
          RET

$2:
; Check for change since last seek.
          LD    B, A
          LD    HL, FDC_TRACK
          SUB   (HL)
          RET   Z
          LD    A, B
          LD    (HL), A

; Check for track zero.
          AND   A
          JP    Z, FDC_RECAL

; Construct seek command.
          LD    HL, FDC_CMD_TBL
          LD    (HL), 0FH           ; Seek command.
          LD    B, 3
          CALL  SEND_CMD

; Wait for seek completion.
          CALL  POLL_INT
          
; Interpret result.
          CALL  SNS_INT_ST
          AND   A
          RET   Z
          LD    HL, FDC_TRACK
          LD    (HL), 0FFH
          RET

POLL_INT:
; Detect FDC interrupt signal.  This signals the begining of the
; result phase for many FDC functions.

          IN    A, (FDC_INT)
          RLA
          RET   C
          
; Poll the other IO units for input if the disk is not yet done.
; The address of the following call is set up during system
; initialization.
          CALL  0
          
PASPOL    .EQU  $ - 2
          
          JR    POLL_INT


SNS_INT_ST:
; Checks the status of the FDC after completion os a seek or
; recalibrate.

; On Exit:
;   (A) = 0 if no error.
;         1 if seek abnormally completed.
;         9 if drive off-line.

; Send prompt command.
          LD    HL, SIS_CMD_TB      ; Sense Interrupt command table.
          LD    B, 1
          CALL  SEND_CMD

; Accept the two result bytes.  Only the first is important.
          CALL  GET_RSLT_BT
          LD    B, A
          CALL  GET_RSLT_BT

; Decode error flags.
          BIT   3, B
          LD    A,9
          RET   NZ
          
          LD    A, 0D0H
          AND   B
          RET   Z
          LD    A, 1
          RET


INT_R_W_ST:
; Interpret the seven byte status returned by the FDC after a
; read or write command.  Only the first three bytes are im-
; portant, but all bytes must be read.  Give immediate pre-
; ference to non-CRC errors.

; On Exit:
;   (A) = 0 if no error.
;         1 if CRC error.
;         2 if seek error.
;         3 if illegal IO request.
;         9 if drive off-line.
;         16 if write protected error.

; Accept first three bytes and interpret error flags.
          CALL  GET_RSLT_BT         ;  ST0 byte.
          LD    E, 6
          
          BIT   3, A                ;  Not ready bit.
          LD    B, A
          LD    A, 9
          JR    NZ, $1
          
          LD    A, 0D0H             ;  Interrupt code, Equip Chk.
          AND   B
          LD    D,A
          
          CALL  GET_RSLT_BT         ; ST1 byte.
          DEC   E
          
          LD    B,A
          LD    A, (R_W_MSK)         ;  Write protected.
          AND   B
          LD    A, 16
          JR    NZ, $1

          LD    A, 84H              ;  End cyl, No data.
          AND   B
          LD    A, 3
          JR    NZ, $1

          LD    A, 61H              ;  Data Error, Overrun, MAM.
          AND   B
          OR    D
          LD    D,A
          
          CALL  GET_RSLT_BT         ;  ST2 byte.
          DEC   E
          
          LD    B, A
          LD    A, 12H              ;  Bad cylinder error.
          AND   B
          LD    A, 2
          JR    NZ, $1
          
          LD    A, B
          OR    D
          LD    A, 0
          JR    Z, $1
          INC   A

$1:
; Read and discard remaining result bytes.
          LD    B, E
          LD    E, A
$2:
          CALL  GET_RSLT_BT
          DJNZ  $2
          LD    A, E
          RET


GET_RSLT_BT:
; Wait until FDC is ready to send, and then accept input byte
; in (A).

          IN    A, (FDC_STAT)
          AND   0C0H
          CP    0C0H
          JR    NZ, GET_RSLT_BT

; Accept character.
          IN    A, (FDC_DATA)
          RET


DSKDKR:
;  Read the designated sector from the disk.

;  Actual read is done below.  Set up read command and read
;  error mask and DMA length.

;  Do not report Write Protected errors in read operation.
          LD    A, 00H
          LD    (R_W_MSK), A
          
          LD    HL, 41FFH
          LD    (FDC_DMA_LEN), HL

;  Store command for reference in common segment.
          LD    HL, FDC_XFR_CMD
          LD    (HL), 46H           ; Read command.
          JR    FDC_DSK_R_W


DSKDKW:
; Write the disignated sector from the disk.

; Set up write command, DMA length and error mask.

; Report all write errors.
          LD    A, 02H
          LD    (R_W_MSK), A
          
          LD    HL, 81FFH
          LD    (FDC_DMA_LEN), HL

; Store write command for reference in common segment.
          LD    HL, FDC_XFR_CMD
          LD    (HL), 45H           ; Write command.


FDC_DSK_R_W:
; Common part of DSKDKW and DSKDKR.

; Filter out Semi-Disk units.
          CALL  VRFY_DRIV
          RET   NC

; Initialize retry count.
          LD    E, DSK_RETRY

$1:
; Seek the designated track.
          CALL  FDC_SEK
          JR    Z, $4
          CP    9
          RET   Z

$2:
; Designated track could not be found.  If retry count is not
; exhausted, recalibrate and retry.
          LD    A, E
          SUB   3
          LD    E, A
          LD    A, 1
          RET   C
          CALL  FDC_RECAL
          JR    $1

$4:
; Seek has been completed successfully.  Code and enable DMA.
          LD    C, DMA_ADR
          LD    HL, (FDC_DMADR)
          OUT   (C), L
          OUT   (C), H
          INC   C                   ; DMA_TMCNT
          LD    HL, (FDC_DMA_LEN)
          OUT   (C), L
          OUT   (C), H
          LD    A, 41H
          OUT   (DMA_CTL), A

; Send command.  Get code from temporary storage.
          LD    A, (FDC_XFR_CMD)
          LD    HL, FDC_CMD_TBL
          LD    (HL), A
          LD    B, 9
          CALL  SEND_CMD

; Set status.  Exit if successful completion.
          CALL  POLL_INT
          PUSH  DE
          CALL  INT_R_W_ST
          POP   DE
          AND   A
          RET   Z

; Error.  Count down retries.
          CP    2
          JR    Z, $2
          DEC   E
          JR    NZ, $2

; Retries exhausted.  Report last error.
          RET
          

========================================================================================
DOCUMENT :usus Folder:VOL20:bios.phone.text
========================================================================================


PHNSTT:
PHCOUT:
PHCIN:
; The phone is currently not implemented.
; Return off-line status.
        LD      A, 9
        RET


========================================================================================
DOCUMENT :usus Folder:VOL20:bios.serpt.text
========================================================================================


INIT:
; This service initializes the entire system on cold start.

; On Entry:
;    (BC) => PASCAL support service jump vector.

          
; Set up jump vectors to callable Pascal services.
          LD    (PASPOL), BC
          INC   BC
          INC   BC
          INC   BC
          
; This storage is the address of a JP instruction in the disk BIOS.
          LD    (PASDCH), BC
          INC   BC
          INC   BC
          INC   BC
          LD    (PASEVENT), BC

; Clear the screen.
          LD    C, 27
          CALL  DR_CRO
          LD    C, "*"
          CALL  DR_CRO
          
; Restore all disks.
          CALL  CLR_DISK
          RET


DR_CRB:
; This service is a dummy to report successful initialization of the
; terminal.
          XOR   A
          RET

DR_CRS:
; This service tests for the presence of an input character from the
; terminal.
          
; On Exit:
;    (A) = 0 to indicate console is on-line.
;    (C) = 0 if no character, else 0FFH.

          LD    C, 0
          IN    A, (CRT_STAT)
          AND   02H
          RET   Z
          DEC   C
          XOR   A
          RET

DR_CRI:
; This service reads the next available character from the keyboard.
; It is extremely simple since the terminal and CPU are so closely
; interconnected in the Escort that failure in this link is highly
; improbable, and it would not be useful to do anything about it anyway.

; On Exit:
;    (A) = 0 to indicate console is on-line.
;    (C) = Character.

          
; Wait for the next character to be ready.
          IN    A, (CRT_STAT)
          AND   02H
          JR    Z, DR_CRI
          
; Pick up the character.
          IN    A, (CRT_DATA)
          LD    C, A
          XOR   A
          RET


DR_CRO:
; This service sends a character to the terminal.

; On Entry:
;    (C) = Character to send.

; On Exit:
;    (A) = 0 to indicate successful transmission.

; Attempt to send the character.
          IN    A, (CRT_STAT)
          AND   01H
          JR    Z, DR_CRO
          LD    A, C
          OUT   (CRT_DATA), A
          
          XOR   A
          RET
          

DR_DIB:
; This service reports the status of the printer.  It does not do any
; initialization of the printer because of the variation in printer
; characteristics which may be encountered with a portable computer system.

; On Exit:
;    (A) = IO Result--
;         0:    Printer initialized successfully.
;         1:    Error in operation.
;         9:    Printer off line.

; Test status for off-line.
          LD    A, PRTDIA
          CALL  PRT_WS
          CP    9
          RET   Z

          XOR   A
          RET


DR_DIS:
; This service is a dummy status routine for the Diablo printer to conform
; to PASCAL  requirements.

; On Entry:
;    (C) = I/O Direction Flag--
;         =0:   Output status desired.
;         >0:   Input status desired.

; On Exit:
;    (A) = Status--
;         0:    Printer is on-line.
;         9:    Diablo is off line.
;    (C) = Channel status (0--no character).
;         0:    Input direction or printer not busy.
;         0FFH: Output direction and printer busy.

          
;  Move direction flag out of the way and collect write status (read status
;  is not relevant, since flow control is via hardware).
          LD    E, C
          LD    A, PRTDIA
          CALL  PRT_WS
          
          
;  Set up input direction return of no character waiting.
          LD    C, 0
          CP    9
          RET   Z
          
;  Printer is not off-line.  Investigate direction flag to interpret
;  status IO Result.
          PUSH  AF
          LD    A, E
          AND   A
          JR    Z, $1
          
;  Input direction--report only good IO Result with no character
;  waiting flag.
          POP   AF
          XOR   A
          RET

$1:
;  Output direction--interpret busy status.
          POP   AF
          CP    16
          
;  Return if not busy.
          RET   NZ
          DEC   C
          RET
          

DR_DII:
; This service is a dummy to provide illegal operation from the Diablo
; to conform to PASCAL requirements.

; On Exit:
;    (A) = Status--
;               3:   Illegal operation.
;    (C) = Character (ANUL)

          LD    A, 3
          LD    C, 0
          RET

DR_DIO:
; Output driver for Diablo printer, operation at 9600 Baud.  Uses RTS 
; protocol to avoid buffer overrun.  Assumes that pins 9 and 20 of inter-
; face cable to Diablo 630 printer have been exchanged.

; On Entry:
;    (C) = character to send

; On Exit:
;    (A) = Status--
;         0:    Successful transmission.
;         1:    Transmission error.
;         9:    Printer off-line.
; All other registers spoiled.

; Mask out high order bit to avoid parity errors.
          LD    A, C
          AND   7FH
          LD    E, A

$1:
; Attempt transmission of character until buffer is available, or until 
; error occurs.
          LD    A, PRTDIA
          CALL  PRT_WT
          CP    16
          RET   NZ
          JR    $1


PRT_IN:
; This service initializes the designated serial port to the characteris-
; tics indicated in its parameters.

; On Entry:
;    (A) = Base Port for device.
;    (E) = Line Control Register for device.

; On Exit:
;    (A - C) spoiled.

; Note:  This service does not return any status as required by UCSD Pascal
; or CP/M.  It prepares the serial port so that subsequent status and output
; calls will function as intended.

; Be certain that UART is in command mode, with RTS and DTR off.
          LD    C, A
          INC   C                  ;  Device status port.
          LD    A, 90H
          OUT   (C), A

; Force Mode Instruction mode in UART.
          LD    A, 40H
          OUT   (C), A
          
; Establish line characteristics.
          OUT   (C), E

; Turn on port.
          LD    A, 37H
          OUT   (C), A
          RET


PRT_RD:
; This service reads waits for a character to appear at the designated 
; serial port and reads it when it shows up.  It tests for transmission 
; and timing errors and diagnoses their occurrence.

; On Input:
;    (A) = Serial Port address.

; On Output:
;    (A) = IO Result--
;         0:    Character is good.
;         1:    Character is in error.  Value is replaced with ANUL.
;         9:    Device is off-line.
;    (C) = Character code.
; All other registers spoiled.

; Save port address.
          LD    D, A

$1:
; Wait for character to be available or error to occur.
          LD    A, D
          CALL  PRT_RS

; If character is present, read it.
          INC   C
          JR    NZ, $2
          LD    C, D
          IN    C, (C)
          RET

$2:
; Character not available.  If no error, continue waiting; otherwise, return
; dummy character.
          AND   A
          RET   NZ
          JR    $1


PRT_RS:
; This service determines the status of the designated serial port for a
; read operation.

; On Entry:
;    (A) = Serial Port address.

; On Exit:
;    (A) = IO Result--
;         0:    No error detected by port.
;         1:    Overrun, framing or parity error.
;         9:    Device off-line.
;    (C) = Ready Result--
;         0:    No character waiting.
;        FF:    Character waiting.

; Determine on-line status from modem status.
          LD    C, A
          INC   C                  ;  Device status port.
          IN    B, (C)
          BIT   PRT_DSR, B
          LD    A, 9
          JR    Z, $1

; Read line status.  Begin by checking error status.
          LD    A, 38H
          AND   B
          LD    A, 1
          JR    NZ, $0

; Terminal is on-line status and there are no errors.
          XOR   A

$0:
; Determine if there is a character waiting.                          
          LD    C, 0FFH
          BIT   PRT_RRDY, B
          RET   NZ

$1:
; Off-line or no character present.
          LD    C, 0
          RET


PRT_WT:
; This service writes a character to the designated serial port.
          
; On Entry:
;    (A) = Serial Port address.
;    (E) = Character.

; On Exit:
;    (A) = IO Result--
;         0:    Transmission of character completed successfully.
;         9:    Device is off-line.
;        16:    Device is not ready to receive data.

; Save the port address for later use.
          LD    D, A

$1:
; Test the write status to determine if transmit buffer is ready.
          LD    A, D
          CALL  PRT_WS
          CP    1
          JR    Z, $1

; Return immediately if device is off-line or unready to receive data.
          RET   NC

; Send character to device.
          LD    C, D
          OUT   (C), E
          RET



PRT_WS:
; This service tests the status of the serial port for writing.

; On Entry:
;    (A) = Serial Port address.

; On Exit:
;    (A) = IO Result--
;         0:    Transmit buffer empty, write possible.
;         1:    Transmit buffer busy, no errors.
;         9:    Device is off-line.
;        16:    Device is not ready to receive data.
;    (BC) spoiled.

; First determine if modem is on-line.
          LD    C, A
          INC   C                  ; Device status register.
          IN    B, (C)
          BIT   PRT_DSR, B
          LD    A, 9
          RET   Z

; On-line. Test for ready to send.
          BIT   PRT_RTSB, B
          LD    A, 16
          RET   Z

; Read line status for transmit buffer condition.
          XOR   A
          BIT   PRT_THBE, B
          RET   NZ

; Buffer is busy.
          INC   A
          RET


CONINI:
; Since Pascal could not be bootstrapped without the console being opera-
; tional, this service is null.

; On Exit:
;    (A) = 0 to imply successful initialization.

          XOR   A
          RET


OFFLIN:
; This service provides off-line status indications for all drivers which
; are not implemented.
          LD    A, 9

NULL:
; This service provides immediate return for null drivers.

          RET


========================================================================================
DOCUMENT :usus Folder:VOL20:boot.write.text
========================================================================================

          .NARROW_PAGE
          .TITLE    "Balke Associates Bootstrap Installer"

;  Programmer:  Karl Balke
;  Version:     001                 16 Jan 82

          .INCLUDE  bios.const

          .PROC     BOOT_WRIT, 2
;  This service writes a bootstrap track, whose contents are
;  supplied in an argument array, to the diskette in Unit 5.

;  It is declared in the calling Pascal program as:

; PROCEDURE boot_writ
;
;  (VAR
;     rslt:                  INTEGER;
;                                 {Result of the format process.  Values
;                                 correspond to IO_RESULT.}
;
;   VAR
;     boot_ary);
;                                 {Bootstrap to be installed on new disk.}
;
;   EXTERNAL;


;  Recalibrate drive B.
          CALL  FDC_RECAL

;  Position SBIOS address for DMA programming.
          POP   HL
          EX    (SP), HL

;  Interpret result of recalibration.
          JR    NZ, $1

;  Write bootstrap to track 0.
          CALL  SEND_W_LST
          CALL  SEND_BUT

$1:
;  Return result of write to calling program.
          POP   DE
          POP   HL
          LD    (HL), A
          INC   HL
          LD    (HL), 0
          EX    DE, HL
          JP    (HL)


SEND_W_LST:
; This service prepares the DMA controller to send a bootstrap parameter
; list to the FDC as needed during SBIOS updating.

; On Entry:
;         (HL) => SBIOS Control list.

          LD    C, DMA_ADR
          OUT   (C), L
          OUT   (C), H
          INC   C                   ; DMA_TMCNT
          LD    HL, 91FFH
          OUT   (C), L
          OUT   (C), H
          LD    A, 41H
          OUT   (DMA_CTL), A
          RET


SEND_BUT:
; This service sends the format command list to the FDC and interprets
; its response.
          LD    HL, FDC_BUT_TBL
          LD    B, 9
          CALL  SEND_CMD
          CALL  POLL_INT
          CALL  INT_R_W_ST
          RET


SEND_CMD:
; Write a command to the disk.

; On Entry:
;         (B) = Command Table Length.
;         (HL) => Command Table.

; On Exit:
;         (B), (C), (HL) spoiled.

          LD    C, FDC_DATA

$1:
; Wait for FDC to be ready.
          IN    A, (FDC_STAT)
          AND   0C0H
          CP    080H
          JR    NZ, $1

; Send next character.
          OUTI
          RET   Z
          JR    $1


FDC_RECAL:
; This service restores the active drive to track 0.

; On Exit:
;         (A) = 0  |  if recalibration successful.
;         (ZF) set |

;         (A) = IO_RESULT if recalibration unsuccessful, or
;               drive off line.

          LD    HL, FDC_RCL_TBL
          LD    B, 2
          CALL  SEND_CMD

; Wait for recalibration to complete.
          CALL  POLL_INT

; Sense status and interpret.
          CALL  SNS_INT_ST
          AND   A
          RET


POLL_INT:
; Detect FDC interrupt signal.  This signals the begining of the
; result phase for many FDC functions.

          IN    A, (FDC_INT)
          RLA
          RET   C

          JR    POLL_INT


SNS_INT_ST:
; Checks the status of the FDC after completion os a seek or
; recalibrate.

; On Exit:
;   (A) = 0 if no error.
;         1 if seek abnormally completed.
;         9 if drive off-line.

; Send prompt command.
          LD    HL, SIS_CMD_TB      ; Sense Interrupt command table.
          LD    B, 1
          CALL  SEND_CMD

; Accept the two result bytes.  Only the first is important.
          CALL  GET_RSLT_BT
          LD    B, A
          CALL  GET_RSLT_BT

; Decode error flags.
          BIT   3, B
          LD    A,9
          RET   NZ

          LD    A, 0D0H
          AND   B
          RET   Z
          LD    A, 1
          RET


INT_R_W_ST:
; Interpret the seven byte status returned by the FDC after a
; read or write command.  Only the first three bytes are im-
; portant, but all bytes must be read.  Give immediate pre-
; ference to non-CRC errors.

; On Exit:
;   (A) = 0 if no error.
;         1 if CRC error.
;         2 if seek error.
;         3 if illegal IO request.
;         9 if drive off-line.
;         16 if write protected error.

; Accept first three bytes and interpret error flags.
          CALL  GET_RSLT_BT         ;  ST0 byte.
          LD    E, 6

          BIT   3, A                ;  Not ready bit.
          LD    B, A
          LD    A, 9
          JR    NZ, $1

          LD    A, 0D0H             ;  Interrupt code, Equip Chk.
          AND   B
          LD    D,A

          CALL  GET_RSLT_BT         ; ST1 byte.
          DEC   E

          LD    B,A
          LD    A, 02H               ;  Write protected.
          AND   B
          LD    A, 16
          JR    NZ, $1

          LD    A, 84H              ;  End cyl, No data.
          AND   B
          LD    A, 3
          JR    NZ, $1

          LD    A, 61H              ;  Data Error, Overrun, MAM.
          AND   B
          OR    D
          LD    D,A

          CALL  GET_RSLT_BT         ;  ST2 byte.
          DEC   E

          LD    B, A
          LD    A, 12H              ;  Bad cylinder error.
          AND   B
          LD    A, 2
          JR    NZ, $1

          LD    A, B
          OR    D
          LD    A, 0
          JR    Z, $1
          INC   A

$1:
; Read and discard remaining result bytes.
          LD    B, E
          LD    E, A
$2:
          CALL  GET_RSLT_BT
          DJNZ  $2
          LD    A, E
          RET


GET_RSLT_BT:
; Wait until FDC is ready to send, and then accept input byte
; in (A).

          IN    A, (FDC_STAT)
          AND   0C0H
          CP    0C0H
          JR    NZ, GET_RSLT_BT

; Accept character.
          IN    A, (FDC_DATA)
          RET



;  This section defines the working storage data blocks used by the 
;  Bootmaker for its own purposes.

;  Disk Command Tables
;  ---- ------- ------

SIS_CMD_TB:
;  Table to define Sense Interrupt Status command.
          .BYTE     08H

FDC_RCL_TBL:
;  Table of recalibration control parameters needed by FDC.

          .BYTE 07H                ;  Recalibrate command.

          .BYTE 1                  ;  Disk number.

FDC_BUT_TBL:
;  Table of SBIOS writing control parameters needed by FDC.

          .BYTE 45H                ;  Write command.

          .BYTE 1                  ;  Disk number.

          .BYTE 0                  ;  Track number of track to which disk
                                   ;  is currently positioned by recalibrate.

          .BYTE 0                  ;  Head number.

          .BYTE 1                  ;  Initial sector number.

          .BYTE 2                  ;  Sector size = 2 for 512.

          .BYTE 9                  ;  Sectors / track.

          .BYTE 27                 ;  Gap-3 read/write length.  Format
                                   ;  length is 84 bytes for Sony disks.

          .BYTE 0FFH               ;  Data length (superseded
                                   ;  by sector size.


          .END


**********
George:  This looked OK as it was echoed to me.  Please let me know if
there are any problems with it.

Karl

Action?   purge

  Purged.

Action?   

========================================================================================
DOCUMENT :usus Folder:VOL20:bootmaker.text
========================================================================================

{Version 001                 16 Jan 82      KGB
    Original issue.}
    
{$I-}
PROGRAM bootmaker;

{**********************************************************************
*    (C) 1982 K. G. Balke, Associates.                                *
*    All rights reserved.                                             *
**********************************************************************}

{$C (C) 1982 K. G. Balke, Associates}

                                  {This program installs a complete
                                  bootstrap and SBIOS on a Sony micro-
                                  floppy disk.}
  
  CONST
    bios_len = 4;
    bios_pos = 2560;
    sboot_len = 4;
    boot_pos = 0;
    sboot_nam = 'load.sboot';
    sboot_pos = 512;
    
  VAR
    blks:                    INTEGER;
                                  {Number of blocks read from bootstrap
                                  file in most recent block read.}
                                  
    boot_ary:                PACKED ARRAY [0 .. 4607] OF CHAR;
                                  {Transfer block for accumulating new
                                  bootstrap and bios components.  Order is:
                                       Primary bootstrap       1
                                       Secondary bootstrap     4
                                       SBIOS                   4}
                                       
    boot_file:               FILE;
                                  {File for reading bootstrap and bios
                                  components.}
                                  
    boot_rslt:               INTEGER;
                                  {IO_RESULT equivalent returned by the
                                  formatting service of the SBIOS.}
    
    f_rslt_str:              STRING;
                                  {String for accumulating formatting error
                                  diagnostic message.}
                                  
    in_ary:                  PACKED ARRAY [0 .. 1] OF CHAR;
    
  
  PROCEDURE boot_writ
                                  {Format a diskette with interleave 2,
                                  skew 4.}
                                  
   (VAR
      rslt:                  INTEGER;
                                  {Result of the format process.  Values
                                  correspond to IO_RESULT.}
    
    VAR
      boot_ary);
                                  {Bootstrap to be installed on new disk.}
    
    EXTERNAL;
    
  
  PROCEDURE diag_file
                                  {Diagnose result of block read and abort
                                  program if error.}
                                  
     (r:                     INTEGER;
                                  {Number of blocks actually read.}
                                  
      t:                     INTEGER;
                                  {Target block count.}
                                  
      i:                     INTEGER);
                                  {IO Result of operation.}
    
    BEGIN {diag_file}
      IF (r <> t) OR (i > 0) THEN
        BEGIN
          GO_TO_X_Y (0, 23);
          WRITE ('Bootstrap files could not be read.  Result = ',
            i, '.');
          EXIT (bootmaker)
        END
    END {diag_file};
    
    
  BEGIN {bootmaker}
    WRITE (CHR (27), '*');

    GO_TO_X_Y (56, 0);
    WRITE (CHR (27), 'k');
    GO_TO_X_Y (23, 0);
    WRITE (CHR (27), 'j PASCAL DISK BOOTSTRAP INSTALLER');

    GO_TO_X_Y (55, 1);
    WRITE (CHR (27), 'm');
    GO_TO_X_Y (22, 1);
    WRITE (CHR (27), 'l(C) 1982 K. G. Balke, Associates');
    
    FILL_CHAR (boot_ary, 4608, CHR (0));
    
    RESET (boot_file, 'e.load.boot');
    blks := BLOCK_READ (boot_file, boot_ary [boot_pos], 1);
    diag_file (blks, 1, IO_RESULT);
    CLOSE (boot_file);
    
    RESET (boot_file, sboot_nam);
    blks := BLOCK_READ (boot_file, boot_ary [sboot_pos], sboot_len);
    diag_file (blks, sboot_len, IO_RESULT);
    CLOSE (boot_file);
    
    RESET (boot_file, 'e.load.bios');
    blks := BLOCK_READ (boot_file, boot_ary [bios_pos], bios_len);
    diag_file (blks, bios_len, IO_RESULT);
    CLOSE (boot_file);
    
    GO_TO_X_Y (0, 23);
    WRITE ('Bootstrap Track Constructed.');
    
    UNIT_CLEAR (5);
    
    GO_TO_X_Y (5, 10);
    WRITE ('Place disk to receive new bootstrap in Unit #5.');
    GO_TO_X_Y (5, 11);
    WRITE ('Enter <CR> to install bootstrap, other key to stop.');
    
    REPEAT
      UNIT_READ (2, in_ary, 1,, 12);
      
      IF in_ary [0] = CHR (13) THEN
        BEGIN
          boot_writ (boot_rslt, boot_ary);
          
          GO_TO_X_Y (0, 23);
          IF boot_rslt IN [0, 9] THEN
            BEGIN
              CASE boot_rslt OF
                0:
                  f_rslt_str := 'Bootstrap installed successfully.';
  
                9:
                  f_rslt_str := 'No disk in Unit #5.              '
              END;
              WRITE (f_rslt_str)
            END
  
          ELSE
            WRITE ('Installation result = ', boot_rslt, '.         ')
        END
  
      ELSE
        BEGIN
          GO_TO_X_Y (0, 23);
          WRITE ('Installation terminated.         ')
        END
    UNTIL in_ary [0] <> CHR (13)
  END {bootmaker}.



========================================================================================
DOCUMENT :usus Folder:VOL20:bootr-genr.text
========================================================================================

cbootmaker
t

aboot.write
boot.write

lt
boot.write


bootmaker.code
frt.code
yq

========================================================================================
DOCUMENT :usus Folder:VOL20:e.boot.text
========================================================================================

.TITLE    "K. G. Balke, Associates, Primary Courier Pascal Bootstrap"

; Author:    Karl G. Balke
;            Brian K. E. Balke
; Version:   15 September 1982

.INCLUDE  bios.const

BIOS_BASE .EQU  0F800H             ;  Base of BIOS as loaded from Track
                                   ;  0 of disk.

S_BOOT_PSN   .EQU  8200H           ;  Location of secondary bootstrap.


.PROC     PRIM_BOOT

;  This program will be loaded into locations 2800-28FFH
;  by the bootstrap ROM in the computer.  It will then load the
;  secondary bootstrap and the SBIOS, sete up the initial stack
;  contents for the secondary bootstrap, and initiate Pascal system
;  loading.

;  Set up a stack for calls to GET_DATA.
          LD    SP, 8000H

;  Initialize the Pascal stack with disk parameters per boot source.
;  Note that this bootstrap assumes that it is being loaded from a
;  double-sided, double-density disk in KGBA standard format.
          LD    DE, BIOS_BASE - 5
          LD    BC, 24
          LD    HL, PAS_STK_TP - 1
          LDDR

;  Specify disk characteristics per table.
          LD    HL, FDC_SPC_TB
          LD    C, 3
          CALL  WRT_FDC_CMD

;  Disk is on line.  Restore it to track 0.
          LD    HL, FDCTBL
          LD    (HL), 07H          ;  Recalibrate command.
          LD    C, 2
          CALL  WRT_FDC_CMD
          
          CALL  POLL_INT
          
          CALL  GET_INT_ST
          AND   0D8H
          JR    NZ, $

;  Load the secondary bootstrap from sectors 2-5 into 8200H.
          LD    HL, S_BOOT_PSN
          LD    DE, 47FFH
          CALL  RD_FDC
          AND   A
          JR    NZ, $

;  Load the SBIOS from sectors 6-8 into BIOS_BASE.
          LD    A, 6
          LD    (FDCTBL + 4), A
          LD    HL, BIOS_BASE
          LD    DE, 45FFH
          CALL  RD_FDC
          AND   A
          JR    NZ, $

; Initialize serial port controller timers.
          LD    HL, DIA_SPEED
          LD    A, 36H
          OUT   (CNT_MDM), A
          LD    C, CNT_REG_0
          OUT   (C), L
          OUT   (C), H
          LD    HL, MDM_SPEED
          LD    A, 76H
          OUT   (CNT_MDM), A
          INC   C                  ; CNT_REG_1
          OUT   (C), L
          OUT   (C), H

; Establish the line characteristics for the Diablo printer.
          LD    A, 4EH
          OUT   (PRTDIA + STAT_PRT), A

; Turn on port.
          LD    A, 37H
          OUT   (PRTDIA + STAT_PRT), A

;  Bootstrap properly loaded.  Execute secondary bootstrap.
          LD    SP, BIOS_BASE - 28
          JP    S_BOOT_PSN


DBG_WRT:
          PUSH  AF
$1:
          IN    A, (CRT_STAT)
          AND   01H
          JR    Z, $1
          POP   AF
          OUT   (CRT_DATA), A
          RET

          
RD_FDC:
;  This subroutine programs the DMA according to input values,
;  writes and executes the read command, and analyzes the result.

;  On entry:
;    (DE) = DMA termination count.
;    (HL) = DMA buffer address.

;  Program DMA.
          LD    C, DMA_ADR
          OUT   (C), L
          OUT   (C), H
          INC   C
          OUT   (C), E
          OUT   (C), D
          LD    A, 41H
          OUT   (DMA_CTL), A

;  Execute read and get result.
          LD    HL, FDCTBL
          LD    (HL), 46H          ;  Read command.
          LD    C, 9
          CALL  WRT_FDC_CMD
          CALL  GET_RD_RSLT
          RET

GET_RD_RSLT:
;  Accept result characters from FDC and analyse error flags.

;  On exit:
;    (A) = 0 if no errors, <> 0 otherwise.
          CALL  POLL_INT
          CALL  GET_RSLT_BT
          AND   0D8H
          LD    C, A
          CALL  GET_RSLT_BT
          OR    C
          LD    C, A
          CALL  GET_RSLT_BT
          AND   073H
          OR    C
          LD    C, A

;  Drop rest of result message.
          LD    B, 4
$1:
          CALL  GET_RSLT_BT
          DJNZ  $1
          LD    A, C
          RET

POLL_INT:
;  Wait for FDC to generate interrupt, signaling that command
;  execution is completed.
          IN    A, (FDC_INT)
          RLA
          JR    NC, POLL_INT
          RET


GET_RSLT_BT:
;  Poll FDC for ready to send status, and accept character.

;  On exit:
;    (A) = character.
          IN    A, (FDC_STAT)
          AND   0C0H
          CP    0C0H
          JR    NZ, GET_RSLT_BT
          IN    A, (FDC_DATA)
          RET

GET_INT_ST:
;  Write Sense Interrupt Status enquiry to FDC and accept response.

;  On exit:
;    (A) = response.
          LD    HL, FDCTBL
          LD    (HL), 08H
          LD    C, 1
          CALL  WRT_FDC_CMD
          
;  Get SR0 and save.
          CALL  GET_RSLT_BT
          LD    B, A

;  Discard present cylinder number.
          CALL  GET_RSLT_BT
          LD    A, B
          RET

WRT_FDC_CMD:
;  Output the prepared command to the FDC.

;  Test FDC ready status.
          IN    A, (FDC_STAT)
          RLA
          JR    NC, WRT_FDC_CMD

;  Output next byte of command.
          LD    A, (HL)
          OUT   (FDC_DATA), A
          INC   HL
          DEC   C
          RET   Z
          JR    WRT_FDC_CMD
          
.ALIGN    2

FDCTBL:
;  FDC command table.  Only command and sector are variable in
;  this application.
.BYTE     0     ;  command
.BYTE     0     ;  disk #
.BYTE     0     ;  track #
.BYTE     0     ;  head #
.BYTE     2     ;  sector #
.BYTE     2     ;  sector size = 2 for 512
.BYTE     9     ;  sectors/track
.BYTE     27    ;  gap
.BYTE     0FFH  ;  data length (superseded by sector size)

FDC_SPC_TB:
;  FDC Specify Command Table.  Specifies characteristics of Sony
;  3-1/4" single-sided micro-floppy drives.
.BYTE     003H  ;  Specify instruction.
.BYTE     01FH  ;  Head unload time/Step rate.
.BYTE     03CH  ;  60 ms head load delay.

PAS_STK_BT:
;  Bootstrap control stack.
.WORD     100H                     ;  Interpreter address.
.WORD     BIOS_BASE                ;  SBIOS jump vector location.
.WORD     100H                     ;  Lowest memory.
.WORD     BIOS_BASE - 2            ;  Highest available memory.
.WORD     70                       ;  Tracks/disk.
.WORD     9                        ;  Sectors/track.
.WORD     512                      ;  Bytes/sector.
.WORD     MFD_INTL                 ;  Interleave.
.WORD     1                        ;  First Pascal track.
.WORD     MFD_SKEW                 ;  Track to track skew.
.WORD     9                        ;  Maximum sectors/track.
.WORD     512                      ;  Maximum bytes/sector.

PAS_STK_TP:
.WORD     0

.END


========================================================================================
DOCUMENT :usus Folder:VOL20:e.load.bios
========================================================================================

]2ÉÔ`jot/X66ßéÌÌÌÌ4444Ï  7CCC͔*͔Gɯ ۩
۩(ۨO۩(yӨ>	ȯY> 	{(
> y_>O>y>@yY>7yWz JHɧO@x>	(
>8> H Wz(JYO@x>	@>ȯP<ɯ>	`+!ͼ!$ E	!q####jy!ͼ!$ !  j;t	o ` 	`/ia!#ia>AӸ!ͩ۠ !~(O͔#Unrecoverable disk protocol error.
:>	!6ͩͲ!(>w `X`X#+y2!6y2y2C:F8>G!xw+!6ͩͲ!6ۢ  !GX>	>Р>_G>	 0>РWG:> >> >aWG>> x> (<C_{۠ ۡ> 2!A"!6F>2!"!6E#y(	{_>+*ia*ia>AӸ:!w	ͩѧ( >	>   !       	M	TN          	                        	                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                    $CURSOR $EQUAL                                                                                                                                                                                                                                                                                            
                                                                                 O  . cc                                                                                                 
========================================================================================
DOCUMENT :usus Folder:VOL20:e.load.boot
========================================================================================

1  !	)!((!(6(ʹ(( ! Gy( >2(! Ey( !
 >6Ӌia!
 >vӋia>NӇ>7Ӈ1 ۩(ӨiaYQ>AӸ!(6F	(͖(ʹ(ͺ(Oͺ(Oͺ(sOͺ(yۢ0۠ ۡ!(6(ͺ(Gͺ(x۠0~ӡ#
     	<   F 	      	                                                                                                                                                                                                                                                        ]2ÉÔ`jot/X66ßéÌÌÌÌ4444Ï  7CCC͔*͔Gɯ ۩
۩(ۨO۩(yӨ>	ȯY> 	{(
> y_>O>y>@yY>7yWz JHɧO@x>	(
>8> H Wz(JYO@x>	@>ȯP<ɯ>	`+!ͼ!$ E	!q####jy!ͼ!$ !  j;t	o ` 	`/ia!#ia>AӸ!ͩ۠ !~(O͔#Un
========================================================================================
DOCUMENT :usus Folder:VOL20:ebios-genr.text
========================================================================================

aebios
ebios

lebios



x*compress
nF800
*system.wrk
e.load.bios
fnyn
q

========================================================================================
DOCUMENT :usus Folder:VOL20:ebios.text
========================================================================================

.TITLE    "K. G. Balke, Associates, Z80 Pascal SBIOS"

; Author:   Karl G. Balke
; Version:  6 July 1982


.INCLUDE  bios.const


.PROC     COUR_BIOS

CRJMP00:
; This vector connects the UCSD PASCAL interpreter to the SBIOS routines.

; #00 SYSINIT Entry.
          JP    INIT

; #03 SYSHALT Entry.
          JP    $

; #06 CONINIT Entry.
          JP    CONINI

; #09 CONSTAT Entry.
          JP    DR_CRS

; #12 CONREAD Entry.
          JP    DR_CRI

; #15 CONWRIT Entry.
          JP    DR_CRO

; #18 SETDISK Entry.
          JP    DSKDKN

; #21 SETTRAK Entry.
          JP    DSKDKT

; #24 SETSECT Entry.
          JP    DSKDKS

; #27 SETBUFR Entry.
          JP    DSKDKB

; #30 DSKREAD Entry.
          JP    DSKDKR

; #33 DSKWRIT Entry.
          JP    DSKDKW

; #36 DSKINIT Entry.
          JP    DSKDKI

; #39 DSKSTRT Entry.
          JP    NULL

; #42 DSKSTOP Entry.
          JP    NULL
          
; #45 PRNINIT Entry.
          JP    DR_DIB
          
; #48 PRNSTAT Entry.
          JP    DR_DIS
          
; #51 PRNREAD Entry.
          JP    DR_DII

; #54 PRNWRIT Entry.
          JP    DR_DIO
          
; #57 REMINIT Entry.
          JP    PHN_STT
          
; #60 REMSTAT Entry.
          JP    PHN_STT
          
; #63 REMREAD Entry.
          JP    PH_CIN
          
; #66 REMWRIT Entry.
          JP    PHCOUT
          
; #69 USRINIT Entry.
          JP    OFFLIN
          
; #72 USRSTAT Entry.
          JP    OFFLIN
          
; #75 USRREAD Entry.
          JP    OFFLIN
          
; #78 USRWRIT Entry.
          JP    OFFLIN
          
; #81 CLKREAD Entry.
          JP    CLK_RD

; #84 QUIET Entry.  (IV.02 and later only)
          DI
          RET
          NOP

; #87 ENABLE Entry.  (IV.02 and later only)
          EI
          RET
          NOP

; #90 FORMAT Entry.  (Courier BIOS only)
          JP    FMT_DISK

.INCLUDE  BIOS.SERPT

.INCLUDE  BIOS.DISKS

.INCLUDE  BIOS.PHONE

CLK_RD:
;  This service provides dummy results for the BIOS clock procedures.
;  Actual clock management is provided by Pascal procedures.


          LD    A, 0
          LD    DE, 0
          LD    HL, 0
          RET


.INCLUDE  BIOS.DATA


; Padding for pascal Blue - courier system transfer routine.
          .WORD 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0
          .WORD 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0
          .WORD 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0
          .WORD 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0
          .WORD 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0
          .WORD 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0
          .WORD 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0
          .WORD 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0


.END


========================================================================================
DOCUMENT :usus Folder:VOL20:eboot-genr.text
========================================================================================

ae.boot
e.boot

le.boot



x*compress
n2800
*system.wrk
e.load.boot
fnyn
q

========================================================================================
DOCUMENT :usus Folder:VOL20:escort.doc.text
========================================================================================


     This disk contains the files necessary to construct and install an
SBIOS for the Jonos Escort portable computer.  This SBIOS is suitable
for use with SofTech MicroSystems UCSD Pascal, Version IV.1 (UCSD
Pascal and p-System are registered trademarks of the Regents of the
University of California).  In addition to the basic SBIOS files, it
contains the text of a program to format the SONY 3.5" single sided
disks which the Escort uses, and one side of a file transfer program
which can be used to exchange Pascal files through one of the serial
ports at up to 9600 bits per second.

     The accompanying program material material is copyrighted.
Permission is hereby granted for the free private use and modification
of the programs on this disk by any members of USUS or their associates
for any non-commercial use only.

     The disk contains text files for the SBIOS, the installation
program (bootmaker), the disk formatting program (formatter), the serial
port transfer program (trans-mgr), and miscellaneous supporting programs
and units which these programs need to operate.  In addition, it
contains assembled versions of the bootstrap and SBIOS code, suitable
for installation on a disk as described below.

     Each program on this disk can be assembled and/or compiled using an
appropriate redirection file.  The names of all redirection files end in
'-genr.text'.

     The suite of programs is sufficient to install the p-System on an
Escort once a working system disk is available for that machine;
however, it does not contain a method for transferring the files from a
p-System to the Escort to begin with.  A simple serial port transfer can
be constructed under CP/M (which comes with the Escort) (CP/M is a
registered trademark of Digital Research) to get the load files
installed on track 0 to begin with.  I suggest that the bootstrap (file
'E.LOAD.BOOT' on this disk) be installed in sector 1, the secondary
bootstrap (which you must extract from your SMS distribution disk) be
installed in sectors 2-5, and the SBIOS itself (file 'E.LOAD.BIOS' on
this disk) be installed in sectors 6-9.

     The code may be well enough documented internally so that it is
clear to an experienced Z80 assembly language programmer with access to
the SofTech Adaptable System "Installation Guide" and the IV.1
supplementary documentation.  I simply do not have time to write a more
thorough explanation of the code, or how to use it.

     Good luck with your installation!


========================================================================================
DOCUMENT :usus Folder:VOL20:fastread.text
========================================================================================

{ FASTREAD - fast text file string read for UCSD pascal. }
{            dhd - PCD Systems, Inc.                     }

{ S+}

{
17 Aug 82 [acd] Fixed bug on consecutive null lines with no blank compression
17 Aug 82 [acd] Intrinsic declarations for Apple iron made conditional
14 Aug 82 [acd] Changed to intrinsic for Apple ][
12 Aug 82 [acd] Fixed error on blank lines with indent count
}

UNIT FastRead ;
  {%IFT Apple }
  (*INTRINSIC CODE 16 ;*)
    {%ENDC }
    
INTERFACE
  CONST
    BufSiz      =  1024 ;
    LineMax     =   255 ;
    
  TYPE
    LineIndex   = 0..LineMax ;
    LongString  = String[LineMax] ;
    FFile       = FILE ;
    Fcb         = RECORD
      InLFN     : STRING[30] ;  { input file name }
      Line      : LongString ;  { current text line }
      BPos      : INTEGER ;     { buffer position }
      EndFile   : BOOLEAN ;     { true when end of file }
      Buf       : PACKED ARRAY [0..BufSiz] OF CHAR ;
      BlkNr     : INTEGER ;
      END ; { Fcb }
    
  PROCEDURE GetString
    ( VAR Phyle : Fcb ;
      VAR InFile: FFile ;
      VAR s     : LongString ) ;
      
  PROCEDURE OpenFile
    ( VAR Phyle : Fcb ;
      VAR InFile: FFile ;
      VAR Lfn   : STRING ) ;
      
IMPLEMENTATION
    
  PROCEDURE OpenFile
    { VAR Phyle : Fcb ;
      VAR InFile: FFile ;
      VAR Lfn   : STRING } ;
      
  BEGIN { OpenFile }
    
    WITH Phyle DO BEGIN
      RESET( InFile, Lfn ) ;
      InLFN   := Lfn ;
      Line    := '' ;
      BPos    := BufSiz + 1 ;
      EndFile := FALSE ;
      BlkNr   := 2 ;
      END ;
      
    END ; { OpenFile }
  
  
  PROCEDURE GetString
    { VAR Phyle : Fcb ;
      VAR InFile: FFile ;
      VAR s     : LongString } ;
      
    CONST
      Cr  = 13 ;
      Dle = 16 ;
      
    VAR 
      BCnt, 
      Chg   : INTEGER ;
      Found : BOOLEAN ;
      
  BEGIN { GetString } 
  
    {$R- disable string range checks }
    
    WITH Phyle DO
      REPEAT
        IF BPos >= BufSiz THEN { time for next buffer } BEGIN
          BCnt  := BLOCKREAD( InFile, Buf[0], 2, BlkNr ) ;
          BPos  := 0 ;
          BlkNr := BlkNr + BCnt ;
          IF BCnt < 2 THEN { eof } BEGIN
            EndFile := TRUE ;
            EXIT( GetString )
            END ; { if }
          END ; { if }
        Chg := SCAN( BufSiz-BPos, =CHR(Cr), Buf[BPos] ) ;
        IF (BPos + Chg) < BufSiz THEN { found a carriage return } BEGIN
          MOVELEFT( Buf[BPos], s[1], Chg ) ;    { copy string except CR }
          s[0]  := CHR( Chg ) ;
          BPos  := SUCC( BPos + Chg ) ;
          Found := TRUE 
          END
        ELSE BEGIN
          Chg := SCAN( BufSiz-BPos, =CHR(0), Buf[BPos] ) ; { look for null }
          IF (BPos + Chg) < BufSiz THEN BEGIN
            MOVELEFT( Buf[BPos], s[1], Chg-1 ) ;
            s[0]  := CHR( Chg ) ;
            BPos  := BufSiz ;
            END ;
          Found := FALSE
          END ;
        UNTIL Found ;
      
    IF LENGTH( s ) >= 2 THEN                          { acd - 12 Aug 82 }
      IF s[1] = CHR(dle) THEN { insert leading blanks } BEGIN
        Chg := ORD( s[2] ) - ORD( ' ' ) ; 
        IF Chg > 2 THEN
          MOVERIGHT( s[3], s[Chg+1], LENGTH(s)-2 )
        ELSE
          MOVELEFT(  s[3], s[Chg+1], LENGTH(s)-2 ) ;
        FILLCHAR( s[1], Chg, ' ' ) ;
        s[0] := CHR( LENGTH(s)+Chg-2 ) ;
        END ;
    
    {$R+}
  
    END ; { GetString }
  
END. { of unit }

========================================================================================
DOCUMENT :usus Folder:VOL20:fmt-genr.text
========================================================================================

cformatter
t

lt
fmt-link


formatter.code
frt.code
yq

========================================================================================
DOCUMENT :usus Folder:VOL20:formatter.text
========================================================================================

PROGRAM formattr;

{**********************************************************************
*    (C) 1982 K. G. Balke, Associates.                                *
*    All rights reserved.                                             *
**********************************************************************}

{$C (C) 1982 K. G. Balke, Associates}

                                  {This program formats a Sony micro-floppy
                                  diskette in [2:7] format for use with the
                                  Courier portable computer.  The
                                  formatting algorithms are included in the
                                  SBIOS.}
  
  VAR
    f_rslt_str:              STRING;
                                  {String for accumulating formatting error
                                  diagnostic message.}
                                  
    fmt_rslt:                INTEGER;
                                  {IO_RESULT equivalent returned by the
                                  formatting service of the SBIOS.}
    
    in_ary:                  PACKED ARRAY [0 .. 1] OF CHAR;
    
  PROCEDURE fmt_lnk
                                  {Format a diskette with interleave 2,
                                  skew 4.}
                                  
   (VAR
      rslt:                  INTEGER);
                                  {Result of the format process.  Values
                                  correspond to IO_RESULT.}
    
    EXTERNAL;
    
  BEGIN {formattr}
    WRITE (CHR (27), '*');

    GO_TO_X_Y (52, 0);
    WRITE (CHR (27), 'k');
    GO_TO_X_Y (26, 0);
    WRITE (CHR (27), 'j PASCAL DISK FORMATTER ');

    GO_TO_X_Y (53, 1);
    WRITE (CHR (27), 'm');
    GO_TO_X_Y (25, 1);
    WRITE (CHR (27), 'l(C) 1983 Balke Associates');
    
    GO_TO_X_Y (5, 10);
    WRITE ('Place disk to be formatted in Unit #5.');
    GO_TO_X_Y (5, 11);
    WRITE ('Enter <CR> to format, other key to stop.');
    
    UNIT_READ (2, in_ary, 1,, 12);
    
    IF in_ary [0] = CHR (13) THEN
      BEGIN
        fmt_lnk (fmt_rslt);
        
        GO_TO_X_Y (5, 13);
        IF fmt_rslt IN [0, 9] THEN
          BEGIN
            CASE fmt_rslt OF
              0:
                f_rslt_str := 'Disk formatted successfully.';
                
              9:
                f_rslt_str := 'No disk in Unit #5.'
            END;
            WRITE (f_rslt_str)
          END
        
        ELSE
          WRITE ('Format result = ', fmt_rslt, '.')
      END
    
    ELSE
      BEGIN
        GO_TO_X_Y (5, 13);
        WRITE ('Format not done.')
      END
  END {formattr}.


========================================================================================
DOCUMENT :usus Folder:VOL20:h19util.text
========================================================================================

{This unit was written for use with the H19 (Z19) terminal. It may be edited
 for use with some other terminals. Procedures or functions requiring editing
 include: CLEARSCREEN, SAVECURSOR, LINE25, GOTO25, NORMALKEYPAD, SHIFTKEYPAD,
 and IN_REAL. For the latter SAVECURSOR is almost essential; however, IN_REAL's
 error messages may be moved from line 24 (the "25th" line) to line 0 by
 making the changes marked with (**instruction **). Real numbers may be input
 from the terminal or a text file using IN_REAL. In either instance, input ofn
 of a number may be terminated by a space, comma, or carriage return. IN_REAL
 will not accept plus (+) signs.  Modification to accept plus signs is possible
 by creating boolean variables POSNO and POSEXP and adding code similar to that
 for handling minus signs.  The back space (erase) routines will have to be
 rewritten to handle no, plus, and minus signs. Another possibly useful
 alternative would be to rewrite IN_REAL as FUNCTION IN_REAL(VAR S : STRING):
 REAL where the string form of the number is saved (in the event it needed
 to be written out elsewhere).---Henry E. Baumgarten}
 
(*$S+*)
UNIT H19UTIL;  (*Version 1.2, 17 Jan 83*)

INTERFACE

TYPE    FILECODE = (INPT,INFIL,OUTFIL);
        VISIBLE = SET OF ' '..'~';
VAR     XCUR,YCUR : INTEGER;

PROCEDURE CLEARSCREEN;
PROCEDURE CLEARSPACE(XCSP,YCSP,N : INTEGER);
PROCEDURE SAVECURSOR(VAR XCUR,YCUR : INTEGER);
PROCEDURE LINE25(ON : BOOLEAN);
PROCEDURE GOTO25;
PROCEDURE NORMALKEYPAD;
PROCEDURE SHIFTKEYPAD;
PROCEDURE CLEAR_EOL;
PROCEDURE CLEAR_EOS;
PROCEDURE GETREPLY (VAR REPLY : CHAR);
FUNCTION DOIT : BOOLEAN;
PROCEDURE PAUSE;
FUNCTION CONTINUE: BOOLEAN;
FUNCTION COMMAND(S : STRING; GOODSET : VISIBLE): CHAR;
FUNCTION GOAHEAD: BOOLEAN;
FUNCTION IN_REAL(VAR F : TEXT; FCODE : FILECODE): REAL;

IMPLEMENTATION

PROCEDURE CLEARSCREEN;
  VAR T : PACKED ARRAY [0..1] OF 0..255;
  BEGIN
    T[0] := 27;
    T[1] := ORD('E');
    UNITWRITE(1,T,2)
  END;

PROCEDURE CLEAR_EOS; {clear to end of screeen (page)}
  VAR T : PACKED ARRAY [0..1] OF 0..255;
  BEGIN
    T[0] := 27;
    T[1] := ORD('J');
    UNITWRITE(1,T,2)
  END;

PROCEDURE CLEAR_EOL;  {clear to end of line}
  VAR T : PACKED ARRAY [0..1] OF 0..255;
  BEGIN
    T[0] := 27;
    T[1] := ORD('K');
    UNITWRITE(1,T,2)
  END;

PROCEDURE CLEARSPACE (*XCSP,YCSP,N : INTEGER*);
  VAR I : INTEGER;
      CS :PACKED ARRAY [1..160] OF CHAR;
  BEGIN
    GOTOXY(XCSP,YCSP);
    FILLCHAR(CS,N,' ');
    FILLCHAR(CS[N+1],N,CHR(8));
    UNITWRITE(1,CS[1],2*N);
  END;
  
PROCEDURE SAVECURSOR (*VAR XCUR,YCUR : INTEGER*);
  VAR T : PACKED ARRAY [0..7] OF 0..255;
  BEGIN
    T[0] := 27;
    T[1] := ORD('j');
    T[2] := 27;
    T[3] := ORD('n');
    UNITWRITE(1,T,4);
    UNITREAD(2,T[4],4);
    XCUR := T[7] - 32;
    YCUR := T[6] - 32
  END;
  
PROCEDURE LINE25(*ON : BOOLEAN*);
  VAR T : PACKED ARRAY [0..2] OF 0..255;
  BEGIN
    T[0] := 27;
    IF ON THEN T[1] := ORD('x') ELSE T[1] := ORD('y');
    T[2] := ORD('1');
    UNITWRITE(2,T,3)
  END;
  
PROCEDURE GOTO25;
  VAR T : PACKED ARRAY [0..3] OF 0..255;
  BEGIN
    T[0] := 27;
    T[1] := ORD('Y');
    T[2] := 56;  {Y=24+32}
    T[3] := 32;  {X=0+32}
    UNITWRITE(2,T,4)
  END;
    
PROCEDURE NORMALKEYPAD;
  VAR T : PACKED ARRAY[0..1] OF 0..255;
  BEGIN
    T[0] := 27;
    T[1] := ORD('u');
    UNITWRITE(1,T,2)
  END;
  
PROCEDURE SHIFTKEYPAD;
  VAR T : PACKED ARRAY[0..1] OF 0..255;
  BEGIN
    T[0] := 27;
    T[1] := ORD('t');
    UNITWRITE(1,T,2)
  END;
  
PROCEDURE GETREPLY (*VAR REPLY : CHAR*);
  VAR   SURROGATE : PACKED ARRAY[0..0] OF CHAR;
  BEGIN
    UNITREAD(2,SURROGATE[0],1);
    REPLY := SURROGATE[0];
    IF REPLY IN ['a'..'z'] THEN REPLY := CHR(ORD(REPLY) - 32);
  END;
  
FUNCTION DOIT(* : BOOLEAN*);
  VAR   REPLY : CHAR;
  BEGIN
    REPEAT
      GETREPLY(REPLY)
    UNTIL REPLY IN ['Y','N'];
    IF REPLY = 'Y' THEN DOIT := TRUE
    ELSE DOIT := FALSE
  END;
  
PROCEDURE PAUSE;
  VAR   REPLY : CHAR;
  BEGIN
    REPEAT
      GETREPLY(REPLY)
    UNTIL REPLY = ' '
  END;
  
FUNCTION CONTINUE(* : BOOLEAN*);
   VAR  REPLY : CHAR;
  BEGIN
    REPEAT
      GETREPLY(REPLY)
    UNTIL REPLY IN [' ','Q'];
    IF REPLY = ' ' THEN CONTINUE := TRUE
    ELSE CONTINUE := FALSE
  END;
  
FUNCTION COMMAND(*S : STRING; GOODSET : VISIBLE): CHAR*);
  VAR   REPLY : CHAR;
  BEGIN
    WRITELN(S);
    REPEAT GETREPLY(REPLY) UNTIL REPLY IN GOODSET;
    COMMAND := REPLY
  END;
  
FUNCTION GOAHEAD(* : BOOLEAN*);
  VAR   REPLY : CHAR;
  BEGIN
    WRITELN('Check entries for errors.  <SP> accepts, <TAB> rejects, <ESC> quits');
    REPEAT GETREPLY(REPLY) UNTIL ((REPLY = ' ') OR (REPLY = CHR(9)) OR
      (REPLY = CHR(27)));
    IF (REPLY = CHR(27)) THEN
      BEGIN
        CLEARSCREEN;
        EXIT(PROGRAM)
      END;
    IF (REPLY = ' ') THEN GOAHEAD := TRUE ELSE GOAHEAD := FALSE;
    CLEARSCREEN
  END;
  
FUNCTION IN_REAL(*VAR F : TEXT; FCODE : FILECODE): REAL*);
  TYPE  NUMBERS = PACKED ARRAY[1..38] OF 0..255;
  VAR   I,J,K : INTEGER;
        INTG,IFRACTN,FRACTION,EXPONENT,SUM,TESTNO : REAL;
        INT,FRAC,EX : NUMBERS;
        NEGNO,NEGEXP,DEC,EXPNT,FRACDONE : BOOLEAN;
        BS,CR,CH : CHAR;
  
  PROCEDURE ERRORHNDLR(KEY : INTEGER);
    VAR S : STRING;
    BEGIN
      SAVECURSOR(XCUR,YCUR);
      {CLEARSPACE(0,0,80);       (**replaces next 2 lines**)}
      LINE25(TRUE);
      GOTO25;
      CASE KEY OF
        1 : S := 'Number too large.';
        2 : S := 'Too many decimal points.';
        3 : S := 'Misplaced minus sign.';
        4 : S := 'Non-numerical character present.';
        5 : S := 'Misplaced "E"';
        6 : S := 'Exponent too large';
        7 : S := 'Mantissa = 0';
        8 : S := 'Plus sign not acceptable';
      END;
      WRITE(S,' Type <SP> to continue or Q(uit.');
      IF NOT CONTINUE THEN
        BEGIN
          CLEARSCREEN;  (**delete 3 lines**)
          GOTOXY(0,0);
          LINE25(FALSE);
          CLEARSCREEN;
          EXIT(PROGRAM)
        END;
      {CLEARSPACE(0,0,80)}    (**replaces next line**)
      CLEARSCREEN;
      GOTOXY(XCUR,YCUR);
      LINE25(FALSE);          (**delete 1 line**)
      IF (FCODE = INPT) THEN WRITE(BS,' ',BS)
    END;
    
  PROCEDURE GET_INTEGER;
    BEGIN
      IF (CH IN ['0'..'9']) THEN
        BEGIN
          IF (INTG <= ((1.0E37 - ORD(CH) + ORD('0'))/10)) THEN
            BEGIN
              IF (I<0) THEN I := 0;
              I := I+1;
              INT[I] := ORD(CH)-ORD('0');
              INTG := INTG*10 + ORD(CH) - ORD('0');
            END
          ELSE ERRORHNDLR(1)
        END
      ELSE IF (CH = '.') THEN
        BEGIN
          DEC := TRUE;
          I := I+1;
          J := J+1;
          CH := '0';
        END
      ELSE IF (CH = '-') THEN
        BEGIN
          CH := '0';
          IF (I < 0) THEN
            BEGIN
              NEGNO := TRUE;
              I := I+1;
            END
          ELSE ERRORHNDLR(3)
        END
      ELSE IF (CH = '+') THEN ERRORHNDLR(8)
      ELSE IF (CH = 'E') THEN
        BEGIN
          CH := '0';
          SUM := INTG;
          IF NOT(SUM = 0) THEN
            BEGIN
              EXPNT := TRUE;
              I := I+1;
              TESTNO := ROUND(LOG(SUM))
            END
          ELSE ERRORHNDLR(7);
        END
      ELSE IF (CH = BS) THEN
        BEGIN
          IF (FCODE = INPT) THEN
            BEGIN
              IF (I<0) THEN WRITE(' ') ELSE WRITE(' ',BS)
            END;
          CH := '0';
          IF (INTG>0) THEN INTG := (INTG - INT[I])/10
            ELSE IF (I=0) THEN NEGNO := FALSE;
          IF (I>=0) THEN I := I-1;
          IF (I=0) AND (NOT NEGNO) THEN I := -1;
        END;
      IF NOT (CH IN [' ','0'..'9']) THEN ERRORHNDLR(4);
    END;
    
  PROCEDURE GET_FRACTION;
    BEGIN
      IF (CH IN ['0'..'9']) THEN
        BEGIN
          IF (J>=37) THEN
            BEGIN
              IF NOT FRACDONE THEN
                BEGIN
                  IF ((ORD(CH)-ORD('0'))>=5) THEN
                    BEGIN
                      IFRACTN := IFRACTN+1.0;
                      FRACDONE := TRUE
                    END;
                  FRAC[38] := ORD(CH)-ORD('0');
                END;
              J := J+1;
              I := I+1
            END
          ELSE BEGIN
              I := I+1;
              J := J+1;
              FRAC[J] := ORD(CH)-ORD('0');
              IFRACTN := IFRACTN*10 + FRAC[J];
            END
        END
      ELSE IF (CH = '.') THEN ERRORHNDLR(2)
      ELSE IF (CH = '-') THEN ERRORHNDLR(3)
      ELSE IF (CH = 'E') THEN
        BEGIN
          EXPNT := TRUE;
          CH := '0';
          I := I+1;
          IF (J>=37) THEN SUM := INTG + IFRACTN/PWROFTEN(37)
            ELSE SUM := INTG +  IFRACTN/PWROFTEN(J);
          IF NOT(SUM=0) THEN TESTNO := ROUND(LOG(SUM)) ELSE ERRORHNDRLR(7)
        END
      ELSE IF (CH = BS) THEN
        BEGIN
          IF (FCODE = INPT) THEN
            BEGIN
              IF (I<0) THEN WRITE(' ') ELSE WRITE(' ',BS)
            END;
          CH := '0';
          IF (J=0) THEN DEC := FALSE
          ELSE IF (J>=38) THEN
            BEGIN
              IF FRACDONE THEN
                BEGIN
                  IFRACTN := IFRACTN-1.0;
                  FRACDONE := FALSE
                END
            END
          ELSE IF (IFRACTN>0) THEN IFRACTN := (IFRACTN - FRAC[J])/10;
          J := J-1;
          I := I-1
        END
      ELSE IF NOT (CH IN ['0'..'9']) THEN ERRORHNDLR(4)
    END;
    
  PROCEDURE GET_EXPONENT;
    VAR EX0 : 0..255;
        EX1 : REAL;
    BEGIN
      IF (CH IN ['0'..'9']) THEN
        BEGIN
          EX0 := ORD(CH)-ORD('0');
          IF (EXPONENT <= (37-EX0)/10) THEN
            BEGIN
              EX1 := EXPONENT*10+EX0;
              IF NOT((EX1+TESTNO)>37) THEN
                BEGIN
                  IF (K<0) THEN K := 0;
                  I := I+1;
                  K := K+1;
                  EX[K] := EX0;
                  EXPONENT := EX1
                END
              ELSE ERRORHNDLR(1)
            END
          ELSE ERRORHNDLR(6)
        END
      ELSE IF (CH = 'E') THEN ERRORHNDLR(5)
      ELSE IF (CH = '+') THEN ERRORHNDLR(8)
      ELSE IF (CH = '-') THEN
        BEGIN
          IF (K<0) THEN
            BEGIN
              I := I+1;
              K := 0;
              NEGEXP := TRUE;
              TESTNO := -TESTNO;
              CH := '0'
            END
          ELSE ERRORHNDLR(3)
        END
      ELSE IF (CH = BS) THEN
        BEGIN
          IF (FCODE = INPT) THEN
            BEGIN
              IF (I<0) THEN WRITE(' ') ELSE WRITE(' ',BS)
            END;
          CH := '0';
          IF (EXPONENT>0) THEN EXPONENT := (EXPONENT - EX[K])/10
          ELSE IF (K=0) THEN
            BEGIN
              NEGEXP := FALSE;
              TESTNO := -TESTNO
            END
          ELSE IF (K<0) THEN EXPNT := FALSE;
          IF (K>=0) THEN K := K-1;
          IF (K=0) AND (NOT NEGEXP) THEN K := -1;
          I := I-1
        END
      ELSE IF NOT (CH IN ['0'..'9']) THEN ERRORHNDLR(4)
    END; 
    
  BEGIN  (*IN_REAL*)
    BS := CHR(8);
    CR := CHR(13);
    DEC := FALSE;
    NEGNO := FALSE;
    EXPNT := FALSE;
    NEGEXP := FALSE;
    FRACDONE := FALSE;
    I := -1;
    J := -1;
    K := -1;
    CH := '0';
    INTG := 0;
    IFRACTN := 0;
    FRACTION := 0;
    EXPONENT := 0;
    IF (FCODE = INPT) THEN READ(F,CH);
    IF ((CH = CR) OR (CH = ',')) THEN CH := ' ';
    WHILE (NOT EOLN(F)) AND (NOT (CH = ' ')) DO
      BEGIN
        IF (FCODE = INFIL) THEN READ (F,CH);
        IF ((CH = CR) OR (CH = ',')) THEN CH := ' ';
        IF (NOT(DEC)) AND (NOT(EXPNT)) THEN GET_INTEGER
        ELSE IF DEC AND (NOT(EXPNT)) THEN GET_FRACTION
        ELSE IF EXPNT THEN GET_EXPONENT;
        IF (FCODE = INPT) THEN
          BEGIN
            READ(F,CH);
            IF ((CH = CR) OR (CH = ',')) THEN CH := ' ';
          END
      END;
    IF EOLN(F) THEN READLN(F);
    IF DEC THEN
      BEGIN
        IF (J>37) THEN J := 37;
        FRACTION := IFRACTN/PWROFTEN(J)
      END;
    EXPONENT := PWROFTEN(TRUNC(EXPONENT));
    IF NEGEXP THEN EXPONENT := 1/EXPONENT;
    INTG := (INTG+FRACTION)*EXPONENT;
    IF NEGNO THEN INTG := -INTG;
    IN_REAL := INTG
  END;

END. {of Unit}

========================================================================================
DOCUMENT :usus Folder:VOL20:home_loan.text
========================================================================================

{
   Changes made by reviewer:
        Replaced CHR(31) by RLF.
        Replaced CHR(29) by CEOL.
        Replaced PAGE(OUTPUT) by CLEARSCREEN.
        Added code for screen control and line DEFINESTRINGS.
        Cleaned up display (alignment, removal of previous
          entries, etc.)
        It was fairly easy to modify this program to (optionally)
          send output to the PRINTER.  This was not done in this
          version because the exact code depends on the capability
          of the printer (presence or absence of form feeds for
          example).
                ---Henry E. Baumgarten
}

PROGRAM HOME_LOAN;

TYPE    SHORTSTRING = STRING[3];

VAR     CEOL,CEOP,RLF,CLEAR_LINE : SHORTSTRING;
        A,R,Y,RATE,P,R12,R1,NP,FR,CM,CM1: REAL;
        
PROCEDURE CLEARSCREEN;    {Clears the TEXT screen}
  VAR   CS : PACKED ARRAY[0..1] OF 0..255;
  BEGIN
    CS[0] := 27;
    CS[1] := ORD('E');
    UNITWRITE(1,CS,2)
  END;

PROCEDURE DEFINESTRINGS;
  BEGIN
    CEOL := '12';        {CEOL clears from cursor to end of line}
    CEOL[1] := CHR(27);
    CEOL[2] := 'K';
    {The following was used by the Grundlers
    CEOL := '1';
    CEOL[1] := CHR(29);}
    
    RLF := '1';          {RLF is a reverse line feed}
    RLF[1] := CHR(11);
    {The following is for the H19
    RLF := '12';
    RLF[1] := CHR(27);
    RLF[2] := 'I';}
    {The following was used by the Grundlers
    RLF := '1';
    RLF[1] := CHR(31);}
    
    CEOP := '12';      {CEOP clears from cursor to end of page (screen)}
    CEOP[1] := CHR(27);
    CEOP[2] := 'J';
    {The following was used by the Grundlers
    CEOP := '1';
    CEOP[1] := CHR(11);}
    
    CLEAR_LINE := '1';
    CLEAR_LINE[1] := CHR(13);  {carriage return}
    CLEAR_LINE := CONCAT(CEOL,CLEAR_LINE);
  END;
  
FUNCTION INPUT_VALUE:REAL;

{
                                                 function by:  EDWARD J GRUNDLER
}

VAR I:INTEGER;
    INP:STRING;
    DEC,NEX,EX,NEG,OK:BOOLEAN;
    EXPO,J,X:REAL;
BEGIN
  REPEAT
    DEC:=FALSE;
    EX:=FALSE;
    READLN(INP);
    IF LENGTH(INP)=0 THEN INP:='0';
    OK:=NOT(INP[1]='E');
    IF LENGTH(INP)>1 THEN
      OK:=OK AND NOT((INP[1] IN ['+','-','.']) AND (INP[2]='E'));
    FOR I:=1 TO LENGTH(INP) DO
      BEGIN
        OK:=OK AND (INP[I] IN ['.','-','+','E','0'..'9']);
        IF (I>1) AND NOT EX THEN OK:=OK AND (INP[I] IN ['.','E','0'..'9']);
        OK:=OK AND NOT(DEC AND(INP[I]='.'));
        IF NOT DEC THEN DEC:=(INP[I]='.');
        OK:=OK AND NOT(EX AND (INP[I]='E'));
        IF NOT EX THEN EX:=(INP[I]='E');
        IF I>1 THEN
          OK:=OK AND NOT(EX AND (INP[I] IN ['+','-']) AND NOT(INP[I-1]='E'));
        OK:=OK AND NOT(EX AND (INP[I]='.'))
      END;
    OK:=OK AND (INP[LENGTH(INP)] IN ['0'..'9','.']);
    OK:=OK AND NOT(EX AND NOT(INP[LENGTH(INP)] IN ['0'..'9']));
    IF NOT OK THEN WRITE(RLF,'Read Error. Try Again ',CEOL)
  UNTIL OK;
  X:=0;
  DEC:=FALSE;
  EXPO:=0;
  NEG:=FALSE;
  EX:=FALSE;
  J:=1;
  FOR I:=1 TO LENGTH(INP) DO
    BEGIN
      IF NOT DEC THEN DEC:=(INP[I]='.');
      IF NOT NEG THEN NEG:=NOT EX AND (INP[I]='-');
      IF NOT NEX THEN NEX:=EX AND (INP[I]='-');
      IF NOT EX THEN EX:=(INP[I]='E');
      IF EX AND NOT(INP[I] IN ['+','-','E']) THEN
        EXPO:=EXPO*10+ORD(INP[I])-ORD('0');
      IF NOT EX THEN
        BEGIN
          IF DEC AND NOT(INP[I] IN ['.','+','-']) THEN
            BEGIN
              J:=J/10;
              X:=X+(ORD(INP[I])-ORD('0'))*J
            END
          ELSE
            IF NOT(INP[I] IN ['.','+','-']) THEN X:=X*10+ORD(INP[I])-ORD('0')
        END
    END;
  IF EX AND NEX THEN EXPO:=-EXPO;X:=X*EXP(LN(10)*EXPO);
  IF NEG THEN INPUT_VALUE:=-X ELSE INPUT_VALUE:=X
END;

PROCEDURE GET_DATA;
VAR CH: CHAR;
BEGIN
  CLEARSCREEN;
  WRITE(' Type <space> to continue or Q(uit');
  READ(KEYBOARD,CH);
  IF CH IN ['Q','q'] THEN EXIT(HOME_LOAN);
  WRITELN;
  WRITE('Amt. of loan = '); A:=INPUT_VALUE;
  WRITE('Annual percent interest rate = '); RATE:=INPUT_VALLUE;
  WRITE('Length of loan (years) = '); Y:=INPUT_VALUE;
END; { procedure GET_DATA }
  
PROCEDURE PAYMENT;
  FUNCTION POWER(A,B:REAL):REAL;
  BEGIN POWER:=EXP(B*LN(A)) END;
BEGIN
  R:=RATE/100;
  R12:=R/12;
  P:=A*R12/(1-POWER(1+R12,-12*Y))
END;

PROCEDURE DISPLAY;
VAR YR,MO,NEXTYR: INTEGER;
    BEGBAL,PAYINT,PAYPRIN,ENDBAL,TOTINT,TOTPRIN: REAL;
    CH: CHAR;
PROCEDURE FIRST_STUFF;
BEGIN
  CLEARSCREEN;
  WRITELN(' Amt of Loan = ',A:12:2,'         Interest rate = ',RATE:6:2,' percent');
  WRITELN(' Length of loan = ',Y:6:2,' years      Monthly payment = ',P:8:2);
  R1:=RATE/1200+1;
  NP:=12*Y;
  FR:=0.5;
  CM:=NP+LN(1-FR*(1-EXP(-NP*LN(R1))))/LN(R1);
  WRITELN('The loan is ',(1-FR)*100:5:2,' percent paid off at ',TRUNC(CM/12)+1,
               ' years ',CM-12*TRUNC(CM/12):5:2,' months');
  CM1:=NP+LN(0.5)/LN(R1)+1;
  WRITELN('Cross-over payment : ',TRUNC(CM1/12)+1,' years ',
                CM1-12*TRUNC(CM1/12):5:2,' months');
  WRITELN;
END;
BEGIN
  FIRST_STUFF;
  WRITELN('             Beginning Payment   Applied to  Ending');
  WRITELN(' Year Month   Balance  Interest  Principal   Balance');
  YR:=1; MO:=1; BEGBAL:=A; 
  TOTINT:=0; TOTPRIN:=0;
  WHILE BEGBAL>0 DO
    BEGIN
      PAYINT:=BEGBAL*R12;
      PAYPRIN:=P-PAYINT;
      ENDBAL:=BEGBAL-PAYPRIN;
      IF (YR=1) OR (YR=Y) OR (YR=NEXTYR) THEN
        begin
          WRITELN(YR:4,MO:6,BEGBAL:11:2,PAYINT:9:2,PAYPRIN:12:2,ENDBAL:11:2);
          TOTINT:=TOTINT+PAYINT; TOTPRIN:=TOTPRIN+PAYPRIN;
          IF MO=12 THEN
            begin
              WRITELN;
              WRITELN('   Totals for year:  Interest = ',TOTINT:8:2,
                '    Principal = ',TOTPRIN:8:2);
              WRITELN;
              WRITE('Enter next year you want printed (0 to quit): ',CEOL);
              NEXTYR:=TRUNC(INPUT_VALUE);
              IF NEXTYR=0 THEN EXIT(DISPLAY);
              TOTINT:=0; TOTPRIN:=0;
              GOTOXY(0,7)
            end;
        end;
      BEGBAL:=ENDBAL;
      IF MO<12 THEN MO:=MO+1
               ELSE begin MO:=1; YR:=YR+1 END;
    END;
END;

BEGIN { main program HOME_LOAN }
  DEFINESTRINGS;
  REPEAT
    GET_DATA;
    PAYMENT;
    DISPLAY
  UNTIL FALSE;
END.



========================================================================================
DOCUMENT :usus Folder:VOL20:lwrcase.text
========================================================================================

program lowercase;  {Version 1.1, 26 Oct 81}

var ch,reply : char;
    sfin,sfout : string;
    fin,fout : text;
    i,rslt : integer;
    skip : boolean;

procedure clearscreen;
  var lf : packed array [1..24] of char;
       i : integer;
  begin
    gotoxy(0,23);
    for i := 1 to 24 do lf[i] := chr(10);
    unitwrite(1,lf,24);
    gotoxy(0,0)
  end;
  
procedure clearspace (x,y,n : integer);
  var i : integer;
      cs :packed array [1..160] of 0..255;
  begin
    gotoxy(x,y);
    for i := 1 to n do cs[i] := 32;
    for i := n+1 to n+n do cs[i] := 8;
    unitwrite(1,cs[1],n);
    unitwrite(1,cs[n+1],n)
  end;
  
(*$I-*)
procedure getinfile;
  begin
    repeat
      begin
        readln(sfin);
        reset(fin,sfin);
        rslt := ioresult;
        if rslt <> 0 then
          begin
            if rslt = 10 then 
              begin
                sfin := concat(sfin,'.text');
                reset(fin,sfin);
                rslt := ioresult
              end;
            if rslt <> 0 then
              begin
                gotoxy(0,20);
                write('IO error',rslt:3,'.  Correct and type <SP> to continue or Q(uit)');
                repeat read (keyboard, reply) until reply in ['Q','q',' '];
                clearspace(0,20,72);
                if reply in ['Q','q'] then
                  begin
                    close(fout,lock);
                    exit(program)
                  end
                  else clearspace(31,4,length(sfin))
              end
          end
      end
    until rslt = 0
   end;
(*$I+*)

(*$I-*)
procedure getoutfile;
  begin
    repeat
      readln(sfout);
      rewrite(fout,sfout);
      rslt := ioresult;
      if rslt <> 0 then
        begin
          gotoxy (0,20);
          write('IO error',rslt:3,'. Correct and type <SP> to continue or Q(uit)');
          repeat read(keyboard,reply) until reply in ['Q','q',' '];
          clearspace(0,20,72);
          if reply in ['Q','q'] then
            begin
              clearscreen;
              exit(program)
            end
            else clearspace(32,2,length(sfout))
        end
      until rslt = 0
  end;
(*$I+*)

begin
  clearscreen;
  writeln('This program copies files in lower case.');
  writeln;
  write('Enter output (lower case) file: ');
  getoutfile;
  writeln;
  write('Enter input (upper case) file: ');
  getinfile;
  writeln;
  writeln('Lines copied');
  skip := false;
  I := 1;
  while (not eof(fin)) do
    begin
      while (not eoln(fin)) do
        begin
          read(fin,ch);
          if (ch in ['''','{','}']) then skip := not skip;
          if (ch >= 'A') and (ch <= 'Z') and not skip then
            ch := chr(ord(ch) + 32);
          write(fout,ch)
        end;
      readln(fin);
      writeln(fout);
      write('.');
      if ((i mod 50) = 0) then writeln;
      i := i+1
    end;
  close(fout,lock);
  close(fin)
end.

========================================================================================
DOCUMENT :usus Folder:VOL20:number2.text
========================================================================================

(*$S+*)
UNIT NUMBER2;

INTERFACE

USES {$U H19UTIL.CODE} H19UTIL;

TYPE    NUMBERTYPE = (DEC,HEX,OCT,BIN);
        HEXNUM = PACKED ARRAY [1..4] OF 0..15;
        BINNUM = PACKED ARRAY [0..15] OF 0..1;
        OCTNUM = PACKED RECORD
                   O5,O4,O3,O2,O1: 0..7;
                   O6 : 0..1;
                 END;
        CHAMELEON = RECORD CASE NUMBERTYPE OF
                     DEC : (INT : INTEGER);
                     HEX : (HEXINT : HEXNUM);
                     OCT : (OCTINT : OCTNUM);
                     BIN : (BININT : BINNUM)
                  END;

VAR     OCTAL,BINARY,HEXA : BOOLEAN;

PROCEDURE WRITEHEX (INTG : INTEGER);

PROCEDURE WRITEFLIP (INTG : INTEGER);

PROCEDURE WRITEOCTAL (INTG : INTEGER);

PROCEDURE WRITEBIN (INTG : INTEGER);

PROCEDURE GETHEX (VAR DATA : INTEGER);

PROCEDURE GETFLIP (VAR DATA : INTEGER);

PROCEDURE GETOCTAL (VAR DATA : INTEGER);

PROCEDURE GETBINARY (VAR DATA : INTEGER);

IMPLEMENTATION

VAR     LEN : INTEGER;

PROCEDURE WRITEHEX(* INTG : INTEGER *);
  VAR   N : INTEGER;
        NUMBER : CHAMELEON;
  BEGIN
    NUMBER.INT := INTG;
    WITH NUMBER DO
      BEGIN
        FOR N := 4 DOWNTO 1 DO
          BEGIN
            IF (HEXINT[N] <= 9) THEN WRITE(HEXINT[N])
              ELSE WRITE(CHR(HEXINT[N] + ORD('A') - 10))
          END
      END
  END;
  
PROCEDURE WRITEFLIP(* INTG : INTEGER *);
  VAR   N : INTEGER;
        NUMBER : CHAMELEON;
  BEGIN
    NUMBER.INT := INTG;
    WITH NUMBER DO
      BEGIN
        FOR N := 2 DOWNTO 1 DO
          BEGIN
            IF (HEXINT[N] <= 9) THEN WRITE(HEXINT[N])
              ELSE WRITE(CHR(HEXINT[N] + ORD('A') - 10))
          END;
        FOR N := 4 DOWNTO 3 DO
          BEGIN
            IF (HEXINT[N] <= 9) THEN WRITE(HEXINT[N])
              ELSE WRITE(CHR(HEXINT[N] + ORD('A') - 10))
          END
      END
  END;
  
PROCEDURE WRITEOCTAL(* INTG : INTEGER *);
  VAR   N : INTEGER;
        NUMBER : CHAMELEON;
  BEGIN
    NUMBER.INT := INTG;
    WITH NUMBER.OCTINT DO WRITE(O6,O5,O4,O3,O2,O1)
  END;
  
PROCEDURE WRITEBIN (* INTG : INTEGER *);
  VAR   N : INTEGER;
        NUMBER : CHAMELEON;
  BEGIN
    NUMBER.INT := INTG;
    WITH NUMBER DO FOR N := 15 DOWNTO 0 DO WRITE(BININT[N])
  END;
  
PROCEDURE ERRHNDLR(VAR DATA : INTEGER);
  CONST BELL = 7;
  BEGIN
    CLEARSPACE(0,0,80);
    WRITE(CHR(BELL),'Improper number. Retype.');
    CLEARSPACE(XCUR,YCUR,LEN);    (*XCUR,YCUR are globals*)
    IF OCTAL THEN GETOCTAL(DATA)
      ELSE IF BINARY THEN GETBINARY(DATA)
        ELSE IF HEXA THEN GETHEX(DATA)
          ELSE GETFLIP(DATA);
    SAVECURSOR(XCUR,YCUR);
    CLEARSPACE(0,0,80);
    GOTOXY(XCUR,YCUR);
    IF OCTAL THEN EXIT(GETOCTAL)
      ELSE IF BINARY THEN EXIT(GETBINARY)
        ELSE IF HEXA THEN EXIT(GETHEX)
          ELSE EXIT(GETFLIP)
  END;
    
PROCEDURE GETHEX(*VAR DATA : INTEGER*);
  VAR   I : INTEGER;
        NUMBER : CHAMELEON;
        STR : STRING;

  BEGIN
    OCTAL := FALSE;
    BINARY := FALSE;
    HEXA := TRUE;
    SAVECURSOR(XCUR,YCUR);
    READLN(STR);
    LEN := LENGTH(STR);
    FOR I := 1 TO LEN DO IF NOT (STR[I] IN ['0'..'9','A'..'F']) THEN ERRHNDLR(DATA);
    IF (LEN > 4) THEN ERRHNDLR(DATA);
    FOR I := 1 TO (4-LEN) DO STR := CONCAT('0',STR);
    WITH NUMBER DO FOR I := 4 DOWNTO 1 DO
        IF STR[I] IN ['0'..'9'] THEN HEXINT[5-I] := ORD(STR[I]) - ORD('0')
          ELSE HEXINT[5-I] := ORD(STR[I]) - ORD('A') + 10;
    DATA := NUMBER.INT
  END;
  
PROCEDURE GETFLIP(*VAR DATA : INTEGER*);
  VAR   I : INTEGER;
        NUMBER : CHAMELEON;
        FLIPSTR,STR : STRING;

  BEGIN
    OCTAL := FALSE;
    BINARY := FALSE;
    HEXA := FALSE;
    STR := '1234';
    SAVECURSOR(XCUR,YCUR);
    READLN(FLIPSTR);
    LEN := LENGTH(FLIPSTR);
    FOR I := 1 TO LEN DO IF NOT (FLIPSTR[I] IN ['0'..'9','A'..'F'])
       THEN ERRHNDLR(DATA);
    IF (LEN > 4) THEN ERRHNDLR(DATA);
    FOR I := 1 TO (4-LEN) DO FLIPSTR := CONCAT('0',FLIPSTR);
    STR[1] := FLIPSTR[3];
    STR[2] := FLIPSTR[4];
    STR[3] := FLIPSTR[1];
    STR[4] := FLIPSTR[2];
    WITH NUMBER DO FOR I := 4 DOWNTO 1 DO
        IF STR[I] IN ['0'..'9'] THEN HEXINT[5-I] := ORD(STR[I]) - ORD('0')
          ELSE HEXINT[5-I] := ORD(STR[I]) - ORD('A') + 10;
    DATA := NUMBER.INT
  END;
  
PROCEDURE GETOCTAL(*VAR DATA : INTEGER*);
  VAR   I : INTEGER;
        NUMBER : CHAMELEON;
        STR : STRING;
  BEGIN
    OCTAL := TRUE;
    BINARY := FALSE;
    HEXA := FALSE;
    SAVECURSOR(XCUR,YCUR);
    READLN(STR);
    LEN := LENGTH(STR);
    FOR I := 1 TO LEN DO IF NOT (STR[I] IN ['0'..'7']) THEN ERRHNDLR(DATA);
    IF (LEN > 6) THEN ERRHNDLR(DATA);
    FOR I := 1 TO (6-LEN) DO STR := CONCAT('0',STR);
    IF (STR > '177777') THEN ERRHNDLR(DATA);
    WITH NUMBER.OCTINT DO
      BEGIN
        O6 := ORD(STR[1]) - ORD('0');
        O5 := ORD(STR[2]) - ORD('0');
        O4 := ORD(STR[3]) - ORD('0');
        O3 := ORD(STR[4]) - ORD('0');
        O2 := ORD(STR[5]) - ORD('0');
        O1 := ORD(STR[6]) - ORD('0')
      END;
    DATA := NUMBER.INT
  END;
  
PROCEDURE GETBINARY(*VAR DATA : INTEGER*);
  VAR   I : INTEGER;
        NUMBER : CHAMELEON;
        STR : STRING;
  BEGIN
    OCTAL := FALSE;
    BINARY := TRUE;
    HEXA := FALSE;
    SAVECURSOR(XCUR,YCUR);
    READLN(STR);
    LEN := LENGTH(STR);
    FOR I := 1 TO LEN DO IF NOT (STR[I] IN ['0','1']) THEN ERRHNDLR(DATA);
    IF (LEN > 16) THEN ERRHNDLR(DATA);
    FOR I := 1 TO (16-LEN) DO STR := CONCAT('0',STR);
    WITH NUMBER DO FOR I := 15 DOWNTO 0 DO BININT[I] := ORD(STR[16-I]) - ORD('0');
    DATA := NUMBER.INT
  END;
END. (* of unit *)

========================================================================================
DOCUMENT :usus Folder:VOL20:othello.1.text
========================================================================================

(*included from othello.text*)

PROCEDURE findlegalmoves(VAR status: gamestatus; VAR legallist: movelist);
VAR
   x,y:                   coordinate;
   sq:                    squareloc;
   flips,direcflips:      INTEGER;
   borderflips:           INTEGER;
   stopdirec:             BOOLEAN;
   oppcolor:              color;
   direc:                 direction;
   trydirs,gooddirs:      SET OF direction;
   possible:              BOOLEAN;
   sqstatus:              squarestatus;
BEGIN
WITH status, legallist DO BEGIN
   oppcolor := flipof(nextmover);
   movecount := 0;
   FOR x := 1 TO 8 DO  FOR y := 1 TO 8 DO BEGIN
      possible := FALSE;
      WITH boardstatus[x,y] DO
         IF NOT occupied THEN
            IF adjacentpieces[oppcolor] <> [] THEN BEGIN
               possible := TRUE;
               trydirs := adjacentpieces[oppcolor];
               END;
      IF possible THEN BEGIN
         gooddirs := [];
         flips := 0;
         borderflips := 0;
         FOR direc := north TO nw DO
            IF direc IN trydirs THEN BEGIN
               sq := board[x,y].adjacentsq[direc];
               sq := board[sq.row,sq.col].adjacentsq[direc];
               IF sq.onboard THEN BEGIN
                  direcflips := 1;
                  stopdirec := FALSE;
                  REPEAT
                     sqstatus := boardstatus[sq.row,sq.col];
                     IF sqstatus.occupied THEN
                        IF sqstatus.occupier = oppcolor THEN BEGIN
                           direcflips := direcflips + 1;
                           sq := board[sq.row,sq.col].adjacentsq[direc];
                           END
                        ELSE
                           stopdirec := TRUE
                     ELSE BEGIN
                        direcflips := 0;
                        stopdirec := TRUE;
                        END;
                     UNTIL ( stopdirec OR (NOT sq.onboard) );
                  IF (stopdirec AND (direcflips>0)) THEN BEGIN
                     flips := flips + direcflips;
                     gooddirs := gooddirs + [direc];
                     IF board[x,y].border AND board[sq.row,sq.col].border THEN
                        borderflips := borderflips + direcflips;
                     END;
                  END; (*IF sq.onboard...*)
               END; (*IF direc IN...*)
         IF flips > 0 THEN BEGIN
            movecount := movecount + 1;
            WITH okmove[movecount] DO BEGIN
               moveloc.onboard := TRUE;
               moveloc.row := x;
               moveloc.col := y;
               points := flips;
               dirsflipped := gooddirs;
               bordrsqsflipped := borderflips;
               END;
            END;
         END; (*IF possible...*)
      END; (*FOR x :=...FOR y :=...*)
   END; (*WITH status, legallist...*)
END; (*findlegalmoves*)

PROCEDURE inputmove(mover: color; legallist: movelist; VAR move: movedesc);
VAR
   x,y:                 coordinate;
   xch,ych:             CHAR;
   i,listindex:         INTEGER;
   c:                   CHAR;
BEGIN
listindex := 0;
REPEAT
   REPEAT
      GOTOXY(0,23);
      WRITE('Enter move for ',colorword[mover],':        ');
      GOTOXY(22,23);
      READ(xch,ych);
      IF ych IN ['1'..'8'] THEN BEGIN (*Want xy but we'll accept yx*)
         c := ych;
         ych := xch;
         xch := c;
         END;
      IF ych IN ['a'..'h'] THEN
         ych := CHR(ORD(ych)-32);
      UNTIL ((xch IN ['1'..'8']) AND (ych IN ['A'..'H']));
   x := ORD(xch) - ORD('1') + 1;
   y := ORD(ych) - ORD('A') + 1;
   i := 1;
   REPEAT
      IF legallist.okmove[i].moveloc.row = x THEN
         IF legallist.okmove[i].moveloc.col = y THEN
            listindex := i;
      i := i+1;
      UNTIL ((i>legallist.movecount) OR (listindex <> 0));
   UNTIL listindex <> 0;
move := legallist.okmove[listindex];
END; (*inputmove*)

PROCEDURE makemove(*VAR status: gamestatus; VAR move: movedesc; updateadjacent:
                                                                BOOLEAN*);
VAR
   direc,direc2:       direction;
   sq,sq2:             squareloc;
   oppcolor:           color;
   flips:              INTEGER;
   emptyneighbors:     SET of direction;
BEGIN
WITH status, move DO BEGIN
   lastmoveloc := moveloc;
   WITH boardstatus[moveloc.row,moveloc.col] DO BEGIN
      emptyneighbors := [north..nw] - adjacentpieces[white]
                                    - adjacentpieces[black];
      occupied := TRUE;
      occupier := nextmover;
      END;
   oppcolor := flipof(nextmover);
   flips := 0;
   FOR direc := north TO nw DO
      IF direc IN dirsflipped THEN BEGIN
         sq := board[moveloc.row,moveloc.col].adjacentsq[direc];
         REPEAT
            IF updateadjacent THEN
               FOR direc2 := north TO nw DO
                  IF NOT (direc2 IN [direc,opposdir[direc]]) THEN BEGIN
                     sq2 := board[sq.row,sq.col].adjacentsq[direc2];
                     IF sq2.onboard THEN WITH boardstatus[sq2.row,sq2.col] DO
                        IF NOT occupied THEN BEGIN
                           adjacentpieces[nextmover]:=adjacentpieces[nextmover]
                                                        + [opposdir[direc2]];
                           adjacentpieces[oppcolor]:=adjacentpieces[oppcolor]
                                                        - [opposdir[direc2]];
                           END;
                     END;
            boardstatus[sq.row,sq.col].occupier := nextmover;
            flips := flips + 1;
            sq := board[sq.row,sq.col].adjacentsq[direc];
            UNTIL boardstatus[sq.row,sq.col].occupier = nextmover;
         END
      ELSE
         IF updateadjacent THEN
            IF direc IN emptyneighbors THEN BEGIN
               sq := board[moveloc.row,moveloc.col].adjacentsq[direc];
               IF sq.onboard THEN
                  WITH boardstatus[sq.row,sq.col] DO
                     adjacentpieces[nextmover] := adjacentpieces[nextmover] + 
                                                  [opposdir[direc]];
               END;
   score[nextmover] := score[nextmover] + flips + 1;
   score[oppcolor]  := score[oppcolor] - flips;
   nextmover := oppcolor;
   END;
END; (*makemove*)


PROCEDURE calcmove( mover: color; VAR status: gamestatus;
                   VAR legallist: movelist; VAR bestmove: movedesc);
TYPE
   movearray = ARRAY[1..30] OF movedesc;
VAR
   bestsofar,cornmoves,m,respcornmoves:         INTEGER;
   move,movetemp:                               movedesc;
   aftermove:                                   gamestatus;
   responses:                                   movelist;

PROCEDURE checkposition(VAR legallist: movelist; VAR cornmoves: INTEGER);
   VAR
      m,bestm,bestyet:  INTEGER;
   BEGIN
   bestyet := -MAXINT;
   cornmoves := 0;
   FOR m := 1 TO legallist.movecount DO WITH legallist.okmove[m],
                                             board[moveloc.row,moveloc.col] DO
      BEGIN
      bordnoncorn := FALSE;
      IF incenter4by4 THEN
         points := points + 10
      ELSE BEGIN
         IF corner THEN BEGIN
            points := points + 60;
            cornmoves := cornmoves + 1;
            END
         ELSE IF border THEN BEGIN
                 bordnoncorn := TRUE;
                 points := points + 25;
                 END
              ELSE IF diagnexttocorner THEN
                      points := points - 50;
         END;
      IF points > bestyet THEN BEGIN
         bestyet := points;
         bestm := m;
         end;
      END; (*FOR m := 1 TO legallist.movecount...*)
   movetemp := legallist.okmove[1];
   legallist.okmove[1] := legallist.okmove[bestm];
   legallist.okmove[bestm] := movetemp;
   END; (*checkposition*)

PROCEDURE sortmoves(VAR okmove: movearray;
                    l,r: INTEGER) (*into descending order by points*) ;
   VAR
      i,j,baseval:      INTEGER;
   BEGIN
   i := l;
   j := r;
   baseval := okmove[(i+j) DIV 2].points;
   REPEAT
      WHILE okmove[i].points > baseval DO
         i := i+1;
      WHILE okmove[j].points < baseval DO
         j := j-1;
      IF i <= j THEN BEGIN
         movetemp := okmove[i];
         okmove[i] := okmove[j];
         okmove[j] := movetemp;
         i := i+1;
         j := j-1;
         END;
      UNTIL i > j;
   IF l < j THEN sortmoves(okmove, l, j );
   IF i < r THEN sortmoves(okmove, i, r )
   END (* sortmoves *) ;

PROCEDURE checkresponses(mover: color; VAR move: movedesc;
                         VAR responses: movelist; bestsofar: INTEGER);
(*$G+*)
   LABEL 0;
   VAR
      contingent,c,r:                   INTEGER;
      x,y:                              coordinate;
      sq:                               squareloc;
      direc:                            direction;
      oppcolor:                         color;
      afterresp:                        gamestatus;
      cornercounter:                    BOOLEAN;
      respondmove:                      movedesc;
      counterresp:                      movelist;
   BEGIN
   oppcolor := flipof(mover);
   WITH move DO BEGIN
      contingent := 0;
      r := 1;
      REPEAT
         respondmove := responses.okmove[r];
         IF NOT board[moveloc.row,moveloc.col].incenter4by4 THEN
            FOR direc := north TO nw DO  WITH respondmove DO
               IF direc IN dirsflipped THEN  WITH moveloc DO
                  IF board[row,col].adjacentsq[direc] = move.moveloc THEN BEGIN
                      move.points := move.points - 5;
                      IF move.points <= bestsofar THEN
                         EXIT(checkresponses);
                      END;
         afterresp := aftermove;
         makemove(afterresp,respondmove,FALSE);
         IF bordnoncorn THEN  WITH moveloc DO
            IF afterresp.boardstatus[row,col].occupier = oppcolor THEN BEGIN
               bordnoncorn := FALSE;
               points := points - 65; (*40, plus the 25 given in checkposition*)
               IF points <= bestsofar THEN
                  EXIT(checkresponses);
               END
            ELSE
               contingent := contingent + 8*respondmove.bordrsqsflipped;
         WITH respondmove.moveloc DO
            IF board[row,col].corner THEN BEGIN
               points := points - 55;
               IF cornmoves > 1 THEN
                  IF board[moveloc.row,moveloc.col].corner THEN
                     points := points -20;
               IF points <= bestsofar THEN
                  EXIT(checkresponses);
               END;
         FOR x:=1 TO 8 DO FOR y:=1 TO 8 DO WITH afterresp.boardstatus[x,y] DO
            IF occupied THEN
               IF occupier = mover THEN
                  FOR direc := north TO nw DO WITH afterresp DO BEGIN
                     sq.row := x;
                     sq.col := y;
                     REPEAT
                        sq := board[sq.row,sq.col].adjacentsq[direc];
                        IF NOT sq.onboard THEN
                           GOTO 0;
                        IF NOT boardstatus[sq.row,sq.col].occupied THEN
                           GOTO 0
                        UNTIL boardstatus[sq.row,sq.col].occupier = oppcolor;
                     END;
         makemove(afterresp,respondmove,TRUE);
         findlegalmoves(afterresp,counterresp);
         cornercounter := FALSE;
         c := 1;
         WITH counterresp DO
            WHILE ( (c <= movecount) AND (NOT cornercounter) ) DO BEGIN
               WITH okmove[c].moveloc DO
                  IF board[row,col].corner THEN
                     cornercounter := TRUE;
               c := c + 1;
               END;
         IF NOT cornercounter THEN BEGIN
            points := points -190;
            IF points <= bestsofar THEN
               EXIT(checkresponses);
            END;
0:
         IF afterresp.score[mover] = 0 THEN BEGIN
            points := -MAXINT+1; (*might be our only choice, so +1*)
            EXIT(checkresponses);
            END;
         r := r + 1;
         UNTIL r > responses.movecount;
      IF bordnoncorn THEN BEGIN
         points := points - contingent;
         WITH board[moveloc.row,moveloc.col] DO
            IF specialbordersq THEN WITH otherofpair,
                                         status.boardstatus[row,col] DO
               IF occupied THEN
                  IF occupier = mover THEN
                     WITH status.boardstatus[between.row,between.col] DO
                        IF NOT occupied THEN
                           points := points - 90;
         END;
      END; (*WITH move...*)
   END; (*checkresponses*)
   
BEGIN (*calcmove*)
GOTOXY(0,23);
WRITE('Calculating move for ',colorword[mover],'...');
checkposition(legallist,cornmoves);
IF legallist.movecount > 2 THEN
   sortmoves(legallist.okmove,2,legallist.movecount);
bestsofar := -MAXINT;
FOR m := 1 TO legallist.movecount DO BEGIN
   move := legallist.okmove[m];
   aftermove := status;
   makemove(aftermove,move,TRUE);
   findlegalmoves(aftermove,responses);
   WITH move DO BEGIN
      IF responses.movecount = 0 THEN
         points := points + 100
      ELSE
         IF points > bestsofar THEN BEGIN
            checkposition(responses,respcornmoves);
            checkresponses(mover,move,responses,bestsofar);
            END;
      IF points > bestsofar THEN BEGIN
         bestsofar := points;
         bestmove := move;
         END;
      END; (*WITH move...*)
   END; (*FOR m := 1 TO legallist.movecount...*)
END; (*calcmove*)

PROCEDURE play(mover: color);
BEGIN
GOTOXY(0,20+ORD(mover));
IF legalmoves[mover] > 0 THEN BEGIN
   WRITE(spaces);
   IF mover = usercolor THEN
      inputmove(mover,legallist,move)
   ELSE
      calcmove(mover,status,legallist,move);
   makemove(status,move,TRUE);
   updatecrt(crtstatus,status);
   crtstatus := status;
   END
ELSE BEGIN
   WRITE('(No legal moves for ',colorword[mover],')');
   status.nextmover := flipof(mover);
   END;
END; (*play*)

FUNCTION userquits: BOOLEAN;
VAR
   playagain:        CHAR;
BEGIN
GOTOXY(0,20);
WRITELN(spaces); WRITELN(spaces); WRITELN; WRITE(spaces);
GOTOXY(0,23);
WRITE('Start a new game? (y/n): ');
READ(playagain);
userquits := NOT (playagain IN ['Y','y']);
END; (*userquits*)



BEGIN (*PROGRAM OTHELLO*)
REPEAT
   initgame;
   findlegalmoves(status,legallist);
   legalmoves[white] := legallist.movecount;
   REPEAT
      play(white);
      findlegalmoves(status,legallist);
      legalmoves[black] := legallist.movecount;
      play(black);
      findlegalmoves(status,legallist);
      legalmoves[white] := legallist.movecount;
      UNTIL (legalmoves[white]=0) and (legalmoves[black]=0);
   UNTIL userquits;
END.



========================================================================================
DOCUMENT :usus Folder:VOL20:othello.text
========================================================================================

(* COPYRIGHT (C) 1979 Software Supply.  All rights reserved. *)
(*$S+*)
(* UCSD Pascal *) PROGRAM OTHELLO; (* Steve Brecher 16-Jun-79 *)
(* modified to be independant of the system clock - gws 01 Jan 83*)

(* The position evaluation weights were derived from a FORTRAN program   *)
(* headed "from Creative Computing/Klaus E Liebold/4-26-78".             *)

(* This program provides playing instructions to the user on request.    *)

CONST
   (* The game pieces are shown on the screen as 2 rows of 3 characters, e.g. *)
   (*                          OOO                                            *)
   (*                          OOO                                            *)
   (* If your crt has a "block" character (like the cursor on some crts), that*)
   (* is good for the white piece, and capital letter O is good for black,    *)
   (* especially if it has a rectangular shape.  Otherwise, choose characters *)
   (* that are centered within the character dot matrix; try to maximize the  *)
   (* difference in intensity between the black and white pieces while maxi-  *)
   (* mizing the absolute intensity of the black piece.  Avoid characters with*)
   (* semantic content, e.g. "W" and "B" are not so good.                     *)
   whiteascii = 96;     (*ascii value of char making up piece of first mover*)
   blackascii = 79;     (*  "     "   "   "     "     "    "   " 2nd    "   *)
  {minticks   = 22.0;   (*min # clock ticks between crt square updates      *)
                        (*--should be long enough for a distinct, separate  *)
                        (*terminal bell sound on each square updated        *)}
   dwell_time = 2000;   (*loop argument for delay between computer moves,
                          change it to produce about 2 or 3 beeps/second*)
   spaces     = '                             ';
   
TYPE
   coordinate   = 1..8;
   color        = (white,black);
   squareloc    = RECORD
                    CASE onboard: BOOLEAN OF
                      TRUE:            (row,col:        coordinate);
                    END;
   direction    = (north,south,east,west,sw,ne,se,nw); (*pairs of opposites*)
   squarestatus = RECORD
                    CASE occupied: BOOLEAN OF
                      TRUE:  (occupier:       color                           );
                      FALSE: (adjacentpieces: ARRAY[color] OF SET of direction);
                    END;
   gamestatus   = RECORD
                    boardstatus:  ARRAY[coordinate,coordinate] OF squarestatus;
                    nextmover:    color;
                    lastmoveloc:  squareloc;
                    score:        ARRAY[color] OF INTEGER;
                    END;
   movedesc     = RECORD
                    moveloc:            squareloc;
                    points:             INTEGER;
                    dirsflipped:        SET OF direction;
                    bordrsqsflipped:    INTEGER;
                    bordnoncorn:        BOOLEAN;
                    END;
   movelist     = RECORD
                    movecount:          INTEGER;
                    okmove:             ARRAY[1..30] OF movedesc;
                    END;
   position     = RECORD
                    border:             BOOLEAN;
                    corner:             BOOLEAN;
                    diagnexttocorner:   BOOLEAN;
                    incenter4by4:       BOOLEAN;
                    adjacentsq:         ARRAY[direction] OF squareloc;
                  (* "special" border squares are those border squares        *)
                  (* adjacent to a corner or adjacent to board midline; there *)
                  (* are 2 pairs of such squares on each border. Sample pair: *)
                  (* (1,2) and (1,4); for each we want a pointer to the other *)
                  (* and to the border square between them (1,3).             *)
                    CASE specialbordersq: BOOLEAN OF
                      TRUE:             (otherofpair,between:  squareloc);
                    END;


VAR
   board:                       ARRAY[coordinate,coordinate] OF position;
   status,crtstatus:            gamestatus;
   square:                      squareloc;
   legallist:                   movelist;
   move:                        movedesc;
   opposdir:                    ARRAY[direction] OF direction;
   legalmoves:                  ARRAY[color] OF INTEGER;
   colorword:                   ARRAY[color] OF STRING[5];
   usercolor:                   color;
   {lastchange:                  REAL; (*time of last square change on crt*)}
   delay:                       integer;
   
(* COPYRIGHT (C) 1979 Software Supply.  All rights reserved.  *)

PROCEDURE updatecrt(VAR oldstatus,newstatus: gamestatus);
FORWARD;
FUNCTION flipof(oldcolor: color): color;
FORWARD;
PROCEDURE makemove(VAR status: gamestatus; VAR move: movedesc; updateadjacent:
                                                                BOOLEAN);
FORWARD;

SEGMENT PROCEDURE initgame;
CONST
   backspace = 8;
VAR
   x,y:         coordinate;
   direc:       direction;
   answer:      CHAR;
   {h,l,h0,l0:   INTEGER; (*for testing whether clock is on*)}

   PROCEDURE defineboard;
   BEGIN
   FOR x := 1 TO 8 DO  FOR y := 1 TO 8 DO  WITH board[x,y] DO BEGIN
      border := (x IN [1,8]) OR (y IN [1,8]);
      corner := (x IN [1,8]) AND (y IN [1,8]);
      incenter4by4 := (x IN [3..6]) AND (y IN [3..6]);
      diagnexttocorner := (x IN [2,7]) AND (y IN [2,7]);
      FOR direc := north TO nw  DO WITH adjacentsq[direc] DO BEGIN 
         CASE direc OF
            north: onboard := x>1;
            ne:    onboard := (x>1) AND (y<8);
            east:  onboard := y<8;
            se:    onboard := (x<8) AND (y<8);
            south: onboard := x<8;
            sw:    onboard := (x<8) AND (y>1);
            west:  onboard := y>1;
            nw:    onboard := (x>1) AND (y>1);
            END; (*CASE*)
         IF onboard THEN BEGIN
            CASE direc OF
               north,ne,nw: row := x-1;
               east,west:   row := x;
               south,se,sw: row := x+1;
               END;
            CASE direc OF
               nw,west,sw:  col := y-1;
               north,south: col := y;
               ne,east,se:  col := y+1;
               END;
            END;
         END; (*FOR direc...WITH adjacentsq...*)
      specialbordersq := border AND (NOT corner) AND 
                            ( (x IN [2,4,5,7]) OR (y IN [2,4,5,7]) );
      IF specialbordersq THEN BEGIN
         otherofpair.onboard := TRUE;
         between.onboard := TRUE;
         IF x IN [1,8] THEN BEGIN
            otherofpair.row := x;
            between.row := x;
            IF y IN [2,5] THEN BEGIN
               otherofpair.col := y+2;
               between.col := y+1;
               END
            ELSE BEGIN
               otherofpair.col := y-2;
               between.col := y-1;
               END;
            END
         ELSE BEGIN
            otherofpair.col := y;
            between.col := y;
            IF x IN [2,5] THEN BEGIN
               otherofpair.row := x+2;
               between.row := x+1;
               END
            ELSE BEGIN
               otherofpair.row := x-2;
               between.row := x-1;
               END;
            END;
         END; (*IF specialbordersq...*)

      END; (*FOR x:= ... FOR y:= ... WITH board[x,y]...*)
   END; (*defineboard*)
    
   PROCEDURE showemptyboard;
   CONST
      vertdivs = '|     |     |     |     |     |     |     |     |';
      horzdivs = '|-----|-----|-----|-----|-----|-----|-----|-----|';
      colnames = '   A     B     C     D     E     F     G     H   ';
      blanks   = '                              ';
   VAR
      gamerow :    coordinate;
   BEGIN
   GOTOXY(0,0);
   FOR gamerow := 1 TO 8 DO BEGIN
      IF gamerow>1 THEN (* "IF" because no room for topmost border line *)
         writeln(blanks,horzdivs);
      writeln(blanks:29,gamerow,vertdivs);
      writeln(blanks,vertdivs);
      END;
   write(blanks,colnames);
   GOTOXY(4,0);
   WRITELN('Score');
   WRITELN('-----------');
   WRITELN(CHR(whiteascii),'/White:');
   WRITELN(CHR(blackascii),'/Black:');
   END; (*showemptyboard*)
  
   PROCEDURE instructions;
   VAR
      i: INTEGER;
   PROCEDURE page1;
      BEGIN
      WRITELN('A move consists of placing  ');
      WRITELN('one of your pieces on an    ');
      WRITELN('unoccupied square which is  ');
      WRITELN('adjacent (vertically, hori- ');
      WRITELN('zontally, or diagonally) to ');
      WRITELN('a square occupied by your   ');
      WRITELN('opponent so that a straight ');
      WRITELN('line starting at your piece ');
      WRITELN('and continuing in the direc-');
      WRITELN('tion of the adjacent oppon- ');
      WRITELN('ent hits one of your other  ');
      WRITELN('pieces before hitting an un-');
      WRITELN('occupied square.  All of the');
      WRITELN('opponent''s pieces which that');
      WRITELN('line crosses are converted  ');
      WRITELN('to become your pieces.  Thus');
      WRITELN('each move "flips" at least  ');
      WRITELN('one opposing piece.         ');
      WRITE  (' (Tap space bar for more...)');
      END; (*page1*)
   PROCEDURE page2;
      BEGIN
      WRITELN('Example:  a legal move for  ');
      WRITELN('white on the first play     ');
      WRITELN('would be 3E, 4F, 6D, or 5C. ');
      WRITELN('To make a move at, e.g., 3E ');
      WRITELN('you may type any of: 3E, 3e,');
      WRITELN('E3, or e3.                  ');
      WRITELN('If you have no legal move,  ');
      WRITELN('you must pass.  The object  ');
      WRITELN('of the game is to end up    ');
      WRITELN('occupying more squares than ');
      WRITELN('does your opponent.         ');
      WRITELN('Hints on strategy:  Usually ');
      WRITELN('the board position of a move');
      WRITELN('is more important than the  ');
      WRITELN('number of pieces it "flips".');
      WRITELN('Try to occupy the borders   ');
      WRITELN('(especially corners!) and   ');
      WRITELN('avoid giving them to your   ');
      WRITE  ('opponent. (Tap space bar...)');
      END; (*page2*)
   BEGIN (*instructions*)
   GOTOXY(0,5);
   WRITE('Want instructions? (y/n): ');
   READ(answer);
   IF NOT (answer IN ['N','n']) THEN BEGIN
      GOTOXY(0,5);
      page1;
      READ(answer);
      GOTOXY(0,5);
      page2;
      READ(answer);
      GOTOXY(0,5);
      FOR i := 5 TO 22 DO
         WRITELN(spaces);
      WRITE(spaces);
      END
   ELSE BEGIN
      GOTOXY(0,5);
      WRITE(spaces);
      END;
   END; (*instructions*)
      
BEGIN (*initgame*)
{lastchange := 0;
TIME(h0,l0);}
defineboard;
FOR direc := north TO NW DO
   IF odd(ORD(direc)) THEN
      opposdir[direc] := pred(direc)
   ELSE
      opposdir[direc] := succ(direc);
{TIME(h,l);
IF (h=h0) AND (l=l0) THEN BEGIN
   GOTOXY(20,11);
   WRITE('Please turn on the clock.');
   WHILE l=l0 DO
      TIME(h,l);
   END;}
showemptyboard;
WITH status DO BEGIN
   score[white] := 0;
   score[black] := 0;
   FOR x := 1 TO 8 DO  FOR y := 1 TO 8 DO WITH boardstatus[x,y] DO BEGIN
      occupied := FALSE;
      adjacentpieces[white] := [];
      adjacentpieces[black] := [];
      END;
   END;
crtstatus := status;
move.dirsflipped := [];
move.points := 0;
WITH status DO BEGIN
   FOR x := 4 TO 5 DO  FOR y := 4 TO 5 DO BEGIN
      move.moveloc.row := x;
      move.moveloc.col := y;
      IF x=y THEN
         nextmover := white
      ELSE
         nextmover := black;
      makemove(status,move,TRUE);
      updatecrt(crtstatus,status);
      crtstatus := status;
      END; (*FOR...FOR...*)
   nextmover := white;
   END; (*WITH status...*)
instructions;
GOTOXY(0,6);
WRITELN('White goes first -- Which');
WRITELN('color do you want to play:');
REPEAT
   GOTOXY(3,8);
   WRITE('W)hite or B)lack?  ',CHR(backspace));
   READ(answer);
   UNTIL answer IN ['W','w','B','b'];
IF answer IN ['W','w'] THEN
   usercolor := white
ELSE 
   usercolor := black;
GOTOXY (0,6);
WRITELN(spaces); WRITELN(spaces); WRITELN(spaces);
colorword[white] := 'white';
colorword[black] := 'black';
END; (*initgame*)

FUNCTION flipof(*oldcolor: color): color*);
BEGIN
IF oldcolor = white THEN
   flipof := black
ELSE
   flipof := white;
END; (*flipof*)

PROCEDURE updatecrt(*VAR oldstatus,newstatus: gamestatus*);
VAR
   x,y:         coordinate;
   direc:       direction;
   square:      squareloc;

   PROCEDURE showpiece(square: squareloc);
      
      PROCEDURE changecrtsq(square: squareloc);
      CONST
         bell = 7;
      VAR
         s:                     PACKED ARRAY[1..3] OF CHAR;
         c:                     CHAR;
         crtline,crtcol:        INTEGER;
         h,l:                   INTEGER;
         {now:                   REAL;}
      BEGIN
      WITH square DO BEGIN
         IF newstatus.boardstatus[row,col].occupier = white THEN
            c := CHR(whiteascii)
         ELSE
            c := CHR(blackascii);
         FILLCHAR(s,3,c);
         crtline := (3*row) - 3;
         crtcol  := 26 + (6*col);
         END;
      {REPEAT
         TIME(h,l);
         now := l;
         IF now < 0.0 THEN
            now := now + 65536.0;
         now := (h*65536.0) + now;
         UNTIL (now - lastchange) > minticks;} 
      for delay := 1 to dwell_time do; {waste some time}
      GOTOXY(crtcol,crtline);
      WRITE(s);
      GOTOXY(crtcol,crtline+1);
      WRITE(s,CHR(bell));
      {lastchange := now;}
      END; (*changecrtsq*)
   
   BEGIN (*showpiece*)
   WITH square DO
      IF newstatus.boardstatus[row,col].occupied THEN
         IF NOT oldstatus.boardstatus[row,col].occupied THEN
            changecrtsq(square)
         ELSE IF oldstatus.boardstatus[row,col].occupier <>
                 newstatus.boardstatus[row,col].occupier THEN
                 changecrtsq(square);
   END; (*showpiece*)

BEGIN (*updatecrt*)
WITH newstatus DO BEGIN
   showpiece(lastmoveloc);
   FOR direc := north to nw DO BEGIN
      square := lastmoveloc;
      WHILE boardstatus[square.row,square.col].occupied AND
            board[square.row,square.col].adjacentsq[direc].onboard DO BEGIN
         square := board[square.row,square.col].adjacentsq[direc];
         showpiece(square);
         END; (*WHILE...*)
      END; (*FOR direc...*)
   GOTOXY(9,2);
   WRITE(score[white]:2);
   GOTOXY(9,3);
   write(score[black]:2);
   END; (*WITH newstatus...*)
GOTOXY(0,0);
END; (*updatecrt*)


(*$I othello.1.text*)




========================================================================================
DOCUMENT :usus Folder:VOL20:screen.h19.text
========================================================================================

UNIT SCREEN;      (*Pure H19 Version - 28 Jun 82*)

INTERFACE

PROCEDURE CLEARSCREEN;
PROCEDURE CLEARSPACE(X,Y,N : INTEGER);
PROCEDURE SAVECURSOR(VAR X,Y : INTEGER);
PROCEDURE NORMALKEYPAD;
PROCEDURE SHIFTKEYPAD;

IMPLEMENTATION

PROCEDURE CLEARSCREEN;
  VAR T : PACKED ARRAY [0..1] OF 0..255;
  BEGIN
    T[0] := 27;
    T[1] := ORD('E');
    UNITWRITE(1,T,2)
  END;

PROCEDURE CLEARSPACE (*X,Y,N : INTEGER*);
  VAR I : INTEGER;
      CS :PACKED ARRAY [1..160] OF 0..255;
  BEGIN
    GOTOXY(X,Y);
    FOR I := 1 TO N DO CS[I] := 32;
    FOR I := N+1 TO N+N DO CS[I] := 8;
    UNITWRITE(1,CS[1],N);
    UNITWRITE(1,CS[N+1],N)
  END;
  
PROCEDURE SAVECURSOR (*VAR X,Y : INTEGER*);
  VAR T : PACKED ARRAY [0..7] OF 0..255;
  BEGIN
    T[0] := 27;
    T[1] := ORD('j');
    T[2] := 27;
    T[3] := ORD('n');
    UNITWRITE(1,T,4);
    UNITREAD(2,T[4],4);
    X := T[7] - 32;
    Y := T[6] - 32
  END;
  
PROCEDURE NORMALKEYPAD;
  VAR T : PACKED ARRAY[0..1] OF 0..255;
  BEGIN
    T[0] := 27;
    T[1] := ORD('u');
    UNITWRITE(1,T,2)
  END;
  
PROCEDURE SHIFTKEYPAD;
  VAR T : PACKED ARRAY[0..1] OF 0..255;
  BEGIN
    T[0] := 27;
    T[1] := ORD('t');
    UNITWRITE(1,T,2)
  END;
  
END.
00>B
========================================================================================
DOCUMENT :usus Folder:VOL20:screen.text
========================================================================================

UNIT SCREEN;

INTERFACE

PROCEDURE CLEARSCREEN;
PROCEDURE CLEARSPACE(X,Y,N : INTEGER);
PROCEDURE SAVECURSOR(VAR X,Y : INTEGER);

IMPLEMENTATION

PROCEDURE CLEARSCREEN;
  VAR LF : PACKED ARRAY [1..24] OF CHAR;
      I : INTEGER;
  BEGIN
    GOTOXY(0,23);
    FOR I := 1 TO 24 DO LF[I] := CHR(10);
    UNITWRITE(1,LF,24);
    GOTOXY(0,0)
  END;

PROCEDURE CLEARSPACE (*X,Y,N : INTEGER*);
  VAR I : INTEGER;
      CS :PACKED ARRAY [1..160] OF 0..255;
  BEGIN
    GOTOXY(X,Y);
    FOR I := 1 TO N DO CS[I] := 32;
    FOR I := N+1 TO N+N DO CS[I] := 8;
    UNITWRITE(1,CS[1],N);
    UNITWRITE(1,CS[N+1],N)
  END;
  
PROCEDURE SAVECURSOR (*VAR X,Y : INTEGER*);
  VAR T : PACKED ARRAY [0..7] OF 0..255;
  BEGIN
    T[0] := 27;
    T[1] := ORD('j');
    T[2] := 27;
    T[3] := ORD('n');
    UNITWRITE(1,T,4);
    UNITREAD(2,T[4],4);
    X := T[7] - 32;
    Y := T[6] - 32
  END;
  
END.

========================================================================================
DOCUMENT :usus Folder:VOL20:sigfig.19.text
========================================================================================

{Note: The exponent handling routine appears in the main program because the
 real-to-string routine was written for use in the labeling of axes in a 
 package of plotting routines. For this purpose it desirable to be able to
 suppress the exponent at the axis tic marks and include it in the title
 of the axis or to write it in conventional arithmetic form rather than
 using the E format. For use with a plotting routine or for many other
 purposes it may be desirable to delete the code marked (**) and to remove
 the comments on the one line bracketed with comment symbols. When this is
 done FORMAT defines the upper limit for the mantissa (e.g., a format of
 0.0XXX will give numbers less than or equal to 0.0999).  Note also that this
 simple program maps all char except '.' and '0' into 'X'. Zeros other than
 leading zeros will be treated as X's by the routine. In a more
 sophisticated program it might be desirable to avoid inadvertent user
 errors by flagging char other than '.', '0', or 'X' with an error message
 and providing an opportunity to retype the format specification.
   This output routine can involve repeated divisions by 10; thus, it is
 more likely to lose accuracy than an assembly language routine which avoids
 such division, operating by shifts and rotates.---Henry E. Baumgarten}
 
PROGRAM SIGFIGS;    (*Version 1.3 - 04 Feb 83*)

USES {$U H19UTIL.CODE} H19UTIL;

VAR     RL1,RL2 : REAL;
        N : INTEGER;
        FORMAT,STRG1,STRG2 : STRING;
        NEGNO : BOOLEAN;
        REPLY : CHAR;
        
PROCEDURE PREAMBLE;
  BEGIN
    WRITELN
('This program demonstrates the use of two "user-friendly" real number input');
    WRITELN
('and output routines, the latter being rather specialized. In the real number');
    WRITELN
('input routine the numbers may be terminated with a space, a comma, or a');
    WRITELN
('carriage return.  The output routine will write either scientific format');
    WRITELN
('(X.XXXXXXXEXX) or selected format numbers (any number of decimal places,');
    WRITELN
('only about 7 of which are meaningful for the 2-word, real-number internal');
    WRITELN
('format).  Typical formats are: X.XXXXXXX, XXXXX., XXXXX, .XXXXX or the');
    WRITELN
('equivalent 0.XXXXX, and 0.000XXXX.  In all cases the output number will');
    WRITELN
('be rounded to the chosen number of zeros and digits (with an exponent if');
    WRITELN
('necessary), and a leading zero will be  appended to all fractional numbers.');
    WRITELN
('Typical inputs might be:  1/7, 0.00999/1, 123456789/1, or 0.31415926E1/1.');
    END;
    
PROCEDURE REALTOSTR(X:REAL; FORMAT:STRING; VAR S:STRING; VAR EXPNT:INTEGER);
  
  VAR  DECPT,DIGIT,INTG,FRAC_DIGITS,INDEX,LEN,TEMP_EXPNT  : INTEGER;
       FIRST_DIGIT,ZEROS,I : INTEGER;
       BOUND : REAL;
       CARRY,LEAD_ZERO,NEGNO : BOOLEAN;
       S0 : STRING;
  
  BEGIN
    EXPNT := 0;
    TEMP_EXPNT := 0;
    NEGNO := FALSE;
    LEN := LENGTH(FORMAT);
    IF (LEN=0) THEN
      BEGIN
        FORMAT := 'X.XXXXXX';
        LEN := 8
      END
    ELSE FOR I := 1 TO LEN DO
        IF NOT(FORMAT[I] IN ['0','X','.']) THEN FORMAT[I] := 'X';
    DECPT := POS('.',FORMAT);
    FIRST_DIGIT := POS('X',FORMAT);
    IF (DECPT=0) THEN FRAC_DIGITS := 0 ELSE FRAC_DIGITS := LEN-DECPT;
    ZEROS := DECPT+1-FIRST_DIGIT;
    IF (ZEROS>0) THEN ZEROS := ZEROS-1;
    IF (DECPT=0) THEN ZEROS := LEN+1-FIRST_DIGIT;
    IF (ZEROS<0) THEN BOUND := 1/PWROFTEN(ABS(ZEROS))
      ELSE BOUND := PWROFTEN(ZEROS);
    IF (X < 0) THEN
      BEGIN
        NEGNO := TRUE;
        X := ABS(X)
      END;
    IF (X >= BOUND) THEN
      REPEAT
        X := X/10;
        EXPNT := EXPNT+1;
      UNTIL (X < BOUND);
    IF ((X < (BOUND/10)) AND (X <> 0)) THEN  (**)
      REPEAT                                 (**)
        X := X*10;                           (**) (*Omit for plot labels*)
        EXPNT := EXPNT-1                     (**)
      UNTIL (X >= (BOUND/10));               (**)
    IF (X > MAXINT) THEN
      REPEAT
        X := X/10;
        TEMP_EXPNT := TEMP_EXPNT + 1;
      UNTIL (X <= MAXINT);
    INTG := TRUNC(X);
    STR(INTG,S);
    X := (X-INTG)*10;
    IF (TEMP_EXPNT>0) THEN FOR I := 1 TO TEMP_EXPNT DO
          BEGIN
            INTG := TRUNC(X);
            STR(INTG,S0);
            S := CONCAT(S,S0);
            X := (X-INTG)*10;
          END;
    IF (FRAC_DIGITS > 0) THEN
      BEGIN
        S := CONCAT(S,'.');
        FOR I := 1 TO FRAC_DIGITS DO
          BEGIN
            INTG := TRUNC(X);
            STR(INTG,S0);
            S := CONCAT(S,S0);
            X := (X-INTG)*10;
          END
      END; 
    IF (X >= 5) THEN
      BEGIN
        IF (S[1] = '0') THEN LEAD_ZERO := TRUE ELSE LEAD_ZERO := FALSE;
        INDEX := LENGTH(S);
        DIGIT := 0;
        REPEAT
          IF NOT(S[INDEX] = '.') THEN
            BEGIN
              DIGIT := (ORD(S[INDEX])-ORD('0'));
              IF (DIGIT <> 0) THEN CARRY := FALSE;
              IF (DIGIT <> 9) THEN DIGIT := DIGIT+1
                ELSE
                  BEGIN
                    DIGIT := 0;
                    CARRY := TRUE
                  END;
              S[INDEX] := CHR(DIGIT + ORD('0'));
            END;
          INDEX := INDEX-1
        UNTIL ((INDEX = 0) OR (DIGIT > 0));
        IF CARRY THEN
          BEGIN
            IF NOT(LEAD_ZERO) THEN S := CONCAT('1',S)
               ELSE S := CONCAT('0',S);          (**) (*Delete ELSE part only*)
            INDEX := POS('.',S);
            IF (INDEX > 0) THEN                  (**)
        (*  IF (INDEX > DECPT) THEN  *)
              BEGIN
                DELETE(S,INDEX,1);
                INSERT('.',S,INDEX-1)
              END;
            DELETE(S,LENGTH(S),1);
            EXPNT := EXPNT+1
          END
      END; 
    IF NEGNO THEN S := CONCAT('-',S)
  END;
  
    
  BEGIN{program}
    CLEARSCREEN;
    PREAMBLE;
    REPEAT
      WRITELN;
      WRITELN('Enter X and Y for X/Y (either = 0 to quit)');
      WRITE('     ');
      RL1 := INREAL(INPUT,INPT);
      RL2 := INREAL(INPUT,INPT);
      IF ((RL1 = 0) OR (RL2 = 0)) THEN EXIT(PROGRAM);
      WRITELN;
      WRITELN('Scientific notation? <Y/N>');
      WRITELN;
      IF DOIT THEN FORMAT := 'X.XXXXXX'
      ELSE
        BEGIN
          WRITE('Enter format (<CR> = X.XXXXXX): ');
          READLN(FORMAT);
          WRITELN
        END;
      REALTOSTR(RL1/RL2,FORMAT,STRG1,N);
      IF (N<>0) THEN
        BEGIN
          STR(N,STRG2);
          STRG1 := CONCAT(STRG1,'E',STRG2)
        END;
      WRITELN(STRG1);
    UNTIL (RL1=0)
  END.

========================================================================================
DOCUMENT :usus Folder:VOL20:sxfr.svcs.text
========================================================================================

.TITLE    "K. G. Balke, Associates, Escort File Transfer Unit"

;  Author:      Karl G. Balke
;  Version:     01 October 1982

.INCLUDE  bios.const

.RELPROC  MDEM_INIT, 1

;  This service initializes the modem port to the speed indicated in 
;  its parameter (the clock divisor at 16x speed).

;  It assumes that the port is in mode instruction mode on entry.

;  It is called from a Pascal program which declares it as follows:

;         PROCEDURE mdem_init
;            (divisor:             INTEGER);

          
;  Position the divisor for programming the clock divider.
          POP   HL
          EX    (SP), HL
          LD    A, 76H
          OUT   (CNT_MDM), A
          LD    A, L
          OUT   (CNT_REG_1), A
          LD    A, H
          OUT   (CNT_REG_1), A
          
;  Set the modem port mode.
          LD    A, 4EH
          OUT   (PRT_MODEM + STAT_PRT), A
          
;  Turn on the port and wait for the chips to settle.
          LD    A, 17H
          OUT   (PRT_MODEM + STAT_PRT), A
          LD    B, 0
          DJNZ  $
          
;  Turn off the modem port to clear the line of any noise.
          LD    A, 40H
          OUT   (PRT_MODEM + STAT_PRT), A
          LD    B, 0
          DJNZ  $
          
;  Set the modem port mode again.
          LD    A, 4EH
          OUT   (PRT_MODEM + STAT_PRT), A
          LD    A, 37H
          OUT   (PRT_MODEM + STAT_PRT), A
          RET

.RELPROC  MDEM_CLR

;  This procedure turns off the DSR and CTS lines of the
;  modem, indicating that the computer is no longer listening.
;  It also places the modem in mode instruction mode.

;  It is declared in the caller as:

;         PROCEDURE mdem_clr;

          LD    A, 40H
          OUT   (PRT_MODEM + STAT_PRT), A
          RET


.PROC     READ_MSG, 1
;  This service reads a message over the designated serial port.
;  It interprets the messages according to the following protocol:

;         First Ch.                Rest Of Message
;         ---------                ---------------

;            A                     <IO Result>

;            B                     <IO Result>
;                                  512-byte message if IO Result = 0

;            C                     --

;            D                     String (all strings are Pascal form.)

;            E                     String

;            G                     --

;            R                     String

;            W                     String

;  The service also polls for console break-in and detects the serial
;  line dropping or going inactive.  (DSR/DTR low means line dropped,
;  CTS/RTS low means inactive.)

;  Console break-in is translated into a line condition code placed in
;  the returned message.  The console break-in is detected by use of the
;  standard SBIOS calls, and must consist of a single escape character
;  (others are ignored).

;  Line conditions are reported through the leading character of the
;  returned message as follows:

;         Value                    Meaning
;         -----                    -------
;           1                      Line error
;           3                      Line dropped
;           4                      Pause (cancel message thus far)
;           5                      Escape from console

;  Procedure is declared in Pascal program as follows:
;         PROCEDURE
;          (VAR
;             msg:                 {PACKED ARRAY [0 .. 513] OF CHAR});

          .DEF  HEX_OUT

          POP   HL
          EX    (SP), HL
          LD    (MSG_BASE), HL

;  From here on, HL => next character to deposit in message.
;  Read the initial incoming character and interpret.
          CALL  RD_DEPOS
          AND   A
          RET   NZ

;  Error free transmission occurred.  Interpret the message.
          LD    A, E
          
;  Discard initial binary zero on assumption that it is generated
;  by serial port when DSR comes high.
          AND   A
          JR    NZ, $0
          
;  Reset the message pointer and read the next character.
          LD    HL, (MSG_BASE)
          CALL  RD_DEPOS
          AND   A
          RET   NZ

          LD    A, E
          
$0:
;  Interpret this character as serious transmission.
          CP    "A"
          JP    Z, RD_DEPOS

;  Not "A".  Return if not larger.
          RET   C

;  Return if greater than "W".
          CP    "W"
          JR    Z, $3
          RET   NC

;  Test remaining long message characters.
          CP    "D"
          JR    Z, $3
          
          CP    "E"
          JR    Z, $3
          
          CP    "R"
          JR    Z, $3
          
          CP    "B"
          RET   NZ

;  Block message in response to "G" request.  Get IO Result and
;  decide whether or not to read 512 characters of block.
          CALL  RD_DEPOS
          AND   A
          RET   NZ

;  Check for IO Result if read valid.
          CP    E
          RET   NZ

;  Result indicates block will follow.
          LD    BC, 2

$2:
;  Read the number of characters specified in BC, where C is high
;  order byte.
          CALL  RD_DEPOS
          AND   A
          RET   NZ
          
          DJNZ  $2
          DEC   C
          RET   Z
          JR    $2

$3:
;  Read the string length character and set up to read the characters
;  of string.
          CALL  RD_DEPOS
          AND   A
          RET   NZ
          
          LD    B, E
          LD    C, 1
          JR    $2


RD_DEPOS:
;  This service reads the next character from the line and deposits it
;  into the message.  It also polls for console break-in, and detects
;  transmission failures.

;  On Entry:
;         (HL) => Message Deposit Position

;  On Exit:
;         (A) = Result status.
;         (E) = Character read.
;         (HL) => Next Message Character.

          CALL  RD_CHAR
          AND   A
          JR    Z, $0

          LD    HL, (MSG_BASE)
          LD    (HL), A
          RET

$0:
          LD    (HL), E
          INC   HL
          RET


RD_CHAR:
;  This service reads a character from the transmission port.
;  It detects pause and line dropping signals, and console break-in
;  with an escape character.

;  On Exit:
;         (A) = Event status.
;         (E) = Character read.

          PUSH  BC

$0:
;  Poll for console character ready.
          IN    A, (CRT_STAT)
          AND   02H
          JR    NZ, $8

;  Look for line dropping.
          IN    A, (PRT_MODEM + STAT_PRT)
          BIT   PRT_DSR, A
          JR    Z, $1
          
;  Look for pause condition from other end.
          BIT   PRT_RTSB, A
          JR    Z, $2
          
;  Analyze errors on line.
          LD    B, A
          AND   38H
          JR    NZ, $3

;  Test for available character on line.
          BIT   PRT_RRDY, B
          JR    Z, $0

;  Character available on line.  Read it and return result.
          IN    A, (PRT_MODEM)
          
;         CALL  HEX_OUT
          
          LD    E, A
          XOR   A

$9:
          POP   BC
          RET


$8:
;  Break-in must be escape.
          IN    A, (CRT_DATA)
          AND   7FH
          CP    27
          JR    NZ, $0

;  Drop CTS and return escape result.
          LD    A, 15H
          OUT   (PRT_MODEM + STAT_PRT), A
          LD    A, 5
          JR    $9

$1:
;  Line has dropped since last poll.
          LD    A, 3
          JR    $9

$2:
;  Ready to send has dropped since last poll.
          LD    A, 4
          JR    $9

$3:
;  Transmission problems.  Drop CTS to signal other end that
;  transaction unsuccessful.
          LD    A, 17H
          OUT   (PRT_MODEM + STAT_PRT), A
          LD    A, 1
          JR    $9

MSG_BASE:
          .WORD 0

HEX_OUT:
;  This service presents the character it receives on input on the
;  screen in hex format.

;  On Entry:
;         (A) = Character to print.

          PUSH  AF
          PUSH  BC

          LD    B, A
          AND   0F0H
          RLA
          RLA
          RLA
          RLA
          RLA
          CALL  CONS_OUT

          LD    A, B
          AND   0FH
          CALL  CONS_OUT
          
          LD    C, " "
          CALL  CONS_TRAN

          POP   BC
          POP   AF
          RET

CONS_OUT:
;  This service converts the offered nibble to a hex digit and sends
;  it to the console.

;  On Entry:
;         (A) = Nibble.

          ADD   A, 30H
          CP    3AH
          JR    C, $0
          ADD   A, 7
$0:
          LD    C, A

CONS_TRAN:
          IN    A, (CRT_STAT)
          AND   01H
          JR    Z, CONS_TRAN

          LD    A, C
          OUT   (CRT_DATA), A
          RET



.FUNC     WRT_MSG, 2
;  This service writes a message to the file transfer port.  It detects
;  console break-in and drops the CTS line to indicate a pause in
;  transmission.

;  The result code is interpreted as follows:

;         Value                    Meaning
;         -----                    -------
;           0                      Message written.
;           1                      Line error.
;           2                      Line interrupt (character received).
;           3                      Line dropped.
;           4                      Pause (RTS dropped).
;           5                      Escape break-in from keyboard.

;  The function is declared in a Pascal program as follows:
;         FUNCTION wrt_msg
;            (l:                   INTEGER;
;           VAR
;             msg:                 {PACKED ARRAY [0 .. 513] OF CHAR}):
;                                  INTEGER;
          
          .REF  HEX_OUT

          POP   DE                 ;  Return.
          POP   HL                 ;  Message pointer.
          POP   BC                 ;  Message length.
          POP   AF                 ;  Dummy function value.
          PUSH  DE

;  Position transfer count for efficient processing.
          LD    A, C
          LD    C, B
          AND   A
          JR    Z, $0
          
          INC   C
$0:
          LD    B, A

;  Raise CTS signal if not already on.
          LD    A, 27H
          OUT   (PRT_MODEM + STAT_PRT), A

$1:
;  Transfer characters until done.
          LD    E, (HL)
          INC   HL
          CALL  WRT_CHAR

          AND   A
          JR    NZ, $3

;  Count down transfer count.
          DJNZ  $1
          DEC   C
          JR    NZ, $1

;  Report successful status.
          LD    HL, 0

$2:
;  Push result onto stack and return.
          EX    (SP), HL
          JP    (HL)

$3:
;  Error or escape break-in has occurred.  Report status.
          LD    L, A
          LD    H, 0
          JR    $2

WRT_CHAR:
;  This service writes a single character to the serial line.  It also
;  polls for <esc> break-in, receipt of a character on the serial line
;  in the opposite direction, and loss of line.

;  On Entry:
;         (E) = Character to transmit.

;  On Exit:
;         (A) = Result.  Values are:
;               0--Successful transmission.
;               1--Line error.
;               2--Reverse direction character.
;               3--Line dropped.
;               4--Pause (RTS dropped).
;               5--Console escape break-in.

          PUSH  BC

$0:
;  Poll for console character ready.
          IN    A, (CRT_STAT)
          AND   02H
          JR    NZ, $8

;  See if Host is still connected.
          IN    A, (PRT_MODEM + STAT_PRT)
          BIT   PRT_DSR, A
          JR    Z, $1

;  Identify errors.
          LD    B, A
          AND   38H
          JR    NZ, $3

;  See if transmit buffer is ready for next character.
          BIT   PRT_THBE, B
          JR    NZ, $4

;  See if Host is trying to send a character.
          BIT   PRT_RRDY, B
          JR    Z, $0

;  Input character from line ready to read.
          LD    A, 2
          JR    $9

$8:
;  Break-in must be escape.
          IN    A, (CRT_DATA)
          AND   7FH
          CP    27
          JR    NZ, $0

;  Drop CTS and return escape result.
          LD    A, 17H
          OUT   (PRT_MODEM + STAT_PRT), A
          LD    A, 5
          JR    $9

$1:
;  Escort off line.
          LD    A, 3
          JR    $9

$2:
;  Escort RTS dropped.
          LD    A, 4
          JR    $9

$3:
;  Line transfer error.
          LD    A, 1
          JR    $9

$4:
;  See if Host has dropped RTS to request pause.
          BIT   PRT_RTSB, B
          JR    Z, $2

;  Ready to send character.
          LD    A, E
          OUT   (PRT_MODEM), A

;         CALL  HEX_OUT
          
          XOR   A

$9:
;  Return result.
          POP   BC
          RET

.END


========================================================================================
DOCUMENT :usus Folder:VOL20:trans-genr.text
========================================================================================

ctransportr
$

asxfr.svcs
sxfr.svcs

ltransportr
sxfr.svcs


trans-mgr.code
frtransportr.code
yq

========================================================================================
DOCUMENT :usus Folder:VOL20:transportr.text
========================================================================================

{Version 002                 06 Dec 82      KGB
    Block disk access to improve efficiency of transfer.}
    
{$I-}
PROGRAM disk_xfr;

{***********************************************************************
*     Copyright (C) 1982 K. G. Balke, Associates                       *
*          All rights reserved.                                        *
***********************************************************************}

{$C (C) 1982 K. G. Balke, Associates}


  CONST
    bell = 7;
    max_msg = 30;
                                  {Length of longest informational
                                  message.}
    
    tank_size = 20;
                                  {Number of blocks in disk holding tank.}
    
    tran_titl = 'FILE TRANSPORTER';
    
  TYPE
    file_tank = PACKED ARRAY [1 .. tank_size, 0 .. 511] OF CHAR;
                                  {Disk file tank array.}
    
  VAR
    done:                    BOOLEAN;
                                  {True if current iteration is complete.}
                                  
    file_name:               STRING [23];
                                  {Name of file being read or written.}
                                  
    mdem_baud:               INTEGER;
                                  {Divisor to achieve desired baud rate
                                  from modem port.  Value 13 corresponds to
                                  9600 baud.  Faster rates not supported by
                                  Escort.}
    
    xfr_bufr:                PACKED ARRAY [0 .. 514] OF CHAR;
                                  {Space for transfer of file blocks
                                  between Escort and Host.  Consists of
                                  type character, then up to 513 bytes of
                                  data.
                                  
                                  The initial character may be a status
                                  report or a file transfer directive.  An
                                  initial status report is a binary integer
                                  between 1 and 5; a file transfer
                                  directive is one of 'A', 'B', 'C', 'D',
                                  'E', 'G', 'R' or 'W'.}
    
    xfr_file:                FILE;
                                  {Untyped file for file transfer.}
    
{************************************************************************
*  The following external procedures are assembler subroutines found in *
*  the sxfr.svcs file.                                                  *
************************************************************************}
    
  PROCEDURE mdem_init
                                  {Initialize the modem RS232 port for
                                  communication.}
                                  
     (divisor:               INTEGER);
                                  {Clock divisor for producing the desired
                                  Baud rate at 8MHz crystal (4MHz clock
                                  rate).}
    
    EXTERNAL;
    
  PROCEDURE mdem_clr;
                                  {Turn off the handshaking lines to the
                                  Host and place the modem port in Mode
                                  Instruction mode for next conversation.}
    
    EXTERNAL;
    
  PROCEDURE read_msg
                                  {Read a complete message from the modem
                                  port according to the transfer protocol. 
                                  Report result.}
                                  
   (VAR
      msg);
                                  {Block to receive the message.  Must be
                                  514 bytes long.}
    
    EXTERNAL;
    
  FUNCTION wrt_msg
                                  {Send a complete message to the modem
                                  port according to the transfer protocol. 
                                  Report result.}
                                  
     (ln:                    INTEGER;
                                  {Active length of message (bytes).}
                                  
    VAR
      msg):
                                  {Block containing message.  Maximum size
                                  is 514 bytes.}
                                  
                             INTEGER;
                                  {Port-level result of write.}
    
    EXTERNAL;
    
    
  PROCEDURE head_scrn
     (t:                     STRING);
    
    BEGIN {head_scrn}
      WRITE (CHR (27), '*', t);
      t := '(C) 1982 K. G. Balke, Assoc.';
      GO_TO_X_Y (80 - LENGTH (t), 0);
      WRITE (t)
    END {head_scrn};
    
    
  PROCEDURE err_prcsr
                                  {Diagnose all host device read or write
                                  errors and set global flow booleans if
                                  necessary. (done & terminate)}
                                  
     (error:                 INTEGER);
                                  {This is the error number as returned by a
                                  read or write operation.}
                                  
    
    BEGIN {err_prcsr}
      IF error > 0 THEN
        BEGIN
      
                                  {Close transfer file in case it is open
                                  on entry.}
          CLOSE (xfr_file);
      
                                  {Analyze error and diagnose.}
          CASE error OF
            1:                        {Line error.}
              BEGIN
                GO_TO_X_Y (10, 23);
                WRITE ('Transmission failure.       ')
              END;
    
            2:                        {Line interrupt.}
              BEGIN
                GO_TO_X_Y (10, 23);
                WRITE ('Host interrupt.                 ')
              END;
    
            3:                        {Line dropped by Host.}
              BEGIN
                done := true;
                GO_TO_X_Y (10, 23);
                WRITE ('Line dropped.               ')
              END;
    
            4:                        {Host has paused for own reasons.}
              BEGIN
                GO_TO_X_Y (10, 23);
                WRITE ('Host paused.                ')
              END;
    
            5:                        {Operator has intervened.}
              BEGIN
                mdem_clr;
                GO_TO_X_Y (10, 23);
                WRITE ('Operator intervened.        ');
                EXIT (PROGRAM)
              END;
          END
        END

    END {err_prcsr};
    
  
  PROCEDURE proto_err;
                                  {Improper protocol has been discovered so
                                  send a an io_error 3 to the host.}
                                  
    BEGIN {proto_err}
      xfr_bufr [0] := 'A';
      xfr_bufr [1] := CHR (3);
      err_prcsr (wrt_msg (2, xfr_bufr))
    END {proto_err};
    
    
  FUNCTION good_file
                                  {Determine whether the given name is a
                                  legal p-System file name.}
                                  
     (fn:                    STRING):
                                  {File name to test.}
                                  
                             BOOLEAN;
                                  {True if name is acceptable.}
    
    VAR
      cln_ct:                INTEGER;
                                  {Number of colons in name.}
                                  
      i:                     INTEGER;
                                  {Running index over file name.}
                                  
      last_cln:              INTEGER;
                                  {Position of last colon in name.}
                                  
      name_rslt:             BOOLEAN;
                                  {True if file name is acceptable to
                                  current point in processing.}
      
    BEGIN {good_file}
      
                                  {Initialize volume name validation count
                                  and index.}
      cln_ct := 0;
      last_cln := 0;
      
                                  {File name must be non-null.}
      name_rslt := LENGTH (fn) > 0;
      
      IF name_rslt THEN
        
                                  {Scan for invalid character or missing
                                  file name component.}
        FOR i := 1 TO LENGTH (fn) DO
          BEGIN
            
                                  {Look first for invalid character.}
            IF NOT (fn [i] IN ['!' .. '#', '%' .. '+', '-' .. '<',
              '>', '@' .. '~']) THEN
              name_rslt := false
            
            ELSE
              
                                  {Character acceptable.  Be certain that
                                  colon is followed by file name, and that
                                  there is only one colon in name.}
              IF fn [i] = ':' THEN
                BEGIN
                  cln_ct := cln_ct + 1;
                  last_cln := i
                END
          END;
      
      good_file := name_rslt AND (cln_ct < 2) AND (last_cln < 
        LENGTH (fn));
    END {good_file};
    
    
  PROCEDURE rpt_flr
                                  {Report a failure to the Host in standard
                                  protocol as supplied in parameters.}
                                  
     (h:                     CHAR;
                                  {Expected response of Escort to Host.}
                                  
      r:                     INTEGER);
                                  {Result value to report.}
    
    VAR
      msg_bufr:              PACKED ARRAY [0 .. 1] OF CHAR;
                                  {Space for forming acknowledgement
                                  message.}
                                  
      msg_rslt:              INTEGER;
                                  {Result of write to Host.}
      
    BEGIN {rpt_flr}
      msg_bufr [0] := h;
      msg_bufr [1] := CHR (r);
      err_prcsr (wrt_msg (2, msg_bufr))
    END {rpt_flr};
    
    
  PROCEDURE dir_mode;
  
    BEGIN
    END;
    
    
  PROCEDURE eras_mode;

    VAR
      problem:               INTEGER;
      
    BEGIN {eras_mode}
      
                                  {Begin initial acknowledgement message.}
      xfr_bufr [0] := 'A';
      
                                  {Attempt file open if file name is
                                  acceptable.}
      IF ORD (xfr_bufr [1]) < 24 THEN
        BEGIN

                                  {File name is short enough to fit in
                                  string for use in RESET.  Move it into
                                  reset string; if it is valid, attempt
                                  open and report result.}
{$R-}
          MOVE_LEFT (xfr_bufr [1], file_name [0], ORD (xfr_bufr [1]) + 1);
{$R^}
          IF good_file (file_name) THEN
            BEGIN
              RESET (xfr_file, file_name);
              xfr_bufr [1] := CHR (IO_RESULT);
              IF IO_RESULT = 0 THEN
                CLOSE (xfr_file, PURGE)
            END
          
          ELSE
                                  
                                  {Report unacceptable file name.}
            xfr_bufr [1] := CHR (7)
        END
      
      ELSE
        
                                  {Report file name too long to analyze.}
        xfr_bufr [1] := CHR (7);

                                  {Write acknowledgement to Host.  Ignore
                                  result.}
      problem := wrt_msg (2, xfr_bufr)
    END {eras_mode};


  PROCEDURE writ_mode;

    PROCEDURE xfr_in;
                                  {Follow the transfer protocol for writing
                                  a file transmitted from the Host to the
                                  open write file.}
      
      VAR
        tank:                file_tank;
                                  {Disk transfer tank.}
                                  
        tank_idx:            INTEGER;
                                  {Count of blocks in tank.}
                                  
        xfr_rslt:            INTEGER;
                                  {Result of block transfer operation.}
        
      FUNCTION wrt_tank
                                  {Write the current tank full to the
                                  file.}
                                  
       (ct:                  INTEGER):
                                  {Number of blocks in tank.}
                                  
                             BOOLEAN;
                                  {True if tank written successfully.}
        
        VAR
          bloks:             INTEGER;
                                  {Number of blocks actually written.}
          
        BEGIN {wrt_tank}
          wrt_tank := true;
          bloks := BLOCK_WRITE (xfr_file, tank, ct);
          IF (bloks < ct) OR (IO_RESULT > 0) THEN
            
                                  {There is a file write error.  Inform
                                  Host and terminate file transfer.}
            BEGIN
              wrt_tank := false;
              done := true;
              rpt_flr ('A', IO_RESULT)
            END
        END {wrt_tank};
        
        
      BEGIN {xfr_in}
        done := false;
        tank_idx := 0;
        REPEAT
          
                                  {Send request for next block.}
          xfr_bufr [0] := 'G';
          xfr_rslt := wrt_msg (1, xfr_bufr);
          
                                  {Diagnose transmission errors.}
          IF xfr_rslt > 0 THEN
            BEGIN
              CLOSE (xfr_file);
              err_prcsr (xfr_rslt);
              EXIT (xfr_in)
            END
          
          ELSE
            
                                  {Transmission of block request
                                  successful.  Wait for Host response and
                                  process.}
            BEGIN
              read_msg (xfr_bufr);
              IF xfr_bufr [0] = 'B' THEN
                
                                  {The expected protocol has been followed.
                                  Now interpret the IO_RESULT in the second
                                  byte.}
                BEGIN
                  IF xfr_bufr [1] = CHR (0) THEN
                    
                                  {Read at Host end successful, and block
                                  present for writing to file.}
                    BEGIN
                      tank_idx := tank_idx + 1;
                      MOVE_LEFT (xfr_bufr [2], tank [tank_idx], 512);
                      IF tank_idx = tank_size THEN
                        IF wrt_tank (tank_idx) THEN
                          tank_idx := 0
                        ELSE
                          EXIT (xfr_in)
                    END
                  
                  ELSE
                    IF xfr_bufr [1] = CHR (13) THEN
                      
                                  {File transfer completed.  Lock file and
                                  wait for next command from Host.}
                      BEGIN
                        IF tank_idx > 0 THEN
                          IF wrt_tank (tank_idx) THEN
                            ;
                        CLOSE (xfr_file, LOCK);
                        EXIT (xfr_in)
                      END
                    
                    ELSE
                      IF xfr_bufr [1] < ' ' THEN
                        
                                  {Serial line failure.  Diagnose and stop
                                  file write.}
                        BEGIN
                          CLOSE (xfr_file);
                          err_prcsr (ORD (xfr_bufr [1]));
                          EXIT (xfr_in)
                        END
                      
                      ELSE
                        
                                  {Protocol error.  Diagnose to Host and
                                  wait for next command.}
                        BEGIN
                          CLOSE (xfr_file);
                          rpt_flr ('A', 3);
                          EXIT (xfr_in)
                        END
                END
              
              ELSE
                
                                  {Protocol not followed correctly. 
                                  Diagnose to Host and terminate writing.}
                BEGIN
                  done := true;
                  CLOSE (xfr_file);
                  rpt_flr ('A', 3)
                END
            END
        UNTIL done
      END {xfr_in};
      
    BEGIN {writ_mode}
      
                                  {Attempt file creation if file name is
                                  acceptable.}
      IF ORD (xfr_bufr [1]) < 24 THEN
        BEGIN

                                  {File name is short enough to fit in
                                  string for use in RESET.  Move it into
                                  reset string; if it is valid, attempt
                                  open and report result.}
{$R-}
          MOVE_LEFT (xfr_bufr [1], file_name [0], ORD (xfr_bufr [1]) + 1);
{$R^}
          IF good_file (file_name) THEN
            BEGIN
              RESET (xfr_file, file_name);
              CASE IO_RESULT OF
                0:                {File already exists.}
                  BEGIN
                    CLOSE (xfr_file);
                    rpt_flr ('A', 11)
                  END;
                  
                10:               {Expected result--no such file.}
                  BEGIN
                    REWRITE (xfr_file, file_name);
                    IF IO_RESULT > 0 THEN
                      rpt_flr ('A', IO_RESULT)
                    ELSE
                      xfr_in
                  END;
                  
                1, 5, 6, 7, 8, 9, 16:
                                  {Expected errors.}
                  rpt_flr ('A', IO_RESULT)
              END;
            END
          
          ELSE
                                  
                                  {Report unacceptable file name.}
            rpt_flr ('A', IO_RESULT)
        END
      
      ELSE
        
                                  {Report file name too long to analyze.}
        rpt_flr ('A', IO_RESULT)
    END {writ_mode};


  PROCEDURE read_mode;
                                  {Analyze a request to read a file,
                                  following standard protocol and
                                  diagnosing failures.}
    
    VAR
      problem:               INTEGER;
                                  {Receives the result of a wrt_msg.}
                                  
    PROCEDURE xfr_out;
                                  {Send successive blocks from the open
                                  file until done or an error occurs.}
                                  
      VAR
        i:                   INTEGER;
                                  {Running index over blocks in tank.}
                                  
        tank:                file_tank;
                                  {Available material from file for
                                  transfer to host.}
                                  
        tank_idx:            INTEGER;
                                  {Number of blocks read from file.}
                                  
        xfr_rslt:            INTEGER;
                                  {Space for IO_RESULT around any
                                  operations which may change it.}
        
      FUNCTION read_tank
                                  {Read the next tank full of data from the
                                  file for transmission to host.}
                                  
       (VAR
          ct:                INTEGER):
                                  {Number of blocks read.}
                             
                             BOOLEAN;
                                  {True if transfer successful.}
        
        BEGIN {read_tank}
          read_tank := true;
          ct := BLOCK_READ (xfr_file, tank, tank_size);
          IF ct < tank_size THEN
            BEGIN
              IF IO_RESULT > 0 THEN
                BEGIN
                  read_tank := false;
                  ct := 0
                END;
              
              IF ct = 0 THEN
                CLOSE (xfr_file)
            END
        END {read_tank};
        
        
      BEGIN {xfr_out}
        read_msg (xfr_bufr);
        
        REPEAT
                                  
          IF read_tank (tank_idx) THEN
            IF tank_idx > 0 THEN
              FOR i := 1 TO tank_idx DO
                BEGIN
                                  {Analyze and process transmission
                                  failures or operator intervention.}
                  IF xfr_bufr [0] < ' ' THEN
                    BEGIN
                      err_prcsr (ORD (xfr_bufr [0]));
                      EXIT (xfr_out)
                    END
                  
                  ELSE
                    IF xfr_bufr [0] = 'G' THEN
                        
                                          {The host has requested a block so
                                          attempt to read one for it.}
                      BEGIN
                        xfr_bufr [0] := 'B';
                        xfr_bufr [1] := CHR (0);
                        MOVE_LEFT (tank [i], xfr_bufr [2], 512);
                        err_prcsr (wrt_msg (514, xfr_bufr));
                        read_msg (xfr_bufr)
                      END
                    
                    ELSE
                                  {Host did not request a block from the
                                  open file.}
                      BEGIN
                        proto_err;
                        EXIT (xfr_out)
                      END
                END
            
            ELSE
              BEGIN
                xfr_bufr [0] := 'B';
                xfr_bufr [1] := CHR (13);
                err_prcsr (wrt_msg (2, xfr_bufr));
                EXIT (xfr_out)
              END
          
          ELSE
            BEGIN
              xfr_bufr [0] := 'B';
              xfr_bufr [1] := CHR (IO_RESULT);
              err_prcsr (wrt_msg (2, xfr_bufr));
              EXIT (xfr_out)
            END
        UNTIL false;
      
      END {xfr_out};
      
      
    BEGIN {read_mode}
      
                                  {Begin initial acknowledgement message.}
      xfr_bufr [0] := 'A';
      
                                  {Attempt file open if file name is
                                  acceptable.}
      IF ORD (xfr_bufr [1]) < 24 THEN
        BEGIN

                                  {File name is short enough to fit in
                                  string for use in RESET.  Move it into
                                  reset string; if it is valid, attempt
                                  open and report result.}
{$R-}
          MOVE_LEFT (xfr_bufr [1], file_name [0], ORD (xfr_bufr [1]) + 1);
{$R^}
          IF good_file (file_name) THEN
            BEGIN
              RESET (xfr_file, file_name);
              xfr_bufr [1] := CHR (IO_RESULT)
            END
          
          ELSE
                                  
                                  {Report unacceptable file name.}
            xfr_bufr [1] := CHR (7)
        END
      
      ELSE
        
                                  {Report file name too long to analyze.}
        xfr_bufr [1] := CHR (7);

                                  {Write acknowledgement to Host.}
      problem := wrt_msg (2, xfr_bufr);
      
                                  {Complete read response protocol if no
                                  error has occurred so far.}
      IF (problem = 0) AND (xfr_bufr [1] = CHR (0)) THEN
        xfr_out
      
      ELSE
        err_prcsr (problem);
      
      CLOSE (xfr_file)
    END {read_mode};
    
    
  PROCEDURE note_obsv
                                  {Place a note on the screen informing an
                                  interested observer what the system is
                                  doing.}
                                  
     (msg:                   STRING);
                                  {Message to display.}
    
    VAR
      msg_strng:             STRING;
      
    BEGIN {note_obsv}
      
                                  {Construct a message string whose length
                                  is independent of the message to clear
                                  out residual characters.}
{$R-}
      FILL_CHAR (msg_strng [1], max_msg, ' ');
      MOVE_LEFT (msg [1], msg_strng [1], LENGTH (msg));
      msg_strng [0] := CHR (max_msg);
{$R^}
      
                                  {Place the message.}
      GO_TO_X_Y (10, 12);
      WRITE (msg_strng);
      
                                  {Move the cursor out of the way.}
      GO_TO_X_Y (0, 0)
    END {note_obsv};
    
    
  BEGIN {disk_xfr}
    head_scrn (tran_titl);
    
                                  {Establish the baud rate divisor.  First
                                  place menu of available rates on screen.}
    GO_TO_X_Y (5, 6);
    WRITE ('Available transmission rates:');
    GO_TO_X_Y (10, 8);
    WRITE ('0 -- 9600 bps');
    GO_TO_X_Y (10, 9);
    WRITE ('1 -- 4800 bps');
    GO_TO_X_Y (10, 10);
    WRITE ('2 -- 2400 bps');
    GO_TO_X_Y (10, 11);
    WRITE ('3 -- 1200 bps');
    GO_TO_X_Y (10, 12);
    WRITE ('4 --  600 bps');
    GO_TO_X_Y (5, 14);
    WRITE ('Select:');
    
                                  {Request selection and filter for
                                  plausibility.}
    REPEAT
                                  {Assume 9600 Baud if no number entered.}
      mdem_baud := 0;
      
                                  {Clear result of prior erroneous entry.}
      GO_TO_X_Y (14, 14);
      WRITE ('     ', CHR (8), CHR (8), CHR (8), CHR (8), CHR (8));
      
                                  {Get operator input and filter.}
      READ_LN (mdem_baud)
    UNTIL mdem_baud IN [0 .. 4];
    
                                  {Start the screen over again.}
    head_scrn (tran_titl);
    
                                  {Translate selection into baud rate
                                  divisor and record result.}
    GO_TO_X_Y (10, 10);
    CASE mdem_baud OF
      0:                          {9600 Baud.}
        BEGIN
          mdem_baud := 13;
          WRITE ('9600 Baud transmission.')
        END;
        
      1:                          {4800 Baud.}
        BEGIN
          mdem_baud := 26;
          WRITE ('4800 Baud transmission.')
        END;
        
      2:                          {2400 Baud.}
        BEGIN
          mdem_baud := 52;
          WRITE ('2400 Baud transmission.')
        END;
        
      3:                          {1200 Baud.}
        BEGIN
          mdem_baud := 104;
          WRITE ('1200 Baud transmission.')
        END;
        
      4:                          {600 Baud.}
        BEGIN
          mdem_baud := 208;
          WRITE ('600 Baud transmission.')
        END
    END;
    
                                  {The hunt mode loop begins here. This
                                  loop is used during initialization.}
    FILL_CHAR (xfr_bufr, SIZE_OF (xfr_bufr), CHR (0));
    note_obsv ('Waiting for Host message.');
      
                                  {Initialize the modem port to the desired
                                  baud rate.}
    mdem_init (mdem_baud);
      
                                  {Search for Host serial port.}
    done := false;
    REPEAT
      read_msg (xfr_bufr);
      done := (xfr_bufr [0] = CHR (5)) OR (xfr_bufr [0] IN
        ['D', 'E', 'R', 'W'])
    UNTIL done;
    
                                  {Serial port has come up with initial
                                  command or transfer has been aborted by
                                  operator intervention.}
    IF xfr_bufr [0] = CHR (5) THEN
          
                                  {Operator has terminated transfer.}
      note_obsv ('Operator terminated.')

    ELSE
      
      BEGIN
                                  {Initial command received.  Process
                                  commands until operator terminates or
                                  Host drops line.}
        done := false;
        REPEAT
          IF xfr_bufr [0] < ' ' THEN
            err_prcsr ( ORD (xfr_bufr [0]))
          
          ELSE
            CASE xfr_bufr [0] OF
              'D':                {Directory request.}
                BEGIN
                  note_obsv ('Sending directory.');
                  dir_mode;
                  note_obsv ('Waiting.');
                END;

              'E':                {Erase file.}
                BEGIN
                  note_obsv ('Erasing file.');
                  eras_mode;
                  note_obsv ('Waiting.');
                END;

              'R':                {Send a file.}
                BEGIN
                  note_obsv ('Sending file to Host.');
                  read_mode;
                  note_obsv ('Waiting.');
                END;

              'W':                {Recieve a file.}
                BEGIN
                  note_obsv ('Getting file from Host.');
                  writ_mode;
                  note_obsv ('Waiting.');
                END
            END;

                                  {If no fatal error has occurred, read the
                                  next message from the host and interpret
                                  it.}
          IF NOT done THEN
            read_msg (xfr_bufr);
        
        UNTIL done;
      END;
    mdem_clr
  END {disk_xfr}.


========================================================================================
DOCUMENT :usus Folder:VOL20:unlpatch.1.text
========================================================================================

(*$S+*)(*$G+*)
PROGRAM UNLPATCH;    (*version 2.4, 2 Nov 82*)
  
CONST   EVERMORE = FALSE;
        MAXMEMORY = 59;    (*block no.*)
        MAXDISK = 987;     (*block no.*)
TYPE    SNUM = STRING[7];
        BASE = 2..16;
        JEKYLLHYDE = RECORD CASE BOOLEAN OF
                       TRUE : (ADDR : INTEGER);
                       FALSE : (DATA : ^INTEGER)
                     END;
        CHAMELEON =  RECORD CASE BOOLEAN OF
                      TRUE : (CH : PACKED ARRAY[0..1] OF CHAR);
                      FALSE : (INT : INTEGER)
                    END;
        ONELINE = PACKED RECORD
                    ADDRESS : INTEGER;
                    CODE : PACKED ARRAY[0..7] OF CHAMELEON
                  END;
        NAME = STRING[24];
        CHARSET = SET OF CHAR;
VAR     FIN : FILE;
        DATA : CHAMELEON;
        WINDOW : PACKED ARRAY[0..31] OF ONELINE;
        TEMP : PACKED ARRAY[0..511] OF CHAR;
        LINENO,COLNO,UNITNO,BLKNO,START,STOP,X,Y,RADIX,BLKRADIX : INTEGER;
        BYTEBLOCK,HALFPAGE,SHOWCHARS,LOWBYTE,SHOWHEX,SHOWDEC : BOOLEAN;
        DONE,FILEBLOCK,MEMORYBLOCK,DISKBLOCK,ALTLINE,WAIT : BOOLEAN;
        REPLY : CHAR;
        SFIN : NAME;
        VISIBLE : CHARSET;
        STRG : STRING;

PROCEDURE CLEARSCREEN;
  VAR LF : PACKED ARRAY [1..24] OF CHAR;
      I : INTEGER;
  BEGIN
    GOTOXY(0,23);
    FOR I := 1 TO 24 DO LF[I] := CHR(10);
    UNITWRITE(1,LF,24);
    GOTOXY(0,0)
  END;

PROCEDURE CLEARSPACE (X,Y,N : INTEGER);
  VAR I : INTEGER;
      CS :PACKED ARRAY [1..160] OF 0..255;
  BEGIN
    GOTOXY(X,Y);
    FOR I := 1 TO N DO CS[I] := 32;
    FOR I := N+1 TO N+N DO CS[I] := 8;
    UNITWRITE(1,CS[1],N);
    UNITWRITE(1,CS[N+1],N)
  END;
  
FUNCTION COMMAND(COMMANDSET : CHARSET) : CHAR;
  VAR   REPLY : CHAR;
        SURROGATE : PACKED ARRAY [0..0] OF CHAR;
  BEGIN
    REPEAT
      UNITREAD(2,SURROGATE[0],1);
      REPLY := SURROGATE[0];
      IF REPLY IN ['a'..'z'] THEN REPLY := CHR(ORD(REPLY) - 32);
    UNTIL REPLY IN COMMANDSET;
    COMMAND := REPLY
  END;

PROCEDURE PAUSE(XCUR,YCUR : INTEGER; S : STRING);
  VAR   REPLY : CHAR;
  BEGIN
    GOTOXY(XCUR,YCUR);
    WRITE(CHR(7),S);
    REPLY := COMMAND([' ']);
    CLEARSPACE(XCUR,YCUR,LENGTH(S))
  END;
  
FUNCTION CONTINUE : BOOLEAN;
  VAR   REPLY : CHAR;
  BEGIN
    REPLY := COMMAND([' ','Q']);
    IF (REPLY = ' ') THEN CONTINUE := TRUE ELSE CONTINUE := FALSE
  END;

FUNCTION DOIT : BOOLEAN;
  VAR   REPLY : CHAR;
  BEGIN
    REPLY := COMMAND(['Y','N']);
    IF (REPLY = 'Y') THEN DOIT := TRUE ELSE DOIT := FALSE
  END;
  
PROCEDURE GETBYTESTR(VAR CHARSTR : STRING; X,Y : INTEGER); FORWARD;

PROCEDURE STRINTCONV (STRG : SNUM; VAR INT : INTEGER; RADIX : BASE;
    X,Y,LEN,MAX : INTEGER; GETSTR : BOOLEAN);
  VAR   I,RESULT : INTEGER;
        REPLY : CHAR;
        S : STRING;
  PROCEDURE ERRSIR(ERRORNO : INTEGER);
    BEGIN
      CASE ERRORNO OF
        1 : S := 'Number too large. Type <SP> to continue.';
        2 : S := ('Invalid number. Type <SP> to continue.');
      END;
      PAUSE(0,23,S);
      CLEARSPACE(X,Y,LEN);
      IF GETSTR THEN
        BEGIN
          READLN(STRG);
          STRINTCONV(STRG,INT,RADIX,X,Y,LEN,MAX,TRUE)
        END
      ELSE
        BEGIN
          GETBYTESTR(STRG,X,Y);
          STRINTCONV(STRG,INT,RADIX,X,Y,LEN,MAX,FALSE)
        END;
      EXIT(STRINTCONV)
    END;
    
  BEGIN
    IF (LENGTH(STRG) > 0) THEN
      BEGIN
        RESULT := 0;
        FOR I := 1 TO LENGTH(STRG) DO
          BEGIN
            IF ((STRG[I] IN ['0'..'9']) AND
                ((ORD(STRG[I])-ORD('0')) IN [0..RADIX])) THEN
              BEGIN
                IF (RESULT <= (MAXINT - (ORD(STRG[I]) - ORD('0'))) DIV RADIX) THEN
                  BEGIN
                    RESULT := RADIX*RESULT + ORD(STRG[I]) - ORD('0');
                    IF (RESULT > MAX) THEN ERRSIR(1)
                  END
                ELSE ERRSIR(1)
              END
            ELSE IF ((STRG[I] IN ['A'..'F']) AND (RADIX > 10) AND
              ((ORD(STRG[I])-ORD('A')+10) < RADIX)) THEN
              BEGIN
                IF (RESULT <= (MAXINT - ORD(STRG[I]) + ORD('A') - 10) DIV RADIX) THEN
                  BEGIN
                    RESULT := RADIX*RESULT + ORD(STRG[I]) - ORD('A') + 10;
                    IF (RESULT > MAX) THEN ERRSIR(1)
                  END
                ELSE ERRSIR(1)
              END
            ELSE 
              BEGIN
                ERRSIR(1)
              END
          END;
        INT := RESULT
      END
  END;
  
PROCEDURE GETRADIX(ASK : BOOLEAN);
  VAR   SRADIX : STRING;
  BEGIN
    IF ASK THEN
      BEGIN
        CLEARSPACE(0,0,80);
        WRITE('Do you want to change the current radix? <Y/N>');
        REPEAT READ(KEYBOARD,REPLY) UNTIL REPLY IN ['Y','y','N','n'];
        IF (REPLY IN ['N','n']) THEN EXIT(GETRADIX)
      END;
    REPEAT
      CLEARSPACE(0,0,80);
      WRITE('Enter new radix (8,10,16; 10 defaults to 8 for words): ');
      READLN(SRADIX)
    UNTIL ((SRADIX = '8') OR (SRADIX = '10') OR (SRADIX = '16'));
    STRINTCONV(SRADIX,RADIX,10,55,0,10,16,TRUE);
    CASE RADIX OF
       8 : BEGIN
             SHOWHEX := FALSE;
             SHOWDEC := FALSE;
           END;
      10 : BEGIN
             SHOWDEC := TRUE;
             SHOWHEX := FALSE
           END;
      16 : BEGIN
             SHOWHEX := TRUE;
             SHOWDEC := FALSE
           END
    END
  END;
      
PROCEDURE GETWORD (VAR DATA : INTEGER; X,Y : INTEGER);
 CONST BS = 8;
       ESC = 27;
       CR = 13;
 VAR   RESULT,I,RDX : INTEGER;
       CH : CHAR;
       STRG :STRING;
  PROCEDURE BADNUMBER;
    BEGIN
      CLEARSPACE(0,0,80);
      WRITE(CHR(7),'Improper number.  Current word radix = ',RDX,'. Retype. ');
      CLEARSPACE(X,Y,I);
      GETWORD(DATA,X,Y);
      CLEARSPACE(0,0,80);
      EXIT(GETWORD)
    END;
  BEGIN
    RESULT := 0;
    I := 0;
    IF (RADIX = 16) THEN RDX := 16 ELSE RDX := 8;
    REPEAT
      READ(INPUT,CH);
      IF (CH = CHR(CR)) THEN CH := ' ';
      IF (CH = CHR(BS)) THEN
        BEGIN
          IF (I > 0) THEN
            BEGIN
              WRITE(' ');
              WRITE(CHR(BS));
              I := I - 1;
              RESULT := RESULT DIV RDX
            END
          ELSE WRITE(' ')
        END
      ELSE IF ((RDX = 8) AND ((ORD(CH)-ORD('0')) IN [0..7])) OR
        ((RDX = 10) AND ((ORD(CH)-ORD('0')) IN [0..9])) THEN
        BEGIN
          I := I + 1;
          IF ((RDX = 8) AND (RESULT > 8191)) OR
            ((RDX = 10) AND ((RESULT > 6553) OR ((RESULT = 6553) AND
            ((ORD(CH)-ORD('0')) > 5)))) THEN BADNUMBER
          ELSE RESULT := RDX*RESULT + ORD(CH) - ORD('0')
        END
      ELSE IF (((RDX = 16) AND ((ORD(CH)-ORD('0')) IN [0..9])) OR
         ((ORD(CH)-ORD('A')) IN [0..5])) THEN
        BEGIN
          I := I + 1;
          IF (RESULT > 4095) THEN BADNUMBER
          ELSE
            BEGIN
              IF ((ORD(CH)-ORD('0')) IN [0..9]) THEN RESULT := RDX*RESULT + ORD(CH) - ORD('0')
              ELSE RESULT := RDX*RESULT + ORD(CH) - ORD('A') + 10
            END
        END
      ELSE IF NOT(CH IN [' ',CHR(ESC)]) THEN BADNUMBER
    UNTIL (CH IN [' ',CHR(ESC)]);
    IF (CH = ' ') THEN DONE := FALSE ELSE DONE := TRUE;
    DATA := RESULT
  END;

PROCEDURE WRITEOCTAL (DATA : INTEGER);
  
  VAR   DIVISOR : INTEGER;
        
  BEGIN
    DIVISOR := 4096;
    IF (DATA < 0) THEN
      BEGIN
        WRITE('1');
        DATA:= DATA + 32767 + 1
      END
    ELSE WRITE('0');
    REPEAT WRITE(CHR(DATA DIV DIVISOR MOD 8 + ORD('0')));
      DIVISOR := DIVISOR DIV 8
    UNTIL DIVISOR = 0
  END;
  
PROCEDURE WRITEBYTE(CH : CHAR);
  VAR NUMBER,DIVISOR : INTEGER;
  BEGIN
    NUMBER := ORD(CH);
    DIVISOR := 64;
    REPEAT
      WRITE(CHR(NUMBER DIV DIVISOR MOD 8 + ORD('0')));
      DIVISOR := DIVISOR DIV 8
    UNTIL DIVISOR = 0
  END;
  
PROCEDURE WRITEHEXBYTE(CH : CHAR);
  VAR   HEXDIGIT,NUMBER,DIVISOR : INTEGER;
  BEGIN
    NUMBER := ORD(CH);
    DIVISOR := 16;
    REPEAT
      HEXDIGIT := NUMBER DIV DIVISOR MOD 16;
      IF (HEXDIGIT IN [0..9]) THEN WRITE(CHR(HEXDIGIT+ORD('0')))
        ELSE WRITE(CHR(HEXDIGIT+ORD('A')-10));
      DIVISOR := DIVISOR DIV 16
    UNTIL DIVISOR = 0;
  END;
  
PROCEDURE WRITEDECBYTE(CH : CHAR);
  VAR   NUMBER : INTEGER;
  BEGIN
    NUMBER := ORD(CH);
    IF (NUMBER < 100) THEN WRITE('0');
    IF (NUMBER < 10) THEN WRITE('0');
    WRITE(NUMBER)
  END;

FUNCTION PEEK(ADDRESS : INTEGER): INTEGER;
  VAR   MEMORY : JEKYLLHYDE;
  BEGIN
    MEMORY.ADDR := ADDRESS;
    PEEK := MEMORY.DATA^
  END;
  
PROCEDURE POKE(ADDRESS,INFO : INTEGER);
  VAR   MEMORY : JEKYLLHYDE;
  BEGIN
    MEMORY.ADDR := ADDRESS;
    MEMORY.DATA^ := INFO
  END;

PROCEDURE GETFIN;
  VAR LEN,RSLT : INTEGER;
  BEGIN
(*$I-*)
    REPEAT
      GOTOXY(36,0);
      READLN(SFIN);
      IF (LENGTH(SFIN) = 0) THEN
        BEGIN
          CLEARSCREEN;
          EXIT(PROGRAM)
        END;
      RESET(FIN,SFIN);
      RSLT := IORESULT;
      IF RSLT <> 0 THEN
        BEGIN
          GOTOXY(0,23);
          WRITE(CHR(7),'I/O error ',RSLT:3,'.  Correct and type <SP> to continue or Q(uit');
          IF NOT CONTINUE THEN
            BEGIN
              CLEARSCREEN;
              EXIT(PROGRAM)
            END;
          CLEARSPACE(0,23,80);
          CLEARSPACE(36,0,LENGTH(SFIN))
        END
    UNTIL RSLT = 0
(*$I+*)
  END;
  
PROCEDURE GETBLKNO;
  VAR   STRG : SNUM;
        CH : CHAR;
        MAX : INTEGER;
  BEGIN
    CLEARSPACE(0,0,80);
WRITE('Current block no. radix = ',BLKRADIX:2,'. Type <SP> to accept, 8 or 10 to change: ');
    REPEAT
      READ(CH);
      IF NOT(CH IN [' ','1','8']) THEN CLEARSPACE(70,0,8)
    UNTIL (CH IN [' ','1','8']);
    STRG := ' ';
    STRG[1] := CH;
    IF (NOT (STRG = ' ')) AND (NOT (STRG = '8')) THEN
      BEGIN
        REPEAT
          READ(CH);
          IF NOT(CH = '0') THEN CLEARSPACE(71,0,7)
        UNTIL (CH = '0');
        STRG := CONCAT(STRG,'0')
      END;
    IF NOT(STRG = ' ') THEN
      BEGIN
        READLN;
        STRINTCONV(STRG,BLKRADIX,10,70,0,8,10,TRUE)
      END;
    CLEARSPACE(0,0,80);
    WRITE('Enter starting block no.: ');
    READLN(STRG);
    IF MEMORYBLK THEN MAX := MAXMEMORY ELSE MAX := MAXDISK;
    STRINTCONV(STRG,BLKNO,BLKRADIX,26,0,8,MAX,TRUE);
    CLEARSPACE(0,0,40)
  END;

(*$I-*)
PROCEDURE GETBLOCK;
  VAR   I : INTEGER;
  BEGIN
    IF EOF(FIN) THEN
      BEGIN
        CLEARSPACE(0,0,80);
        WRITELN(CHR(7),'End of file.  Do you want to continue? <Y/N>');
        IF NOT DOIT THEN EXIT(PROGRAM);
        RESET(FIN);
        GETBLKNO
      END;
    I := BLOCKREAD(FIN,TEMP,1,BLKNO);
    IF (IORESULT = 0) AND (I = 1) THEN EXIT(GETBLOCK);
    WRITELN('Block not transferred.  Type <SP> to continue or Q(uit.');
    IF NOT CONTINUE THEN
      BEGIN
        CLEARSCREEN;
        EXIT(PROGRAM)
      END;
    CLEARSCREEN;
    GETBLKNO;
    GETBLOCK
  END;
(*$I+*)

PROCEDURE GETMEMORYBLOCK;
  VAR   I,N : INTEGER;
  BEGIN
    I := 0;
    N := BLKNO*256;
    REPEAT
      DATA.INT := PEEK(N + I);
      TEMP[I] := DATA.CH[0];
      I := I + 1;
      TEMP[I] := DATA.CH[1];
      I := I + 1
    UNTIL I >= 512
  END;
  
PROCEDURE LOADMEMORY;
  VAR   I,J,K,N : INTEGER;
    BEGIN
      K := 0;
      N := BLKNO*256;
      FOR I := 0 TO 31 DO FOR J := 0 TO 7 DO
        BEGIN
          POKE((N + K),WINDOW[I].CODE[J].INT);
          K := K + 2
        END
    END;
    
PROCEDURE WRITEADDRESS(RDX : INTEGER; ADDR : INTEGER);
  VAR   DIGIT,DIVISOR : INTEGER;
  BEGIN
    DIVISOR := RDX*RDX;
    REPEAT
      DIGIT := ADDR DIV DIVISOR MOD RDX;
      IF (DIGIT IN [0..9]) THEN WRITE(CHR(DIGIT+ORD('0')))
        ELSE WRITE(CHR(DIGIT+ORD('A')-10));
      DIVISOR := DIVISOR DIV RDX
    UNTIL DIVISOR = 0;
  END;

PROCEDURE INITWINDOW;
  VAR  I,J,K : INTEGER;
  BEGIN
    K := 0;
    FOR I := 0 TO 31 DO FOR J:= 0 TO 7 DO
      BEGIN
        WINDOW[I].ADDRESS := 16*I;
        WINDOW[I].CODE[J].CH[0] := TEMP[K];
        K := K + 1;
        WINDOW[I].CODE[J].CH[1] := TEMP[K];
        K := K + 1
      END
  END;
  
PROCEDURE RELOAD;
  VAR   I,J,K : INTEGER;
  BEGIN
    K := 0;
    FOR I:= 0 TO 31 DO FOR J := 0 TO 7 DO
        BEGIN
          TEMP[K] := WINDOW[I].CODE[J].CH[0];
          K := K + 1;
          TEMP[K] := WINDOW[I].CODE[J].CH[1];
          K := K + 1
       END;
  END;
  
PROCEDURE BLOCKLINE;
  BEGIN
    WRITE('Block number ',BLKNO,'     Radix is ');
    CASE RADIX OF
      8 : WRITELN('octal');
      10 : IF BYTEBLOCK THEN WRITELN('decimal') ELSE WRITELN('octal');
      16 : WRITELN('hexadecimal')
    END;
    WRITELN
  END;
  
PROCEDURE OWTOPLINE;
  BEGIN
    WRITELN('        00     02     04     06     10     12     14     16');
    WRITELN
  END;

PROCEDURE HWTOPLINE;
  BEGIN
    WRITELN('        00     02     04     06     08     0A     0C     OE');
    WRITELN
  END;
  
PROCEDURE OBTOPLINE;
  BEGIN
    WRITELN('       00  01  02  03  04  05  06  07  10  11  12  13  14  15  16  17');
    WRITELN
  END;
  
PROCEDURE HBTOPLINE;
  BEGIN
    WRITELN('       00  01  02  03  04  05  06  07  08  09  0A  0B  0C  0D  0E  0F');
    WRITELN
  END;
  
PROCEDURE SHOWWORDS;
  VAR  J,N : INTEGER;
  BEGIN
    IF SHOWHEX THEN HWTOPLINE ELSE OWTOPLINE;
    FOR N := START TO STOP DO
      BEGIN
        WITH WINDOW[N] DO
          BEGIN
            IF (NOT SHOWHEX) THEN
              BEGIN
                WRITEADDRESS(8,ADDRESS);
                WRITE(': ');
                FOR J := 0 TO 7 DO
                  BEGIN
                    WRITE(' ');
                    WRITEOCTAL(CODE[J].INT)
                  END;
              END
            ELSE
              BEGIN
                WRITEADDRESS(16,ADDRESS);
                WRITE(': ');
                FOR J := 0 TO 7 DO
                  BEGIN
                    WRITE('  ');
                    WRITEHEXBYTE(CODE[J].CH[1]);
                    WRITEHEXBYTE(CODE[J].CH[0]);
                    WRITE(' ');
                  END;
              END;
            WRITE('  ');
            FOR J := 0 TO 7 DO
              BEGIN
                IF (CODE[J].CH[0] IN VISIBLE) THEN
                  WRITE(CODE[J].CH[0]) ELSE WRITE('.');
                IF (CODE[J].CH[1] IN VISIBLE) THEN
                  WRITE(CODE[J].CH[1]) ELSE WRITE('.')
              END;
            WRITELN
          END
      END
  END;

(*$I #5:UNLPATCH.2.TEXT*)

========================================================================================
DOCUMENT :usus Folder:VOL20:unlpatch.2.text
========================================================================================

PROCEDURE SHOWBYTES;
  VAR J,N : INTEGER;
  BEGIN
    IF SHOWHEX THEN HBTOPLINE ELSE OBTOPLINE;
    FOR N := START TO STOP DO
      BEGIN
        WITH WINDOW[N] DO
          BEGIN
            IF (NOT SHOWHEX) THEN WRITEADDRESS(8,ADDRESS)
            ELSE WRITEADDRESS(16,ADDRESS);
            WRITE(':  ');
            FOR J := 0 TO 7 DO
              BEGIN
                WITH CODE[J] DO
                  BEGIN
                    WRITE(' ');
                    IF ((CH[0] IN VISIBLE) AND (SHOWCHARS)) THEN WRITE(CH[0],'  ')
                      ELSE IF SHOWHEX THEN
                        BEGIN
                          WRITEHEXBYTE(CH[0]);
                          WRITE(' ')
                        END
                      ELSE IF SHOWDEC THEN WRITEDECBYTE(CH[0])
                      ELSE WRITEBYTE(CH[0]);
                    WRITE(' ');
                    IF ((CH[1] IN VISIBLE) AND (SHOWCHARS)) THEN WRITE(CH[1],'  ')
                      ELSE IF SHOWHEX THEN
                        BEGIN
                          WRITEHEXBYTE(CH[1]);
                          WRITE(' ')
                        END
                      ELSE IF SHOWDEC THEN WRITEDECBYTE(CH[1])
                      ELSE WRITEBYTE(CH[1])
                  END
              END;
            WRITELN
          END
      END
  END;
  
PROCEDURE DISPLAY;
  BEGIN
    CLEARSCREEN;
    IF (HALFPAGE) THEN
      BEGIN
        START := 0;
        STOP := 15;
      END
    ELSE
      BEGIN
        START := 16;
        STOP := 31
      END;
    GOTOXY(0,2);
    BLOCKLINE;
    IF BYTEBLOCK THEN SHOWBYTES ELSE SHOWWORDS;
  END;

PROCEDURE PATCH; FORWARD;
  
PROCEDURE ADVANCE;
  BEGIN
    IF LOWBYTE THEN COLNO := COLNO + 1;
    IF (COLNO > 7) THEN
      BEGIN
        IF (LINENO = 31) THEN
          BEGIN
            CLEARSPACE(0,1,80);
            CLEARSPACE(0,0,80);
            WRITE('End of block. Type <SP> to continue.');
            REPEAT READ(KEYBOARD,REPLY) UNTIL (REPLY = ' ');
            EXIT(PATCH)
          END
        ELSE IF (LINENO = 15) THEN
          BEGIN
            HALFPAGE := NOT HALFPAGE;
            DISPLAY;
            LINENO := 16;
            COLNO := 0
          END
        ELSE
          BEGIN
            COLNO := 0;
            LINENO := LINENO + 1
          END
      END
  END;

PROCEDURE PATCHWORD;
  BEGIN
    IF NOT SHOWHEX THEN X := COLNO*7 + 6 ELSE X := COLNO*7 + 7;
    IF HALFPAGE THEN Y:= LINENO + 6
      ELSE Y := LINENO - 10;
    CLEARSPACE(0,0,80);
    IF (NOT SHOWHEX) THEN
WRITE('Enter new word in XXXXXX (octal) format. <SP> continues, <ESC> terminates.')
    ELSE IF SHOWHEX THEN
WRITE('Enter new word in XXXX (hex) format. <SP> continues, <ESC> terminates.');;
    CLEARSPACE(X,Y,6);
    GETWORD(DATA.INT,X,Y);
    WINDOW[LINENO].CODE[COLNO].INT := DATA.INT;
    IF HALFPAGE THEN CLEARSPACE(63 + COLNO*2,LINENO + 6,2)
      ELSE CLEARSPACE(63 + COLNO*2,LINENO - 10,2);
    WITH WINDOW[LINENO] DO
      BEGIN
        IF (CODE[COLNO].CH[0] IN VISIBLE) THEN
          WRITE(CODE[COLNO].CH[0]) ELSE WRITE('.');
        IF (CODE[COLNO].CH[1] IN VISIBLE) THEN
          WRITE(CODE[COLNO].CH[1]) ELSE WRITE('.')
      END;
    LOWBYTE := TRUE;
    IF DONE THEN EXIT(PATCH) ELSE ADVANCE;
    PATCHWORD
  END;
  
PROCEDURE GETBYTESTR(*VAR CHARSTR : STRING; X,Y : INTEGER*);
  CONST BS = 8;
        ESC = 27;
        CR = 13;
  VAR   CH : CHAR;
        I : INTEGER;
        ONESTR : STRING[1];
  BEGIN
    I := 0;
    ONESTR := ' ';
    CHARSTR := '';
    REPEAT
      READ(INPUT,CH);
      IF (CH = CHR(CR)) THEN CH := ' ';
      IF (CH = CHR(BS)) THEN
        BEGIN
          WRITE(' ');
          IF (I > 0) THEN
            BEGIN
              WRITE(CHR(BS));
              DELETE(CHARSTR, LENGTH(CHARSTR),1);
              I := I-1
            END
        END
      ELSE IF NOT(CH IN [' ',CHR(ESC)]) THEN
        BEGIN
          I := I + 1;
          ONESTR[1] := CH;
          CHARSTR := CONCAT(CHARSTR,ONESTR)
        END;
      IF ((I = 0) AND (CH = ' ')) THEN
        BEGIN
          CHARSTR := ' ';
          CH := 'X';  (*anything but ' '*)
          I := 1
        END;
      IF (I > 3) THEN
        BEGIN
          CLEARSPACE(0,0,80);
          WRITE(CHR(7),'Byte string too long.  Retype. ');
          CLEARSPACE(X,Y,LENGTH(CHARSTR));
          GETBYTESTR(CHARSTR,X,Y);
          CLEARSPACE(0,0,80);
          EXIT(GETBYTESTR)
        END
    UNTIL (CH IN [' ',CHR(ESC)]);
    IF (CH = ' ') THEN DONE := FALSE ELSE DONE := TRUE;
  END;
  
PROCEDURE PATCHBYTE;
  LABEL 999;
  VAR   CHARSTR: SNUM;
        LEN : INTEGER;
        NUM : 0..255;
  BEGIN
    CLEARSPACE(0,0,80);
    IF SHOWCHARS THEN
      WRITELN('Enter new char in X(Ascii) or XXX(ord) format. Current radix = ',RADIX)
    ELSE IF SHOWHEX THEN
      WRITELN('Enter new byte in XX(hex) format. ')
    ELSE WRITELN('Enter new byte in XXX format. Current radix = ',RADIX);
    WRITE('     <SP> continues; <ESC> terminates');
    IF LOWBYTE THEN X := COLNO*8+7 ELSE X := COLNO*8+11;
    IF HALFPAGE THEN Y:= LINENO + 6 ELSE Y := LINENO - 10;
    CLEARSPACE(X,Y,3);
    GETBYTESTR(CHARSTR,X,Y);
    LEN := LENGTH(CHARSTR);
    IF (SHOWCHARS AND NOT (LEN IN [1,3])) OR (NOT SHOWCHARS AND NOT SHOWHEX
      AND NOT (LEN = 3)) THEN
      BEGIN
        CLEARSPACE(X,Y,7);
        WITH WINDOW[LINENO] DO
          BEGIN
            IF SHOWCHARS AND (CODE[COLNO].CH[0] IN VISIBLE) THEN WRITE(CODE[COLNO].CH[0],'  ')
              ELSE IF SHOWDEC THEN WRITEDECBYTE(CODE[COLNO].CH[0])
                ELSE WRITEBYTE(CODE[COLNO].CH[0]);
            WRITE(' ');
            IF SHOWCHARS AND (CODE[COLNO].CH[1] IN VISIBLE) THEN WRITE(CODE[COLNO].CH[1],'  ')
              ELSE IF SHOWDEC THEN WRITEDECBYTE(CODE[COLNO].CH[1])
                ELSE WRITEBYTE(CODE[COLNO].CH[1]);
            WRITE(' ');
            GOTO 999
          END
      END;
    IF SHOWCHARS OR (NOT SHOWCHARS AND NOT SHOWHEX) THEN
      IF (LEN = 3) THEN
        BEGIN
          STRINTCONV(CHARSTR,NUM,RADIX,X,Y,3,255,FALSE);
          IF LOWBYTE THEN WINDOW[LINENO].CODE[COLNO].CH[0] := CHR(NUM)
            ELSE WINDOW[LINENO].CODE[COLNO].CH[1] := CHR(NUM)
        END
      ELSE  (*IF LEN = 1*)
        BEGIN
          IF LOWBYTE THEN WINDOW[LINENO].CODE[COLNO].CH[0] := CHARSTR[1]
            ELSE WINDOW[LINENO].CODE[COLNO].CH[1] := CHARSTR[1]
        END;
    IF SHOWHEX AND NOT (LEN = 2) THEN
      BEGIN
        CLEARSPACE(X,Y,7);
        WITH WINDOW[LINENO] DO
          BEGIN
            WRITE(' ');
            WRITEHEXBYTE(CODE[COLNO].CH[0]);
            WRITE(' ');
            WRITEHEXBYTE(CODE[COLNO].CH[1]);
            GOTO 999
          END
      END;
    IF SHOWHEX AND (LEN = 2) THEN
      BEGIN
        STRINTCONV(CHARSTR,NUM,16,X,Y,3,255,FALSE);
        IF LOWBYTE THEN WINDOW[LINENO].CODE[COLNO].CH[0] := CHR(NUM)
          ELSE WINDOW[LINENO].CODE[COLNO].CH[1] := CHR(NUM)
      END;
    LOWBYTE := NOT LOWBYTE;
    IF DONE THEN EXIT(PATCH) ELSE ADVANCE;
999:  PATCHBYTE
  END;
  
PROCEDURE PATCH;
  VAR   STRG : SNUM;
        RDX : INTEGER;
  BEGIN
    CLEARSPACE(0,0,80);
    IF SHOWHEX THEN RDX := 16 ELSE RDX := 8;
    WRITE('Enter line no. of code to be changed: ');
    READLN(STRG);
    STRINTCONV(STRG,LINENO,RDX,38,0,8,496,TRUE);
    LINENO := LINENO DIV 16;
    IF HALFPAGE AND (LINENO > 15) THEN
      BEGIN
        HALFPAGE := FALSE;
        DISPLAY
      END;
    IF NOT HALFPAGE AND (LINENO < 16) THEN
      BEGIN
        HALFPAGE := TRUE;
        DISPLAY
      END;
    CLEARSPACE(0,0,80);
    WRITE('Enter column no. of code to be changed: ');
    READLN(STRG);
    STRINTCONV(STRG,COLNO,RDX,40,0,8,17,TRUE);
    IF (ODD(COLNO)) THEN LOWBYTE := FALSE ELSE LOWBYTE := TRUE;
    COLNO := COLNO DIV 2;
    CLEARSPACE(0,0,80);
    IF (BYTEBLOCK) THEN PATCHBYTE ELSE PATCHWORD;
  END;
  
PROCEDURE QUERY;
  VAR   I : INTEGER;
        S : STRING;
  BEGIN
    CLEARSCREEN;
    WRITELN('Select disposition of present block:');
    WRITELN('    W(rite patched block to disk (memory))');
    WRITELN('    E(xit leaving disk (memory) block unchanged)');
    IF (COMMAND(['E','W']) = 'W') THEN
      BEGIN
        CLEARSCREEN;
        RELOAD;
        IF DISKBLOCK THEN
          BEGIN
            UNITWRITE(UNITNO,TEMP,512,BLKNO);
            UNITREAD(UNITNO,TEMP,512,BLKNO)
          END
        ELSE IF MEMORYBLOCK THEN
          BEGIN
            LOADMEMORY;
            GETMEMORYBLOCK
          END
        ELSE
          BEGIN
            IF EOF(FIN) THEN RESET(FIN);
            I := BLOCKWRITE(FIN,TEMP,1,BLKNO);
            GETBLOCK
          END;
        INITWINDOW;
        HALFPAGE := TRUE;
        DISPLAY;
        GOTOXY(0,22);
WRITE('This is your patched block (no. ',BLKNO,') as read from  the disk (memory)');
S := ('..........................Type <SP> to continue..........................');
        PAUSE(0,23,S);
        HALFPAGE := FALSE;
        DISPLAY;
        S := 'Type <SP> to continue';
        PAUSE(0,23,S);
      END;
    CLEARSCREEN;
    HALFPAGE := TRUE
  END;

PROCEDURE DUMP;
  VAR   N,RSLT : INTEGER;
BEGIN
(*$I-*)
  REPEAT
    CLOSE(OUTPUT);
    RESET(OUTPUT,'PRINTER:');
    RSLT := IORESULT;
    IF (RSLT <> 0) THEN
      BEGIN
        RESET(OUTPUT,'CONSOLE:');
        GOTOXY(0,23);
        WRITE(CHR(7),'I/O error',RSLT:3,'. Correct and type <SP> to continue',
          'or Q(uit).');
        IF NOT CONTINUE THEN
          BEGIN
            CLEARSCREEN;
            EXIT(PROGRAM)
          END;
        CLEARSPACE(0,23,80);
      END
    UNTIL RSLT = 0;
(*$I+*)
    IF FILEBLOCK THEN WRITE('File ',SFIN,'     ');
    BLOCKLINE;
    START := 0;
    STOP := 31;
    IF BYTEBLOCK THEN SHOWBYTES ELSE SHOWWORDS;
    CLOSE(OUTPUT);
    RESET(OUTPUT,'CONSOLE:')
  END;
  
PROCEDURE BLKERROR;
  VAR  S : STRING;
  BEGIN
    CLEARSPACE(0,0,80);
    S := 'Improper block number requested. Type <SP> to continue.';
    PAUSE(0,0,S);
    GETBLKNO
  END;
  
PROCEDURE INITIALIZE;
  BEGIN
    VISIBLE := [' '..'~'];
    FILEBLOCK := TRUE;
    DISKBLOCK := FALSE;
    MEMORYBLOCK := FALSE;
    WAIT := FALSE;
    RADIX := 8;
    BLKRADIX := 10;
    CLEARSCREEN;
    WRITELN('This program displays half a block of words, bytes, or characters');
    WRITELN('from a disk or disk file or memory, accepts patches, and rewrites');
    WRITELN('the patched block to the disk or disk file or memory.');
    WRITELN;
    WRITELN('F(ile or D(isk or M(emory?');
    REPLY := COMMAND(['F','D','M']);
    CLEARSCREEN;
    IF (REPLY = 'F') THEN 
      BEGIN
        WRITE('Enter input file (or <CR> to quit): ');
        GETFIN;
        GETBLKNO;
        GETBLOCK;
      END
    ELSE IF (REPLY = 'D') THEN
      BEGIN
        WRITE('Enter unit number <4 or 5>:');
        IF (COMMAND(['4','5']) = '4') THEN UNITNO := 4 ELSE UNITNO := 5;
        GETBLKNO;
        UNITREAD(UNITNO,TEMP,512,BLKNO);
        DISKBLOCK := TRUE;
        FILEBLOCK := FALSE
      END
    ELSE
      BEGIN
WRITE('Current block no. radix = ',BLKRADIX,'. Enter memory block number: ');
        READLN(STRG);
        STRINTCONV(STRG,BLKNO,BLKRADIX,57,0,2,16,TRUE);
        GETMEMORYBLOCK;
        MEMORYBLOCK := TRUE;
        FILEBLOCK := FALSE
       END;
    CLEARSPACE(0,0,80);
    HALFPAGE := TRUE;
    INITWINDOW;
    BYTEBLOCK := FALSE;
    SHOWCHARS := FALSE;
    SHOWHEX := FALSE;
    SHOWDEC := FALSE;
  END;
  
PROCEDURE COMMANDLINE;
  BEGIN
    CLEARSPACE(0,0,80);
    IF NOT ALTLINE THEN
      WRITE('S(wap, F(orward, reV(erse, N(ewblock, P(atch, D(ump, ?')
    ELSE WRITE('W(ord, C(har, B(yte, R(adix, Q(uit, ?');
    ALTLINE := FALSE
  END;
  
BEGIN(*PROGRAM*);
  INITIALIZE;
  REPEAT
    IF NOT WAIT THEN DISPLAY;
    WAIT := FALSE;
    COMMANDLINE;
    CASE COMMAND(['B','C','D','F','N','P','Q','R','S','V','W','?']) OF 
      'S' : HALFPAGE := NOT HALFPAGE;
      'P' : PATCH;
      'D' : DUMP;
      'F' : BEGIN
              QUERY;
              BLKNO := SUCC(BLKNO);
              IF FILEBLOCK THEN IF EOF(FIN) THEN
                BEGIN
                  PAUSE(0,0,'End of file.  Type <SP> to continue.');
                  RESET(FIN);
                  GETBLKNO;
                END;
              IF ((DISKBLOCK AND (BLKNO > MAXDISK)) OR
                (MEMORYBLOCK AND (BLKNO > MAXMEMORY))) THEN BLKERROR;
              IF DISKBLOCK THEN UNITREAD(UNITNO,TEMP,512,BLKNO)
                ELSE IF MEMORYBLOCK THEN GETMEMORYBLOCK
                ELSE GETBLOCK;
              INITWINDOW
            END;
      'V' : BEGIN
              QUERY;
              BLKNO := PRED(BLKNO);
              IF (BLKNO < 0) THEN BLKERROR;
              IF FILEBLOCK THEN IF EOF(FIN) THEN RESET(FIN);
              IF DISKBLOCK THEN UNITREAD(UNITNO,TEMP,512,BLKNO)
                ELSE IF MEMORYBLOCK THEN GETMEMORYBLOCK
                ELSE GETBLOCK;
              INITWINDOW
            END;
      'N' : BEGIN
              QUERY;
              GETBLKNO;
              IF FILEBLOCK THEN IF EOF(FIN) THEN RESET(FIN);
              IF DISKBLOCK THEN UNITREAD(UNITNO,TEMP,512,BLKNO)
                ELSE IF MEMORYBLOCK THEN GETMEMORYBLOCK
                ELSE GETBLOCK;
                INITWINDOW
            END;
      'Q' : BEGIN
              QUERY;
              EXIT(PROGRAM)
            END;
      'C' : BEGIN
              BYTEBLOCK := TRUE;
              SHOWCHARS := TRUE;
              GETRADIX(TRUE)
            END;
      'W' : BEGIN
              BYTEBLOCK := FALSE;
              SHOWCHARS := FALSE;
              GETRADIX(TRUE)
            END;
      'B' : BEGIN
              BYTEBLOCK := TRUE;
              SHOWCHARS := FALSE;
              GETRADIX(TRUE)
            END;
      'R' : GETRADIX(FALSE);
      '?' : BEGIN
              ALTLINE := NOT ALTLINE;
              WAIT := TRUE
            END;
    END
  UNTIL EVERMORE
END.

========================================================================================
DOCUMENT :usus Folder:VOL20:unlpch.doc.text
========================================================================================


                           UNLPATCH

Submitted by:  Henry E. Baumgarten
               Department of Chemistry
               University of Nebraska, Lincoln
               Lincoln, Nebraska 68588-0304
               (402) 472-3301

     UNLPATCH is a patch-dump program intended to facilitate the examination,
revision (patching), and printing (dumping) of UCSD files, disks, and memory.
In its present form operations on memory are limited largely to the examin-
ation of the UNLPATCH program itself and those portions of the operating
system which are resident in memory.  This program may also be used for the
examination, patching, and dumping of RT-11 disk blocks; however, the
present version is not designed to read RT-11 directories; therefore, it
cannot be used with RT-11 files.  The program is neither as elegant nor as
bug-ridden as the UCSD PATCH program the author received with Version 2.0. It
is intended to be fairly easy to use and fairly forgiving of user blunders;
however, as with most patching operations, it is wise to back-up disks and
files before using this program.

Preparing the code file:
     
     On the author`s Heath H11A system (DEC LSI-11/2, UNL mongrel version)
using Version 2.0 of UCSD Pascal, compilation of UNLPATCH.1.TEXT gives a
runnable version of UNLPATCH.CODE (without linking)---i.e., the "software
tools" the author often uses are built into the program rather than taken from
a library.  Those persons having an editor capable of handling large files may
wish to combine UNLPATCH.1.TEXT WITH UNLPATCH.2.TEXT.  The program appears to
compile and work properly with Version 4.0 also; however, for many purposes 
the author prefers Version 2.0 over 4.0 and has not used this program 
extensively with 4.0.  Furthermore, the author has found that that Version
2.0 is sometimes more forgiving than Version 4.0; therefore, it is possible
that "bugs" not known to the author may still be lurking within. Since the
author has not had the opportunity to test this program with non-DEC
microprocessors, users should test this program carefully to determine if
their microprocessors have system-dependent idiosyncracies that will require
editing of the source. This will be especially important for those persons
having machines whose byte sex is different from that of the LSI-11 (least
significant byte goes into byte 0 of a word, most significant byte into byte
1). Making changes to accommodate different byte sexes should not be 
difficult. Making the the changes necessary to address extended memory may
be more difficult.

UNLPATCH conventions:

     Data formats allowed are bytes, words, and characters.  Data, whether 
from a file, a disk, or memory, is handled in blocks of 512 bytes.

     Radices (number bases) in this version are limited to the following.

       Disk, file, or memory blocks:   8 or 10  (starting block = 0)
       Words (16 bits):                8 or 16  (10 defaults to 8)
       Bytes (8 bits):                 8, 10, or 16
       Addresses:                      8 or 16  (10 defaults to 8)

     Characters are assumed to be ASCII-coded with non-printable char (0 to 
31, 128 to 255 (base 10)) given in byte-form in the current radix.  


========================================================================================
DOCUMENT :usus Folder:VOL20:uprcase.text
========================================================================================

PROGRAM UPPERCASE;  {Version 1.1, 26 Oct 81}

VAR CH,REPLY : CHAR;
    SFIN,SFOUT : STRING;
    FIN,FOUT : TEXT;
    I,RSLT : INTEGER;
    SKIP : BOOLEAN;

PROCEDURE CLEARSCREEN;
  VAR LF : PACKED ARRAY [1..24] OF CHAR;
       I : INTEGER;
  BEGIN
    GOTOXY(0,23);
    FOR I := 1 TO 24 DO LF[I] := CHR(10);
    UNITWRITE(1,LF,24);
    GOTOXY(0,0)
  END;
  
PROCEDURE CLEARSPACE (X,Y,N : INTEGER);
  VAR I : INTEGER;
      CS :PACKED ARRAY [1..160] OF 0..255;
  BEGIN
    GOTOXY(X,Y);
    FOR I := 1 TO N DO CS[I] := 32;
    FOR I := N+1 TO N+N DO CS[I] := 8;
    UNITWRITE(1,CS[1],N);
    UNITWRITE(1,CS[N+1],N)
  END;
  
(*$I-*)
PROCEDURE GETINFILE;
  BEGIN
    REPEAT
      BEGIN
        READLN(SFIN);
        RESET(FIN,SFIN);
        RSLT := IORESULT;
        IF RSLT <> 0 THEN
          BEGIN
            IF RSLT = 10 THEN 
              BEGIN
                SFIN := CONCAT(SFIN,'.TEXT');
                RESET(FIN,SFIN);
                RSLT := IORESULT
              END;
            IF RSLT <> 0 THEN
              BEGIN
                GOTOXY(0,20);
                WRITE('IO error',RSLT:3,'.  Correct and type <SP> to continue or Q(uit)');
                REPEAT READ (KEYBOARD, REPLY) UNTIL REPLY IN ['Q','q',' '];
                CLEARSPACE(0,20,72);
                IF REPLY IN ['Q','q'] THEN
                  BEGIN
                    CLOSE(FOUT,LOCK);
                    EXIT(PROGRAM)
                  END
                  ELSE CLEARSPACE(36,4,LENGTH(SFIN))
              END
          END
      END
    UNTIL RSLT = 0
   END;
(*$I+*)

(*$I-*)
PROCEDURE GETOUTFILE;
  BEGIN
    REPEAT
      READLN(SFOUT);
      REWRITE(FOUT,SFOUT);
      RSLT := IORESULT;
      IF RSLT <> 0 THEN
        BEGIN
          GOTOXY (0,20);
          WRITE('IO error',RSLT:3,'. Correct and type <SP> to continue or Q(uit)');
          REPEAT READ(KEYBOARD,REPLY) UNTIL REPLY IN ['Q','q',' '];
          CLEARSPACE(0,20,72);
          IF REPLY IN ['Q','q'] THEN
            BEGIN
              CLEARSCREEN;
              EXIT(PROGRAM)
            END
            ELSE CLEARSPACE(37,2,LENGTH(SFOUT))
        END
      UNTIL RSLT = 0
  END;
(*$I+*)

BEGIN
  CLEARSCREEN;
  WRITELN('This program copies files in upper case.');
  WRITELN;
  WRITE('Enter output file (upper case file): ');
  GETOUTFILE;
  WRITELN;
  WRITE('Enter input file (lower case file): ');
  GETINFILE;
  WRITELN;
  WRITELN('Lines copied');
  SKIP := FALSE;
  I := 1;
  WHILE (NOT EOF(FIN)) DO
    BEGIN
      WHILE (NOT EOLN(FIN)) DO
        BEGIN
          READ(FIN,CH);
          IF (CH IN ['''','{','}']) THEN SKIP := NOT SKIP;
          IF (CH >= 'a') AND (CH <= 'z') AND NOT SKIP THEN
            CH := CHR(ORD(CH) - 32);
          WRITE(FOUT,CH)
        END;
      READLN(FIN);
      WRITELN(FOUT);
      WRITE('.');
      IF ((I MOD 50) = 0) THEN WRITELN;
      I := I+1
    END;
  CLOSE(FOUT,LOCK);
  CLOSE(FIN)
END.

========================================================================================
DOCUMENT :usus Folder:VOL20:vol20.doc.text
========================================================================================

                             USUS Library Volume 20
  A disk patch utility, a good game, and a complete BIOS for the Jonos ESCORT

VOL20:
UNLPATCH.1.TEXT   26  The University of Nebraska Lincoln disk patch utility
UNLPATCH.2.TEXT   24    it displays its data in octal
UNLPCH.DOC.TEXT   10    doc for above
AUTOPSY.TEXT      10  Divides a file into small enough pieces for the sytem
                        Editor
SCREEN.H19.TEXT   10  A screen control unit for Autopsy
SCREEN.TEXT        6  A terminal independant version of SCREEN.H19
LWRCASE.TEXT       8  Converts a file to lower case but leaves literals intact
UPRCASE.TEXT       8    same but to upper case
HOME_LOAN.TEXT    14  A simple minded simple loan calculator
SIGFIG.19.TEXT    14  Get another "significant" figure, or maybe even more!
OTHELLO.TEXT      28  Steve Brecher's OTHELLO game, originally on Volume 3
OTHELLO.1.TEXT    26    an include file.  This game is a real killer!
BASE.TEXT          6  A numeric base converter, works nice.
H19UTIL.TEXT      24  A screen control unit for BASE.  Modify it for other 
                        terminals
NUMBER2.TEXT      12  A unit for BASE.
FASTREAD.TEXT     10  Another version of a fast string read routine.
ESCORT.DOC.TEXT    8  Documentation for the Jonos ESCORT BIOS
E.BOOT.TEXT       14 
EBIOS.TEXT         8 
BIOS.CONST.TEXT    8 
BIOS.SERPT.TEXT   22 
BIOS.DISKS.TEXT   26 
BIOS.PHONE.TEXT    4 
BIOS.DATA.TEXT    10 
SXFR.SVCS.TEXT    26 
FORMATTER.TEXT     8 
TRANSPORTR.TEXT   42 
BOOTMAKER.TEXT    10 
EBIOS-GENR.TEXT    4 
EBOOT-GENR.TEXT    4 
FMT-LINK.CODE      3 
FMT-GENR.TEXT      4 
TRANS-GENR.TEXT    4 
FORMATTER.CODE     3 
SXFR.SVCS.CODE     3 
TRANS-MGR.CODE     8 
BOOTR-GENR.TEXT    4 
BOOT.WRITE.CODE    3 
BOOTMAKER.CODE     4 
E.BOOT.CODE        3 
E.LOAD.BOOT        1 
EBIOS.CODE         7 
E.LOAD.BIOS        4 
BOOT.WRITE.TEXT   16 
VOL20.DOC.TEXT     8  You're reading it
__________________________________________________________________________
                         
Please transfer the text below to a disk label if you copy this volume.

    USUS Volume 20 -***- USUS Software Library
                         
   For not-for-profit use by USUS members only.
  May be used and distributed only according to 
      stated policy and the author's wishes.



This volume was assembled by George Schreyer from material collected by
the Library committee.

__________________________________________________________________________

Some notes from the editor:

                                    Othello

     This is a game of Othello which plays a VERY GOOD game.  It's ripped up
most self-proclaimed "experts" that have played it.  The original was on Volume
3, but since that volume has been withdrawn, I am placing it here so all USUS
members can have it.  The original also used the TIME intrinsic to pace its
moves, but I have coded that out and replaced it with a simple delay loop.  You
have to set a constant "dwell_time" to get about 2 or 3 beeps per second for
your hardware.  The value which is already there is about right for an 
LSI-11/23.  I've only beaten this game twice, its beat me at least 50 times.

                                    FastRead

     FastRead is a routine which allows you to read string info much faster than
the p-system will do it.  It has been updated and improved by Arley Dealey.

     
     
     
           The following programs were submitted by Henry Baumgarten

                                    UNLPatch

     This disk patch utility displays its output in octal for you hex haters. 
It is particularly useful for following assembler listings which list generated
code in octal, such as the RT-11 assembler.

                                    Autopsy
                                        
     Autopsy breaks a large text file into small pieces so they can be digested
by the stock system editors.  Those of you with ASE won't need it.
                                        
                              UprCase and LwrCase

     This programs do case conversions on files, but leave literals, such as
strings, alone.  This can be useful if you have recieved software where the 
case of the source is not to your liking.

                                    SigFig.19

     Some time ago a chap in Byte bemoaned the loss of one sigficant figure in
the UCSD output of real numbers.  This program fragment will recover that digit
(plus as many other---nonsignificant--- figures as your heart may desire).  Try
it by entering 1.23456789 and 1 and an output format of your choise, or compare
1 divided by any integer with the result from your HP-67 or HP-41.  More
seriously the routine used is useful for converting real numbers to strings for
using in plotting programs, etc.

                                      Base

     This is a numeric base converter to convert numbers of one base to another.
It works pretty well.  You will have to modify the screen control unit, H19UTIL
so that it works with your terminal.

                             The Jonos ESCORT BIOS

     Karl Balke wrote the BIOS for the Jonos ESCORT and was generous enough
to contribute his work to the USUS Library.  While the BIOS is machine 
specific, it is for a Z80.  This should be an excellent example of how to 
write a BIOS for other Z80 machines also.





========================================================================================
DOCUMENT :usus Folder:VOL22:contour.text
========================================================================================

{$L-  LEVEL_CURVES.LIST}

{
                        program by:  KEN GAAL (9-21-79)
                                     EDWARD J GRUNDLER (AUG 79)
                                     
     Changes made by reviewer:
        The ranges in SCREENTYPE were correct in this one!!!!!
        Changed boolean CLEAR_SCREEN to CLR_SCRN (to avoid conflict
          with procedure CLEARSCREEN).
        Replaced CHR(31) by RLF.
        Replaced CHR(29) by CEOL.
        Replaced PAGE(OUTPUT) by CLEARSCREEN.
        Added line DEFINESTRINGS to main program.
                 ---Henry E. Baumgarten
}

PROGRAM LEVEL_CURVES;

USES {$U GRAPH.LIBRARY} SCREEN_STUFF, POST_ENTRY_OF_FUNCTION;

TYPE SCREENTYPE = PACKED ARRAY[0..239,0..319] OF BOOLEAN;

VAR NEW_FUNCTION,NEW_LIMITS,CLR_SCRN,CONTOUR,SCAN_AGAIN:BOOLEAN;
    ANS,CH,DIR:CHAR;
    R,I,XAXIS,YAXIS,ERROR_COUNT,J:INTEGER;
    X,XL,XR,YL,YU,XRNG,YRNG,XINC,YINC,Y,ZV,XSEARCH,YSEARCH,XPLOT,YPLOT:REAL;
    ST:SCREENTYPE;


PROCEDURE DRAWLINE(VAR R:INTEGER;
                   VAR ST:SCREENTYPE; RW,XSTART,YSTART,DX,DY,INK:INTEGER);
EXTERNAL;

FUNCTION INPUT_VALUE:REAL;

{
                                                 function by:  EDWARD J GRUNDLER
}

VAR I:INTEGER;
    INP:STRING;
    DEC,NEX,EX,NEG,OK:BOOLEAN;
    EXPO,J,X:REAL;
BEGIN
  REPEAT
    DEC:=FALSE;
    EX:=FALSE;
    READLN(INP);
    IF LENGTH(INP)=0 THEN INP:='0';
    OK:=NOT(INP[1]='E');
    IF LENGTH(INP)>1 THEN
      OK:=OK AND NOT((INP[1] IN ['+','-','.']) AND (INP[2]='E'));
    FOR I:=1 TO LENGTH(INP) DO
      BEGIN
        OK:=OK AND (INP[I] IN ['.','-','+','E','0'..'9']);
        IF (I>1) AND NOT EX THEN OK:=OK AND (INP[I] IN ['.','E','0'..'9']);
        OK:=OK AND NOT(DEC AND(INP[I]='.'));
        IF NOT DEC THEN DEC:=(INP[I]='.');
        OK:=OK AND NOT(EX AND (INP[I]='E'));
        IF NOT EX THEN EX:=(INP[I]='E');
        IF I>1 THEN
          OK:=OK AND NOT(EX AND (INP[I] IN ['+','-']) AND NOT(INP[I-1]='E'));
        OK:=OK AND NOT(EX AND (INP[I]='.'))
      END;
    OK:=OK AND (INP[LENGTH(INP)] IN ['0'..'9','.']);
    OK:=OK AND NOT(EX AND NOT(INP[LENGTH(INP)] IN ['0'..'9']));
    IF NOT OK THEN WRITE(RLF,'READ ERROR, TRY AGAIN ',CEOL)
  UNTIL OK;
  X:=0;
  DEC:=FALSE;
  EXPO:=0;
  NEG:=FALSE;
  EX:=FALSE;
  J:=1;
  FOR I:=1 TO LENGTH(INP) DO
    BEGIN
      IF NOT DEC THEN DEC:=(INP[I]='.');
      IF NOT NEG THEN NEG:=NOT EX AND (INP[I]='-');
      IF NOT NEX THEN NEX:=EX AND (INP[I]='-');
      IF NOT EX THEN EX:=(INP[I]='E');
      IF EX AND NOT(INP[I] IN ['+','-','E']) THEN
        EXPO:=EXPO*10+ORD(INP[I])-ORD('0');
      IF NOT EX THEN
        BEGIN
          IF DEC AND NOT(INP[I] IN ['.','+','-']) THEN
            BEGIN
              J:=J/10;
              X:=X+(ORD(INP[I])-ORD('0'))*J
            END
          ELSE
            IF NOT(INP[I] IN ['.','+','-']) THEN X:=X*10+ORD(INP[I])-ORD('0')
        END
    END;
  IF EX AND NEX THEN EXPO:=-EXPO;X:=X*EXP(LN(10)*EXPO);
  IF NEG THEN INPUT_VALUE:=-X ELSE INPUT_VALUE:=X
END;

PROCEDURE HELP;
BEGIN
  CLEARSCREEN;
  WRITELN('THIS PROGRAM PLOTS THE ENTERED FUNCTION');
  WRITELN;
  WRITELN('THE OPERATOR IS ASKED FOR THE FOLLOWING INPUTS:');
  WRITELN;
  WRITELN('F(X,Y) = ');
  WRITELN('THE X,Y LIMITS FOR THE SCREEN DISPLAY');
  WRITELN('THE Z VALUE FOR THE LEVEL CURVE');
  WRITELN;
  WRITELN('press RETURN to continue');
  READLN;
  CLEARSCREEN
END;

PROCEDURE INITIALIZE;
BEGIN
  ERROR_COUNT:=0;
  GOTOXY(0,0);
  WRITE(CEOL,CHR(10),CEOL,CHR(10),CEOL,CHR(10));
  GOTOXY(0,0);
  IF NOT NEW_FUNCTION THEN
    BEGIN
      WRITE('DO YOU WANT TO ENTER A NEW FUNCTION? ');
      READ(KEYBOARD,ANS);
      NEW_FUNCTION:=ANS IN ['Y','y'];
      WRITELN
    END;
  IF NEW_FUNCTION THEN
    REPEAT
      WRITE(RLF,'F(X,Y) = ',CEOL);
      GET_FUNCTION;
      WRITE(CEOL);
      IF ERROR THEN
        CASE ERROR_CODE OF
        1:WRITELN('UNBALANCED PARENTHESES',RLF);
        2:WRITELN('UNRECOGNIZED SYMBOL',RLF);
        3:WRITELN('MULTIPLE DECIMAL POINTS IN A CONSTANT',RLF)
        END; {OF CASE}
      NEW_FUNCTION:=FALSE
    UNTIL NOT ERROR;
  IF NOT NEW_LIMITS THEN
    BEGIN
      WRITE(RLF,'DO YOU WANT NEW LIMITS ON THE DISPLAY? ',CEOL);
      READ(KEYBOARD,ANS);
      NEW_LIMITS:=ANS IN ['Y','y'];
      WRITELN
    END;
  IF NEW_LIMITS THEN
    BEGIN
      CLR_SCRN:=TRUE;
      FILLCHAR(ST,SIZEOF(ST),CHR(0));
      REPEAT
        CLEARSCREEN;
        WRITE('ENTER THE LOWER VALUE OF "X" ');
        XL:=INPUT_VALUE;
        WRITE('ENTER THE UPPER VALUE OF "X" ');
        XR:=INPUT_VALUE
      UNTIL XL<XR;
      REPEAT
        CLEARSCREEN;
        WRITE('ENTER THE LOWER VALUE OF "Y" ');
        YL:=INPUT_VALUE;
        WRITE('ENTER THE UPPER VALUE OF "Y" ');
        YU:=INPUT_VALUE
      UNTIL YL<YU
    END;
  IF NOT CLR_SCRN THEN 
    BEGIN
      WRITE(RLF,'DO YOU WANT THE SCREEN CLEARED? ',CEOL);
      READ(KEYBOARD,ANS);
      CLR_SCRN:=ANS IN ['Y','y']
    END
END;

PROCEDURE SET_SCREEN;
BEGIN
  IF CLR_SCRN THEN
    BEGIN
      FILLCHAR(ST,SIZEOF(ST),CHR(0));
      DRAWLINE(R,ST,20,59,30,201,0,1);
      DRAWLINE(R,ST,20,60,230,200,0,1);
      DRAWLINE(R,ST,20,60,30,0,200,1);
      DRAWLINE(R,ST,20,260,30,0,200,1);
      FOR I:=0 TO 10 DO DRAWLINE(R,ST,20,60,30+I*20,-3,0,1);
      FOR I:=0 TO 10 DO DRAWLINE(R,ST,20,60+I*20,230,0,3,1);
      CLR_SCRN:=FALSE
    END;
  IF NEW_LIMITS THEN
    BEGIN
      NEW_LIMITS:=FALSE;
      CLEARSCREEN;
      XRNG:=XR-XL;
      YRNG:=YU-YL;
      FOR I:=0 TO 10 DO
        BEGIN
          GOTOXY(4,3+2*I);
          WRITE(YU-I*YRNG/10:2:2)
        END;
      FOR I:=0 TO 5 DO
        BEGIN
          GOTOXY(11+10*I,23);
          WRITE(XL+I*XRNG/5:7:2);
        END
    END;
  GOTOXY(0,0); WRITE(' ':80);
  GOTOXY(15,0);
  WRITELN('Z = F(X.Y) = ',ENTERED_FUNCTION,CEOL)
END;

PROCEDURE SCAN;
VAR SEARCH: BOOLEAN;
    X1,Y1,X2,Y2,DX,DY,F1,F2: REAL;
BEGIN { procedure SCAN }
  REPEAT
    GOTOXY(20,1);
    WRITE('enter (X,Y) and direction (Up,Down,Right,Left) for search');
    GOTOXY(20,2); WRITE('X = '); XSEARCH:=INPUT_VALUE;
    GOTOXY(20,2); WRITE(' ':60);
    GOTOXY(20,2); WRITE('Y = '); YSEARCH:=INPUT_VALUE;
    GOTOXY(20,2); WRITE(' ':60);
    F1:=F(XSEARCH,YSEARCH,0);
    GOTOXY(20,1); WRITE(' ':60);
    GOTOXY(30,1);
    WRITELN('X = ',XSEARCH:8:3,'  Y= ',YSEARCH:8:3,'  F(X,Y) = ',F1:9:5);
    GOTOXY(20,2);
    WRITE('enter S for Search or N for New (X.Y) values');
    READ(KEYBOARD,CH); SEARCH:=CH IN ['S','s'];
    GOTOXY(20,2); WRITE(' ':60);
  UNTIL SEARCH;
  REPEAT
    GOTOXY(0,2); WRITE(' ':80);
    GOTOXY(20,2); WRITE('enter direction (U,D,R,L)');
    READ(KEYBOARD,DIR);
  UNTIL DIR IN ['U','D','R','L','u','d','r','l'];
  GOTOXY(20,1); WRITELN(' ':60);
  GOTOXY(0,2);  WRITELN(' ':80);
  CASE DIR OF
    'U','u': begin DX:=0; DY:=YINC end;
    'D','d': begin DX:=0; DY:=-YINC end;
    'R','r': begin DX:=XINC; DY:=0 end;
    'L','l': begin DX:=-XINC; DY:=0 end;
    END; { case }
  X1:=XSEARCH; Y1:=YSEARCH;
  F1:=F1-ZV;
  GOTOXY(20,1); WRITE('**Searching**');
  REPEAT
    X2:=X1+DX; Y2:=Y1+DY; F2:=F(X2,Y2,0)-ZV;
    GOTOXY(35,1);
    WRITE('X = ',X2:8:3,'  Y = ',Y2:8:3,'  F(X,Y) = ',F2+ZV:9:5);
    CONTOUR:= F1*F2 <= 0;
    IF NOT CONTOUR THEN begin F1:=F2; X1:=X2; Y1:=Y2 end
  UNTIL (CONTOUR or (X1<XL) or (X1>XR) or (Y1<YL) or (Y1>YU));
  IF CONTOUR THEN
    IF ABS(F1) < ABS(F2) THEN begin XPLOT:=X1; YPLOT:=Y1 end
                         ELSE begin XPLOT:=X2; YPLOT:=Y2 end;
END; { procedure SCAN }
  
PROCEDURE PLOT;
TYPE COMPASS = (E,NE,N,NW,W,SW,S,SE);
VAR XBEG,YBEG,XNEW,YNEW,PATH,NFXY,NPTS: INTEGER;
    FNEW,XTAN,YTAN,RTD,MAXERR: REAL;
    BOARDER,BEG,BLOWUP: BOOLEAN;
    CH: CHAR;
    FUN: ARRAY[COMPASS] OF REAL;
    KNOWN: SET OF COMPASS;

  FUNCTION FXY(X,Y:INTEGER):REAL;
  BEGIN
    NFXY:=NFXY+1;
    FXY:=F(XL+(X-60)*XINC,YU-(Y-30)*YINC,0) - ZV
  END;
    
  FUNCTION HEADING(X,Y:REAL):COMPASS;
  VAR ANG: REAL;
      DHEAD: INTEGER;
  BEGIN
    IF (X=0)  AND (Y>0) THEN
      begin HEADING:=N; EXIT(HEADING) end;
    IF (X=0)  AND (Y<0) THEN
      begin HEADING:=S; EXIT(HEADING) end;
    IF (X=0) AND (Y=0) THEN
      begin IF PATH=1 THEN HEADING:=N ELSE HEADING:=S;
            EXIT(HEADING)
      end;
    ANG:=ATAN(Y/X)*RTD;
    IF X<0 THEN ANG:=ANG+180;
    IF ANG<0 THEN ANG:=ANG+360;
    DHEAD:=TRUNC(ANG/45) MOD 8;
    
    (*
    GOTOXY(9,6); WRITELN('ANG,DHEAD= ',ANG:8:3,DHEAD:5);
    GOTOXY(9,7); WRITELN('XTAN,YTAN= ',X:8:3,Y:8:3);
    GOTOXY(9,8); WRITELN('FNEW=F(X,Y)-Z= ',FNEW:8:5);
    GOTOXY(9,9); WRITELN('XNEW,YNEW ',XNEW:5,YNEW:5);
    *)
    
    CASE DHEAD OF
      0: HEADING:=E;
      1: HEADING:=NE;
      2: HEADING:=N;
      3: HEADING:=NW;
      4: HEADING:=W;
      5: HEADING:=SW;
      6: HEADING:=S;
      7: HEADING:=SE;
      END;
  END; { of function HEADING }
    
  PROCEDURE INCLUDE(DIR:COMPASS);
  VAR X,Y: INTEGER;
  BEGIN
    CASE DIR OF
      NE,E,SE:  X:=XNEW+1;
      N,S:      X:=XNEW;
      NW,W,SW:  X:=XNEW-1;
      END;
    CASE DIR OF
      NW,N,NE: Y:=YNEW-1;
      W,E:     Y:=YNEW;
      SW,S,SE: Y:=YNEW+1;
      END;
    FUN[DIR]:=FXY(X,Y); KNOWN:=KNOWN+[DIR]
  END; { procedure INCLUDE }
  
  PROCEDURE TANGENT(VAR XT,YT: REAL);
  VAR DFDX,DFDY: REAL;
  BEGIN { procedure TANGENT }
    { compute partial derivatives }
    IF NOT (E IN KNOWN) THEN INCLUDE(E);
    IF NOT (N IN KNOWN) THEN INCLUDE(N);
    IF NOT (W IN KNOWN) THEN INCLUDE(W);
    IF NOT (S IN KNOWN) THEN INCLUDE(S);
    DFDX:=(FUN[E]-FUN[W])/(2*XINC);
    DFDY:=(FUN[N]-FUN[S])/(2*YINC);
    CASE PATH OF
      1: begin XT:=-DFDY; YT:=DFDX end;
      2: begin XT:=DFDY; YT:=-DFDX end;
      END;
    XT:=XT/XINC; YT:=YT/YINC
  END; { procedure TANGENT }
  
  PROCEDURE NEXT_PT(DIR: COMPASS);
  VAR ALT: COMPASS;
  
    PROCEDURE NEXT(D:COMPASS);
    VAR UPDATE: SET OF COMPASS;
    
      PROCEDURE NEWNEW(FROM,TOWARD:COMPASS);
      BEGIN
        FUN[FROM]:=FNEW; FNEW:=FUN[TOWARD];
        UPDATE:=[FROM]
      END;
      
      PROCEDURE SHIFT(DOLD,DNEW:COMPASS);
      BEGIN
        IF DOLD IN KNOWN THEN
          begin
            FUN[DNEW]:=FUN[DOLD]; UPDATE:=UPDATE + [DNEW]
          end
      END;
            
      
    BEGIN { procedure NEXT }
    UPDATE:=[ ];
    CASE D OF
      E:  begin NEWNEW(W,E); XNEW:=XNEW+1;
                SHIFT(S,SW); SHIFT(SE,S); SHIFT(N,NW); SHIFT(NE,N) end;
      NE: begin NEWNEW(SW,NE); XNEW:=XNEW+1; YNEW:=YNEW-1;
                SHIFT(N,W); SHIFT(E,S) end;
      N:  begin NEWNEW(S,N);               YNEW:=YNEW-1;
                SHIFT(W,SW); SHIFT(NW,W); SHIFT(E,SE); SHIFT(NE,E) end;
      NW: begin NEWNEW(SE,NW); XNEW:=XNEW-1; YNEW:=YNEW-1;
                SHIFT(W,S); SHIFT(N,E) end;
      W:  begin NEWNEW(E,W); XNEW:=XNEW-1; 
                SHIFT(N,NE); SHIFT(NW,N); SHIFT(S,SE); SHIFT(SW,S) end;
      SW: begin NEWNEW(NE,SW); XNEW:=XNEW-1; YNEW:=YNEW+1;
                SHIFT(W,N); SHIFT(S,E) end;
      S:  begin NEWNEW(N,S);               YNEW:=YNEW+1;
                SHIFT(W,NW); SHIFT(SW,W); SHIFT(E,NE); SHIFT(SE,E) end;
      SE: begin NEWNEW(NW,SE); XNEW:=XNEW+1; YNEW:=YNEW+1;
                SHIFT(S,W); SHIFT(E,N) end;
      END; { case }
    KNOWN:=UPDATE
    END; { procedure NEXT }
    
    
  BEGIN { procedure NEXT_PT }
    { make two candidates for next pt available }
    IF NOT (DIR IN KNOWN) THEN INCLUDE(DIR);
    IF DIR=SE THEN ALT:=E ELSE ALT:=SUCC(DIR);
    IF NOT (ALT IN KNOWN) THEN INCLUDE(ALT);
    { now select the better of the two candidates }
    IF ABS(FUN[ALT])<ABS(FUN[DIR]) THEN NEXT(ALT) ELSE NEXT(DIR);
  END; { procedure NEXT_PT }
  
BEGIN { procedure PLOT }
  CH:='A';
  NFXY:=0; NPTS:=1;
  RTD:=45/ATAN(1.0);
  MAXERR:=SQRT(SQR(XRNG)+SQR(YRNG))/10;
  GOTOXY(20,1); WRITE(' ':60);
  GOTOXY(20,1); WRITE('**Plotting**');
  PATH:=1;
  XBEG:=60+ROUND((XPLOT-XL)/XINC);
  YBEG:=30+ROUND((YU-YPLOT)/YINC);
  ST[YBEG,XBEG]:=TRUE;
  XNEW:=XBEG; YNEW:=YBEG;
  FNEW:=FXY(XNEW,YNEW);
  KNOWN:=[ ];
  REPEAT
    UNITREAD(2,CH,1,,1);
    IF UNITBUSY(2) THEN UNITCLEAR(2)
                   ELSE IF CH=CHR(27) THEN
                     begin
                       (*
                       GOTOXY(10,10);
                       WRITELN('NFXY,NPTS,NFXY/NPTS ',NFXY:6,NPTS:6,NFXY/NPTS:8:5);
                       *)
                       EXIT(PLOT)
                     end;
    TANGENT(XTAN,YTAN); { compute vector tangent to contour }
    NEXT_PT(HEADING(XTAN,YTAN)); { compute next pt to be plotted }
    BOARDER:=((XNEW<60) or (XNEW>260) or (YNEW<30) or (YNEW>230));
    BEG:=(XNEW=XBEG) AND (YNEW=YBEG);
    BLOWUP:=ABS(FNEW) >= MAXERR;
    IF BEG or ((PATH=2) and (BOARDER or BLOWUP)) THEN
      begin
        (*
        GOTOXY(10,10);
        WRITELN('NFXY,NPTS,NFXY/NPTS ',NFXY:6,NPTS:6,NFXY/NPTS:8:5);
        *)
        EXIT(PLOT)
      end;
    IF NOT (BOARDER OR BLOWUP) THEN
      begin ST[YNEW,XNEW]:=TRUE; NPTS:=NPTS+1 end;  {plot pt.}
    IF (PATH=1) AND (BOARDER or BLOWUP) THEN
      begin
        PATH:=2; KNOWN:=[ ];
        XNEW:=XBEG; YNEW:=YBEG
      end;
  UNTIL FALSE;
END; { procedure PLOT }
          
BEGIN {MAIN PROGRAM}
  DEFINESTRINGS;
  FILLCHAR(ST,SIZEOF(ST),CHR(0));
  UNITWRITE(3,ST,63);
  NEW_FUNCTION:=TRUE;
  NEW_LIMITS:=TRUE;
  CLR_SCRN:=TRUE;
  CLEARSCREEN;
  WRITELN('HELP IS AVAILABLE BY PRESSING "H" OR "?"');
  WRITELN;
  WRITELN('press SPACE to continue');
  READ(KEYBOARD,CH);
  IF CH IN ['H','h','/','?'] THEN HELP;
  REPEAT
    INITIALIZE;
    SET_SCREEN;
    XINC:=XRNG/200;
    YINC:=YRNG/200;
    IF XL*XR <= 0 THEN   { DRAW Y AXIS }
       begin
         YAXIS:=ROUND(60-XL/XINC);
         DRAWLINE(R,ST,20,YAXIS,30,0,200,1)
       end;
    IF YL*YU <= 0 THEN   { DRAW X AXIS }
       begin
         XAXIS:=ROUND(30+YU/YINC);
         DRAWLINE(R,ST,20,60,XAXIS,200,0,1)
       end;
    GOTOXY(15,1);
    WRITE('ENTER Z VALUE FOR LEVEL CURVE  ');
    ZV:=INPUT_VALUE;
    GOTOXY(0,1); WRITELN(' ':80);
    GOTOXY(3,1); WRITE('Z = ',ZV:8:3);
    SCAN_AGAIN:=TRUE;
    REPEAT
       SCAN;
       IF CONTOUR THEN PLOT;
       GOTOXY(15,2);
       WRITE('SEARCH FOR ANOTHER CONTOUR WITH Z = ',ZV:8:3,' (Y/N)');
       READ(KEYBOARD,CH); SCAN_AGAIN:=CH IN ['Y','y'];
       GOTOXY(15,2); WRITE(' ':65);
    UNTIL NOT SCAN_AGAIN;
    GOTOXY(30,2);
    WRITE('press RETURN to CONTINUE or "Q" RETURN to QUIT');
    READLN(KEYBOARD,CH);
  UNTIL CH IN ['Q','q'];
  UNITWRITE(3,ST,7);
  CLEARSCREEN
END.

========================================================================================
DOCUMENT :usus Folder:VOL22:curve_fit.text
========================================================================================

{$L- CURVE_FIT.LIST}

{
                                                  program by:  EDWARD J GRUNDLER
      Changes made by reviewer:
          Reversed ranges in type SCREEN.
          Replaced PAGE(OUTPUT) with CLEARSCREEN.
          Replaced definitions of RLF and CEOL with those in SCREEN_STUFF.
          Replaced missing unit EDS_STUFF with REAL_INPUT.
                   ___Henry E. Baumgarten
}

PROGRAM CURVE_FIT;
USES {$U GRAPH.LIBRARY} SCREEN_STUFF, REAL_INPUT;

CONST MAXIMUM_POINTS = 50;
      MAXIMUM_FUNCTIONS = 10;
      MAX_PLUS_1 = 11;
TYPE MATRIX = ARRAY[1..MAXIMUM_FUNCTIONS,1..MAX_PLUS_1] OF REAL;
     REAL_ARRAY = ARRAY[1..MAXIMUM_POINTS] OF REAL;
     SCREEN = PACKED ARRAY[0..239,0..319] OF BOOLEAN;
VAR ERROR_SUM,SQUARE_SUM:REAL;
    C,X,Y,YLS,ERROR,ERROR_SQ:REAL_ARRAY;
    R,NUMB_OF_POINTS,NUMBER_OF_FUNCTIONS:INTEGER;
    TITLE:STRING;
    ANSWER,TYPE_FUNCTION,NEW:CHAR;
    ERROR_FLAG,STARTED:BOOLEAN;
    A:MATRIX;

PROCEDURE DRAWLINE(VAR R:INTEGER; VAR S:SCREEN; RW,XS,YS,DX,DY,INK:INTEGER);
EXTERNAL;

PROCEDURE QUERY(Q:STRING);
BEGIN
  WRITELN(Q);
  REPEAT READ(KEYBOARD,ANSWER) UNTIL ANSWER IN ['Y','y','N','n']
END;

FUNCTION F(X:REAL;I:INTEGER):REAL;
  FUNCTION F1:REAL;
  BEGIN
    I:=I-1;
    IF I=0 THEN F1:=1 ELSE F1:=F1*X
  END;
BEGIN {F}
  CASE TYPE_FUNCTION OF
  'P','p':F:=F1;
  END {OF CASE}
END;

PROCEDURE DISPLAY;
VAR I:INTEGER;
    XL,XU,YL,YU,XRNG,YRNG,XINC,YINC:REAL;
    S:SCREEN;

  PROCEDURE SET_SCREEN;
  VAR J,XSTART,YSTART:INTEGER;
  BEGIN {SET_SCREEN}
    CLEARSCREEN;
    FILLCHAR(S,SIZEOF(S),CHR(0));
    UNITWRITE(3,S,63);
    FOR J:=0 TO 9 DO DRAWLINE(R,S,20,24,44+J*20,5,0,1);
    FOR J:=0 TO 10 DO DRAWLINE(R,S,20,39+J*28,229,0,-5,1);
    GOTOXY(0,4);
    FOR J:=0 TO 9 DO
      BEGIN
        WRITELN(YU-J*YRNG/9:2:2);
        IF J<>9 THEN WRITELN
      END;
    FOR J:=0 TO 10 DO
      BEGIN
        GOTOXY(3+7*J,23);
        WRITE(XL+J*XRNG/10:7:2)
      END;
    GOTOXY(0,0);
    IF ABS(319-XU/XINC)>319 THEN XSTART:=0 ELSE XSTART:=ROUND(319-XU/XINC);
    IF XSTART IN [24..319] THEN DRAWLINE(R,S,20,XSTART,39,0,190,1);
    IF ABS(44+YU/YINC)>239 THEN YSTART:=0 ELSE YSTART:=ROUND(44+YU/YINC);
    IF YSTART IN [40..229] THEN DRAWLINE(R,S,20,24,YSTART,295,0,1)
  END; {SET_SCREEN}
  
  PROCEDURE PLOT_POINTS;
  VAR XSTART,YSTART,J:INTEGER;
  BEGIN {PLOT_POINTS}
    FOR J:=1 TO NUMB_OF_POINTS DO
      BEGIN
        XSTART:=319-ROUND((XU-X[J])/XINC);
        YSTART:=ROUND((YU-Y[J])/YINC)+44;
        DRAWLINE(R,S,20,XSTART-5,YSTART+5,5,-5,1);
        DRAWLINE(R,S,20,XSTART-5,YSTART-5,5,5,1)
      END
  END; {PLOT_POINTS}
  
  PROCEDURE DRAW_CURVE;
  VAR J,K,YSTART,YSTOP:INTEGER;
      X1,Y1,X2,Y2:REAL;
  BEGIN {DRAW_CURVE}
    FOR J:=39 TO 318 DO
      BEGIN
        X1:=XL+(J-39)*XINC;
        X2:=XL+(J-38)*XINC;
        Y1:=0;
        FOR K:=1 TO NUMBER_OF_FUNCTIONS DO Y1:=Y1+C[K]*F(X1,K);
        Y2:=0;
        FOR K:=1 TO NUMBER_OF_FUNCTIONS DO Y2:=Y2+C[K]*F(X2,K);
        IF ABS(44+(YU-Y1)/YINC)>239 THEN YSTART:=0
        ELSE YSTART:=ROUND(44+(YU-Y1)/YINC);
        IF ABS(44+(YU-Y2)/YINC)>239 THEN YSTOP:=0
        ELSE YSTOP:=ROUND(44+(YU-Y2)/YINC);
        IF (YSTART IN [40..229]) AND (YSTOP IN [40..229]) THEN
        DRAWLINE(R,S,20,J,YSTART,1,YSTOP-YSTART,1)
      END
  END; {DRAW_CURVE}

BEGIN {DISPLAY}
  XL:=X[1];
  XU:=X[1];
  YL:=Y[1];
  YU:=Y[1];
  FOR I:=2 TO NUMB_OF_POINTS DO
    BEGIN
      IF X[I]<XL THEN XL:=X[I] ELSE IF X[I]>XU THEN XU:=X[I];
      IF Y[I]<YL THEN YL:=Y[I] ELSE IF Y[I]>YU THEN YU:=Y[I]
    END;
  IF (XU-XL)=0 THEN
    BEGIN
      XL:=XL-0.05;
      XU:=XU+0.05
    END
  ELSE
    BEGIN
      XL:=XL-(XU-XL)/18;
      XU:=XU+(XU-XL)/19
    END;
  XRNG:=XU-XL;
  IF (YU-YL)=0 THEN
    BEGIN
      YU:=YU+0.045;
      YL:=YL-0.045
    END
  ELSE
    BEGIN
      YL:=YL-(YU-YL)/18;
      YU:=YU+(YU-YL)/19
    END;
  YRNG:=YU-YL;
  XINC:=XRNG/280;
  YINC:=YRNG/180;
  SET_SCREEN;
  PLOT_POINTS;
  DRAW_CURVE;
  WRITE('press RETURN to continue');
  READLN;
  UNITWRITE(3,S,7)
END; {DISPLAY}
      
PROCEDURE OUTPUT_LEAST_SQUARES;
VAR I:INTEGER;
BEGIN
  FOR I:=1 TO NUMB_OF_POINTS DO
    BEGIN
      IF (I MOD 20)=1 THEN
        BEGIN
          CLEARSCREEN;
          WRITELN(' N       X(N)           Y(N)      Y=L.S.APPROX.      ',
                  'ERR=Y-Y(N)      ERR^2');
          WRITELN
        END;
      WRITELN(I:2,X[I]:15:6,Y[I]:15:6,YLS[I]:15:6,ERROR[I]:15:6,
              ERROR_SQ[I]:15:6);
      IF ((I MOD 20)=0) OR (I=NUMB_OF_POINTS) THEN
        BEGIN
          WRITE('press RETURN to continue');
          IF I=NUMB_OF_POINTS THEN
            WRITE('                  SUMS=',ERROR_SUM:15:6,SQUARE_SUM:15:6);
          READLN
        END
    END
END;

PROCEDURE LEAST_SQUARES;
VAR I,J:INTEGER;
BEGIN
  ERROR_SUM:=0;
  SQUARE_SUM:=0;
  FOR I:=1 TO NUMB_OF_POINTS DO
    BEGIN
      WRITE('.');
      YLS[I]:=0;
      FOR J:=1 TO NUMBER_OF_FUNCTIONS DO
        YLS[I]:=YLS[I]+C[J]*F(X[I],J);
      ERROR[I]:=YLS[I]-Y[I];
      ERROR_SQ[I]:=SQR(ERROR[I]);
      ERROR_SUM:=ERROR_SUM+ERROR[I];
      SQUARE_SUM:=SQUARE_SUM+ERROR_SQ[I]
    END
END;

PROCEDURE OUTPUT_C;
VAR I:INTEGER;
BEGIN
  CLEARSCREEN;
  WRITELN(TITLE);
  WRITELN;
  FOR I:=1 TO NUMBER_OF_FUNCTIONS DO
    WRITELN('C(',I:2,') = ',C[I]:12:6);
  WRITELN;
  WRITELN('press RETURN to continue')
END;

PROCEDURE GAUSS_SEIDEL;
VAR I,J,K:INTEGER;
    X,ERROR:REAL;
BEGIN {GAUSS_SEIDEL}
  K:=0;
  REPEAT
    ERROR:=0;
    K:=K+1;
    WRITE('.');
    FOR I:=1 TO NUMBER_OF_FUNCTIONS DO
      BEGIN
        X:=A[I,NUMBER_OF_FUNCTIONS+1];
        FOR J:=1 TO NUMBER_OF_FUNCTIONS DO IF NOT (J=I) THEN X:=X-A[I,J]*C[J];
        X:=X/A[I,I];
        ERROR:=ERROR+ABS(X-C[I]);
        C[I]:=X
      END;
    IF (K MOD 50)=0 THEN WRITELN
  UNTIL (ERROR=0) OR (K=150);
  FOR I:=1 TO NUMBER_OF_FUNCTIONS DO A[I,NUMBER_OF_FUNCTIONS+1]:=C[I]
END; {GAUSS_SEIDEL}

PROCEDURE ROW_ECHELON(A:MATRIX; ROWS,COLS:INTEGER);
TYPE INTEGER_ARRAY = ARRAY[1..MAX_PLUS_1] OF INTEGER;
VAR I,J,K:INTEGER;
    SCALAR:INTEGER_ARRAY;
  PROCEDURE CLEAR_COL(I,J,N:INTEGER);
  VAR K,L,M:INTEGER;
      MULT:REAL;
  BEGIN {CLEAR_COL}
    FOR K:=I TO J DO
      BEGIN
        IF A[K,N]<>0 THEN
          BEGIN
            MULT:=-A[K,N]/A[N,N];
            FOR L:=1 TO COLS DO
              A[K,L]:=A[K,L]+MULT*A[N,L]
          END
      END
  END; {CLEAR_COL}
  PROCEDURE SWAP_ROWS(I:INTEGER);
  VAR J,L,M:INTEGER;
      HOLD,MAX:REAL;
  BEGIN {SWAP_ROWS}
    MAX:=ABS(A[I,I]);
    M:=I;
    FOR J:=I+1 TO ROWS DO
      BEGIN
        IF ABS(A[J,I])>MAX THEN
          BEGIN
            MAX:=ABS(A[J,I]);
            M:=J
          END
      END;
    IF M<>I THEN
      BEGIN
        FOR L:=1 TO COLS DO
          BEGIN
            HOLD:=A[I,L];
            A[I,L]:=A[M,L];
            A[M,L]:=HOLD
          END
      END
  END; {SWAP_ROWS}
  PROCEDURE DIVIDE_ROW(I:INTEGER);
  VAR M:INTEGER;
      DIVISOR:REAL;
  BEGIN {DIVIDE_ROW}
    DIVISOR:=A[I,I];
    FOR M:=1 TO COLS DO A[I,M]:=A[I,M]/DIVISOR
  END; {DIVIDE_ROW}
  PROCEDURE UNSCALE;
  VAR I,J:INTEGER;
      X:REAL;
  BEGIN {UNSCALE}
    FOR J:=1 TO NUMBER_OF_FUNCTIONS+1 DO
      BEGIN
        X:=1;
        FOR I:=1 TO SCALAR[J] DO X:=X*2;
        FOR I:=1 TO NUMBER_OF_FUNCTIONS DO A[I,J]:=A[I,J]*X
      END
  END; {UNSCALE}
  PROCEDURE SCALE;
  VAR I,J:INTEGER;
      X:REAL;
  BEGIN {SCALE}
    FOR I:=1 TO NUMBER_OF_FUNCTIONS+1 DO SCALAR[I]:=0;
    FOR J:=1 TO NUMBER_OF_FUNCTIONS+1 DO
      BEGIN
        X:=ABS(A[1,J]);
        FOR I:=2 TO NUMBER_OF_FUNCTIONS DO IF ABS(A[I,J])>X THEN X:=ABS(A[I,J]);
        WHILE X>10 DO
          BEGIN
            SCALAR[J]:=SCALAR[J]+1;
            X:=X/2
          END;
        X:=1;
        FOR I:=1 TO SCALAR[J] DO X:=X*2;
        FOR I:=1 TO NUMBER_OF_FUNCTIONS DO A[I,J]:=A[I,J]/X
      END
  END; {SCALE}
BEGIN {ROW_ECHELON}
  SCALE;
  FOR I:=1 TO ROWS DO
    BEGIN
      WRITE('.');
      SWAP_ROWS(I);
      IF A[I,I]<>0 THEN CLEAR_COL(I+1,ROWS,I)
      ELSE
        BEGIN
          ERROR_FLAG:=TRUE;
          EXIT(ROW_ECHELON)
        END
    END;
  UNSCALE;
  FOR I:=ROWS DOWNTO 1 DO
    BEGIN
      WRITE('.');
      DIVIDE_ROW(I);
      CLEAR_COL(1,I-1,I)
    END;
  FOR I:=1 TO ROWS DO C[I]:=A[I,NUMBER_OF_FUNCTIONS+1];
  WRITELN
END; {ROW_ECHELON}

PROCEDURE B_SOLVE;
VAR I,J:INTEGER;
BEGIN
  FOR I:=1 TO NUMBER_OF_FUNCTIONS DO
    BEGIN
      WRITE('.');
      A[I,NUMBER_OF_FUNCTIONS+1]:=0;
      FOR J:=1 TO NUMB_OF_POINTS DO
        A[I,NUMBER_OF_FUNCTIONS+1]:=A[I,NUMBER_OF_FUNCTIONS+1]+F(X[J],I)*Y[J]
    END;
  WRITELN
END;

PROCEDURE A_SOLVE;
VAR I,J,K:INTEGER;
BEGIN
  FOR I:=1 TO NUMBER_OF_FUNCTIONS DO
    BEGIN
      FOR J:=1 TO NUMBER_OF_FUNCTIONS DO
        BEGIN
          WRITE('.');
          A[I,J]:=0;
          FOR K:=1 TO NUMB_OF_POINTS DO A[I,J]:=A[I,J]+F(X[K],I)*F(X[K],J)
        END;
      WRITELN
    END
END;

PROCEDURE GET_HOW_MANY;
BEGIN
  REPEAT
    CLEARSCREEN;
    WRITELN('ENTER THE NUMBER OF FUNCTIONS');
    WRITELN;
    WRITELN('FOR EXAMPLE;');
    WRITELN('IF YOU ARE SOLVING FOR A POLYNOMIAL');
    WRITELN('ENTER 3 FOR C( 1)+C( 2)X+C( 3)X^2');
    REPEAT;
      WRITE('NUMBER OF FUNCTIONS = ');
      NUMBER_OF_FUNCTIONS:=ROUND(INPUT_VALUE);
      IF NUMBER_OF_FUNCTIONS>MAXIMUM_FUNCTIONS THEN
        WRITE('MAXIMUM IS CURRENTLY ',MAXIMUM_FUNCTIONS,' ')
      ELSE
        IF NUMBER_OF_FUNCTIONS>NUMB_OF_POINTS THEN
          WRITE('ALL FUNCTIONS GREATER THAN ',NUMB_OF_POINTS,
                ' WOULD EVALUATE TO 0.  ');
    UNTIL NUMBER_OF_FUNCTIONS IN[1..NUMB_OF_POINTS];
    WRITE('NUMBER OF FUNCTIONS IS ',NUMBER_OF_FUNCTIONS);
    QUERY(' -- IS THAT CORRECT')
  UNTIL ANSWER IN ['Y','y']
END;

PROCEDURE VERIFY_DATA;
VAR I:INTEGER;
  PROCEDURE FIX_DATA;
  VAR X_OR_Y:CHAR;
      J:INTEGER;
  BEGIN {FIX_DATA}
    REPEAT
      REPEAT
        WRITELN(RLF,'DO YOU WANT TO CHANGE AN X OR Y VALUE? ',CEOL);
        READ(KEYBOARD,X_OR_Y)
      UNTIL X_OR_Y IN ['X','x','Y','y'];
      REPEAT
        WRITE(RLF,'WHICH ',X_OR_Y,' DO YOU WANT TO CHANGE? ',CEOL);
        J:=ROUND(INPUT_VALUE)
      UNTIL J IN [((I-1) DIV 20*20+1)..I];
      WRITE(RLF,'ENTER VALUE FOR ',X_OR_Y,'(',J,') ',CEOL);
      IF X_OR_Y IN ['X','x'] THEN
        BEGIN
          X[J]:=INPUT_VALUE;
          GOTOXY(2,(J-1) MOD 20+2);
          WRITE(X[J]:15:3)
        END
      ELSE
        BEGIN
          Y[J]:=INPUT_VALUE;
          GOTOXY(17,(J-1) MOD 20+2);
          WRITE(Y[J]:10:3)
        END;
      GOTOXY(0,(I-1) MOD 20+3);
      QUERY('ARE THERE ANY MORE POINTS TO CHANGE?')
    UNTIL ANSWER IN ['N','n']
  END; {FIX_DATA}
BEGIN {VERIFY_DATA}
  FOR I:=1 TO NUMB_OF_POINTS DO
    BEGIN
      IF (I MOD 20)=1 THEN
        BEGIN
          CLEARSCREEN;
          WRITELN(' I          X         Y');
          WRITELN;
        END;
      WRITELN(I:2,X[I]:15:3,Y[I]:10:3);
      IF (I=NUMB_OF_POINTS) OR ((I MOD 20)=0) THEN
        BEGIN
          QUERY('ARE ALL OF THE ABOVE DATA CORRECT?');
          IF ANSWER IN ['N','n'] THEN FIX_DATA
        END
    END
END; {VERIFY_DATA}

PROCEDURE GET_DATA;
VAR I:INTEGER;
BEGIN
  CLEARSCREEN;
  REPEAT
    REPEAT
      WRITE('HOW MANY DATA POINTS ARE THERE? ');
      NUMB_OF_POINTS:=ROUND(INPUT_VALUE);
      IF NUMB_OF_POINTS>MAXIMUM_POINTS THEN
        WRITELN('CURRENT MAXIMUM IS ',MAXIMUM_POINTS,' POINTS')
    UNTIL NUMB_OF_POINTS IN [1..MAXIMUM_POINTS];
    WRITE('NUMBER OF POINTS IS ',NUMB_OF_POINTS);
    QUERY(' -- IS THAT CORRECT?')
  UNTIL ANSWER IN ['Y','y'];
  FOR I:=1 TO NUMB_OF_POINTS DO
    BEGIN
      WRITE('ENTER THE VALUE FOR X(',I,') ');
      X[I]:=INPUT_VALUE;
      WRITE('ENTER THE VALUE FOR Y(',I,') ');
      Y[I]:=INPUT_VALUE
    END
END;

PROCEDURE NEW_OR_OLD;
BEGIN
  IF STARTED THEN
    BEGIN
      CLEARSCREEN;
      WRITE('do you want to enter N(ew data or use the O(ld data? ');
      REPEAT READ(KEYBOARD,NEW) UNTIL NEW IN ['N','n','O','o']
    END
  ELSE
    BEGIN
      STARTED:=TRUE;
      NEW:='N'
    END
END;

PROCEDURE GET_TYPE;
BEGIN
  CLEARSCREEN;
  WRITELN('THE TYPE FUNCTIONS AVAILABLE ARE:');
  WRITELN;
  WRITELN('P(olynomial');
  WRITELN;
  WRITELN('PLEASE SELECT');
  REPEAT READ(KEYBOARD,TYPE_FUNCTION) UNTIL TYPE_FUNCTION IN ['P','p']
END;

PROCEDURE GET_TITLE;
BEGIN
  REPEAT
    WRITELN('ENTER THE TITLE OF THIS CURVE ');
    READLN(TITLE);
    WRITELN(TITLE);
    QUERY('IS THAT CORRECT?')
  UNTIL ANSWER IN ['Y','y']
END;

PROCEDURE INITIALIZE;
BEGIN
  DEFINESTRINGS;
  CLEARSCREEN;
  STARTED:=FALSE;
  WRITELN('THIS PROGRAM ACCEPTS DATA POINTS, P(X,Y) AS INPUT');
  WRITELN('AND GIVES A LEAST SQUARES APPROXIMATION CURVE');
  WRITELN('FOR THE DATA.');
  WRITELN;
  WRITELN('SEVERAL OPTIONS WILL BE PRESENTED AT');
  WRITELN('APPROPRIATE TIMES.  WHEN THESE OPTIONS');
  WRITELN('ARE PRESENTED, ENTER ONLY THE UPPER CASE');
  WRITELN('LETTER.  FOR EXAMPLE:  ENTER P FOR');
  WRITELN('P(olynomial.');
  WRITELN
END;

BEGIN
  INITIALIZE;
  REPEAT
    ERROR_FLAG:=FALSE;
    GET_TITLE;
    GET_TYPE;
    NEW_OR_OLD;
    IF NEW IN ['N','n'] THEN
      BEGIN
        GET_DATA;
        VERIFY_DATA
      END;
    GET_HOW_MANY;
    A_SOLVE;
    B_SOLVE;
    ROW_ECHELON(A,NUMBER_OF_FUNCTIONS,NUMBER_OF_FUNCTIONS+1);
    GAUSS_SEIDEL;
    IF ERROR_FLAG THEN
      BEGIN
        WRITELN('THERE IS NO UNIQUE SOLUTION');
        WRITELN;
        WRITELN('press RETURN to continue');
        READLN
      END
    ELSE
      BEGIN
        OUTPUT_C;
        LEAST_SQUARES;
        READLN;
        OUTPUT_LEAST_SQUARES
      END;
    DISPLAY;
    CLEARSCREEN;
    QUERY('IS THAT THE LAST CURVE FIT?')
  UNTIL ANSWER IN ['Y','y']
END.

========================================================================================
DOCUMENT :usus Folder:VOL22:distrib.text
========================================================================================

{$S+}
{$L-DISTRIB.LIST}
PROGRAM DISTRIB;

USES {$U GRAPH.LIBRARY} SCREEN_STUFF, POST_ENTRY{ by EDWARD J GRUNDLER},
   GRAPHICS, FACTORIAL_STUFF;
   
VAR P:REAL; {probability of success.  1-P is the probability of failure}
    N:INTEGER; {number of trials}
    X1:INTEGER; {number of successes, or number of occurences}
    MU:REAL;  { the population mean }
    SIGMA:REAL; { the population standard deviation }
    VALUE:REAL; {value returned by INPUT_VALUE}
    LAST,COMMANDLN:STRING;
    OLD_XMAX,OLD_XMIN,OLD_YMAX,YMAX,XMAX,XMIN,STEP,XEND,YEND:REAL;
    HRDCPY:BOOLEAN;
    I:INTEGER;
    CH:CHAR;
    
{ Changes made by reviewer:
      Replaced missing unit DGS_STUFF by FACTORIAL_STUFF. This unit provides
        the functions LNFACTORIAL(X:INTEGER):REAL and
        LN_COMBINATION(N,X:INTEGER):REAL.
      Removed three lines
        X:=0;
        Y:=0;
        Z:=0;
        which seemed to do nothing with undefined variables (may have been
        defined in DGS_STUFF).
      Concocted FUNCTION INPUT_VALUE from FUNCTION INPUT_VALUE in UNIT
        REAL_INPUT (which see).
      Added real variable, VALUE.
      Changed CHR(29) to CEOL.
      Changed PAGE(OUTPUT) to CLEARSCREEN.
      Added DEFINESTRINGS to PROCEDURE FIRST_TIME.
      Added last two lines to FIRST_TIME and added forward reference.
                                  ---Henry E. Baumgarten}
                                  
FUNCTION INPUT_VALUE(VAR R:REAL; INP:STRING) : REAL;

VAR I,INDEX:INTEGER;
    DEC,NEX,EX,NEG,OK:BOOLEAN;
    EXPO,J:REAL;
  BEGIN
    INDEX := POS('=',INP);
    INP := COPY(INP,INDEX+1,LENGTH(INP)-INDEX);
    REPEAT
      DEC:=FALSE;
      EX:=FALSE;
      IF LENGTH(INP)=0 THEN INP:='0';
      OK:=NOT(INP[1]='E');
      IF LENGTH(INP)>1 THEN
        OK:=OK AND NOT((INP[1] IN ['+','-','.']) AND (INP[2]='E'));
      FOR I:=1 TO LENGTH(INP) DO
        BEGIN
          OK:=OK AND (INP[I] IN ['.','-','+','E','0'..'9']);
          IF (I>1) AND NOT EX THEN OK:=OK AND (INP[I] IN ['.','E','0'..'9']);
          OK:=OK AND NOT(DEC AND(INP[I]='.'));
          IF NOT DEC THEN DEC:=(INP[I]='.');
          OK:=OK AND NOT(EX AND (INP[I]='E'));
          IF NOT EX THEN EX:=(INP[I]='E');
          IF I>1 THEN
            OK:=OK AND NOT(EX AND (INP[I] IN ['+','-']) AND NOT(INP[I-1]='E'));
          OK:=OK AND NOT(EX AND (INP[I]='.'))
        END;
      OK:=OK AND (INP[LENGTH(INP)] IN ['0'..'9','.']);
      OK:=OK AND NOT(EX AND NOT(INP[LENGTH(INP)] IN ['0'..'9']));
      IF NOT OK THEN WRITE(RLF,'READ ERROR, TRY AGAIN ',CEOL)   (*****)
    UNTIL OK;
    R:=0;
    DEC:=FALSE;
    EXPO:=0;
    NEG:=FALSE;
    EX:=FALSE;
    J:=1;
    FOR I:=1 TO LENGTH(INP) DO
      BEGIN
        IF NOT DEC THEN DEC:=(INP[I]='.');
        IF NOT NEG THEN NEG:=NOT EX AND (INP[I]='-');
        IF NOT NEX THEN NEX:=EX AND (INP[I]='-');
        IF NOT EX THEN EX:=(INP[I]='E');
        IF EX AND NOT(INP[I] IN ['+','-','E']) THEN
          EXPO:=EXPO*10+ORD(INP[I])-ORD('0');
        IF NOT EX THEN
          BEGIN
            IF DEC AND NOT(INP[I] IN ['.','+','-']) THEN
              BEGIN
                J:=J/10;
                R:=R+(ORD(INP[I])-ORD('0'))*J
              END
            ELSE
              IF NOT(INP[I] IN ['.','+','-']) THEN R:=R*10+ORD(INP[I])-ORD('0')
          END
      END;
    IF EX AND NEX THEN EXPO:=-EXPO;
    R:=R*EXP(LN(10)*EXPO);
    IF NEG THEN R:=-R;
    INPUT_VALUE := R
  END;
  
PROCEDURE PREPARE_PLOT; FORWARD;

PROCEDURE FIRST_TIME;

BEGIN
  DEFINESTRINGS;
  CLEARSCREEN;
  ENTERED_FUNCTION:='0';
  LAST:='NONE';
  XMIN:=-5;
  XMAX:=5;
  YMAX:=0.4;
  MU:=1;
  SIGMA:=1;
  N:=25;
  P:=0.5;
  QUIET:=FALSE;
  SETUP(SCREEN);
  PSCALE:=6;
  HRDCPY:=FALSE;
  OLD_XMAX:=0;
  OLD_XMIN:=0;
  OLD_YMAX:=0;
  CH := 'A';
  PREPARE_PLOT;
END;

PROCEDURE SET_VARIABLE;

VAR NAME:STRING;
    RN:REAL;

BEGIN
  RN:=N;
  NAME:=COPY(COMMANDLN,1,POS('=',COMMANDLN)-1);
  IF NAME ='MU' THEN MU := INPUT_VALUE(VALUE,COMMANDLN)
  ELSE IF NAME ='SIGMA' THEN SIGMA := INPUT_VALUE(VALUE,COMMANDLN)
  ELSE IF NAME ='P' THEN P := INPUT_VALUE(VALUE,COMMANDLN)
  ELSE IF NAME ='YMAX' THEN YMAX := INPUT_VALUE(VALUE,COMMANDLN)
  ELSE IF NAME ='XMAX' THEN XMAX := INPUT_VALUE(VALUE,COMMANDLN)
  ELSE IF NAME ='XMIN' THEN XMIN := INPUT_VALUE(VALUE,COMMANDLN)
  ELSE IF NAME ='PSCALE' THEN PSCALE := INPUT_VALUE(VALUE,COMMANDLN)
  ELSE IF NAME ='N' THEN RN := INPUT_VALUE(VALUE,COMMANDLN)
  ELSE EXIT(SET_VARIABLE);
  N:=ROUND(RN);
  WRITE(NAME,' = ',VALUE:7:4,'   ',CEOL);
  IF SIGMA <= 0.0 THEN WRITE('INVALID ENTRY FOR SIGMA.  SIGMA MUST BE > 0.0',
    CEOL);
  IF (P<0.0) OR (P>1.0) THEN WRITE('P MUST BE IN THE RANGE 0.0 TO 1.0',CEOL);
END;
  
PROCEDURE HELP;

PROCEDURE FINISH_HELP;

BEGIN
  WRITELN;WRITE('press "RETURN" to continue');
  READLN;
  CLEARSCREEN;
  NEXT_FRAME(SCREEN,NO_CLEAR,ALL,ALL,NOT_DONE);
END;

BEGIN {HELP}
  NEXT_FRAME(SCREEN,NO_CLEAR,OFF,ALL,NOT_DONE);
  CLEARSCREEN;
  WRITELN('The following commands are available to the user when prompted:');
  WRITELN;WRITELN('NORMAL      for a normal distribution plot');
  WRITELN('BINOMIAL    for a binomial distribution');
  WRITELN('POISSON     for a poisson distribution');
  WRITELN('ALL or COMPARE for a comparison of all three distributions');
  WRITELN('SAME        to plot another curve of the same type as before');
  WRITELN;WRITELN('CLEARSCREEN to erase any plot on the screen');
  WRITELN('HARDCOPY    if the plotter is to draw the plot as well as the screen');
  WRITELN('VALUE       to print the value of the variables');
  WRITELN('QUIT or DONE to leave the program');
  WRITELN;WRITELN;WRITELN('The first letter of the command is sufficient'
    ,' for every one of the ');
  WRITELN('above commands with the exception of COMPARE {use A}');
  WRITELN('Follow each command with a "RETURN"');
  WRITELN;WRITELN('You may alter the value of the variables by entering the',
    ' following:');
  WRITELN('The name of the variable followed by an = then the new value');
  WRITELN('ie. XMAX=25 "RETURN"');
  FINISH_HELP;
END;

FUNCTION POISSON(X:INTEGER; MU:REAL):REAL;

VAR TEMP:REAL;

BEGIN
  IF MU=0 THEN
    BEGIN
      POISSON:=0;
      EXIT(POISSON);
    END;
  TEMP:= -MU+X*LN(MU)-LN_FACTORIAL(X);
  IF TEMP>87.4 THEN POISSON:=1.0E37 ELSE POISSON:=EXP(TEMP);
END;

FUNCTION NORMAL(X,MU,SIGMA:REAL):REAL;
  
VAR TEMP:REAL;

BEGIN
  TEMP:=-SQR(X-MU)/(2.0*SQR(SIGMA));
  IF TEMP < -20.0 THEN NORMAL:=0.0 ELSE
    NORMAL:=1/(SIGMA*SQRT(8.0*ATAN(1.0){2PI}))*EXP(TEMP)
END;

FUNCTION BINOMIAL(N,X:INTEGER; P:REAL):REAL;

VAR TEMP:REAL;

BEGIN
  IF (P=0.0) OR (P=1.0) THEN
    BEGIN
      BINOMIAL:=0.0;
      EXIT(BINOMIAL)
    END;
  TEMP:=LN_COMBINATION(N,X)+X*LN(P)+(N-X)*LN(1-P);
  IF TEMP>87.4 THEN BINOMIAL:=1.0E37 ELSE BINOMIAL:=EXP(TEMP);
END;

PROCEDURE DRAW_AXIS;

VAR I,XTEMP:INTEGER;

BEGIN
  FOR I:=0 TO 8 DO 
    BEGIN
      GOTOXY(0,4+2*I);
      WRITE(YMAX-YMAX/9*I:6:4)
    END;
  PICTURE(49,229,270,0,1);
  XTEMP:=ROUND(-XMIN*270/(XMAX-XMIN)+50);
  IF (XTEMP<320) AND (XTEMP>49) THEN PICTURE(XTEMP,29,0,200,1);
END;

PROCEDURE PREPARE_PLOT;

PROCEDURE DRAW_PLOT(FUNCTN:STRING);

PROCEDURE PLOT_IT(TYPE_OF_PLOT:STRING);

VAR YTEMP:INTEGER;
    XTEMP:INTEGER;
    CH:CHAR;

PROCEDURE GET_POINT;

FUNCTION IN_RNG(X:REAL):INTEGER;

BEGIN
  IF X>32767.0 THEN X:=32767.0;
  IF X<-32767 THEN X:=-32767;
  IN_RNG:=ROUND(X)
END;

BEGIN {GET_POINT}
  CASE CH OF
    'P' : YEND:=POISSON(ROUND(XEND),MU);
    'B' : YEND:=BINOMIAL(N,ROUND(XEND),P);
    'N' : YEND:=NORMAL(XEND,MU,SIGMA);
  END;
  XTEMP:=IN_RNG(270*(XEND-XMIN)/(XMAX-XMIN)+49);
  YTEMP:=229-IN_RNG(200.0/YMAX*YEND)
END;

BEGIN {PLOT_IT}
  CH:=TYPE_OF_PLOT[1];
  GET_POINT;
  DRAW(XTEMP,YTEMP,UP);
  WHILE XEND<=XMAX DO
    BEGIN
      XEND:=XEND+STEP;
      GET_POINT;
      GOTOXY(0,3);
      DRAW(XTEMP,YTEMP,DOWN);
      IF ESCAPE_PLOT THEN EXIT(PREPARE_PLOT)
    END
END;

BEGIN{DRAW_PLOT}
  IF (LAST='NONE') OR (COMMANDLN='') THEN EXIT(DRAW_PLOT);
  CH:=FUNCTN[1];
  IF NOT((OLD_XMAX=XMAX) AND (OLD_XMIN=XMIN) AND (OLD_YMAX=YMAX)) OR HRDCPY
    THEN BEGIN
      IF HRDCPY THEN NEXT_FRAME(BOTH,CLEAR,ALL,ALL,NOT_DONE)
        ELSE NEXT_FRAME(SCREEN,CLEAR,ALL,ALL,NOT_DONE);
      DRAW_AXIS
    END;
  OLD_XMAX:=XMAX;
  OLD_XMIN:=XMIN;
  OLD_YMAX:=YMAX;
  IF CH='N' THEN 
    BEGIN
      STEP:=(XMAX-XMIN)/270;
      XEND:=XMIN;
    END       ELSE
    BEGIN
      IF (XMAX-XMIN)/270.0 < 1.0 THEN STEP:=1 
                                 ELSE STEP:=ROUND((XMAX-XMIN)/270.0);
      IF XMIN>0.0 THEN XEND:=XMIN ELSE XEND:=0;
    END;
  GOTOXY(0,0);
  WRITE(CEOL);
  DRAW(XLOC,YLOC,NEW_COLOR);
  GOTOXY(0,1);
  WRITE(CEOL);
  GOTOXY(0,0);
  WRITELN(' I am plotting a ',FUNCTN,' curve!',CEOL);
  WRITELN;
  PLOT_IT(FUNCTN);
  DRAW(0,ROUND(ABS(239*6/PSCALE)),UP);
  HRDCPY:=FALSE;
  LAST:=FUNCTN;
END;

PROCEDURE ERROR_MESSAGE(ERR_MSSG:STRING);

BEGIN
  GOTOXY(0,1);
  WRITELN(ERR_MSSG,CEOL);
  EXIT(PREPARE_PLOT);
END;

BEGIN{ PREPARE_PLOT}
  IF XMIN>XMAX THEN ERROR_MESSAGE('XMIN must be < XMAX');
  IF SIGMA <= 0.0 THEN ERROR_MESSAGE('SIGMA must be > 0 ');
  IF (P<0.0) OR (P>1.0) THEN
    ERROR_MESSAGE('P must be between 0 and 1 inclusive');
  IF NOT(MU>0.0) AND (COMMANDLN='POISSON') THEN
    ERROR_MESSAGE('MU be >= 0 when plotting the POISSON DISTRIBUTION');
  ESCAPE_PLOT:=FALSE;
  IF CH='S' THEN CH:=LAST[1];
  CASE CH OF
    'C' : BEGIN
            NEXT_FRAME(SCREEN,CLEAR,ALL,ALL,NOT_DONE);
            DRAW_AXIS
          END;
    'H' : IF COMMANDLN='HELP' THEN HELP ELSE HRDCPY:=TRUE;
    'A' :BEGIN
           SIGMA:=SQRT(N*P*(1-P));
           MU:=N*P;
           YMAX:=1/(SIGMA*SQRT(8.0*ATAN(1.0){2PI}));
           XMIN:=MU-3*SIGMA;
           XMAX:=MU+3*SIGMA;
           DRAW_PLOT('BINOMIAL');
           DRAW_PLOT('NORMAL');
           DRAW_PLOT('POISSON');
           LAST:='ALL'
         END;
    'B','N','P' : DRAW_PLOT(COMMANDLN);
    'V' : BEGIN
            NEXT_FRAME(SCREEN,NO_CLEAR,OFF,ALL,NOT_DONE);
            CLEARSCREEN;
            WRITELN('SIGMA =':20,SIGMA:10:4);
            WRITELN('MU =':20,MU:10:4);
            WRITELN('P =':20,P:10:4);
            WRITELN('N =':20,N:5);
            WRITELN;WRITELN('XMAX =':20,XMAX:10:4);
            WRITELN('XMIN =':20,XMIN:10:4);
            WRITELN('YMAX =':20,YMAX:10:4);
            WRITELN;WRITELN('PSCALE =':20,PSCALE:10:4);
            WRITELN;WRITELN;WRITELN('press RETURN to continue');
            READLN;
            CLEARSCREEN;
            NEXT_FRAME(SCREEN,NO_CLEAR,ALL,ALL,NOT_DONE);
          END;
  END
END;

BEGIN
  FIRST_TIME;
  DRAW_AXIS;
  GOTOXY(0,1);
  WRITELN('Help is available by entering HELP followed by a "RETURN" at any time');
  REPEAT
    GOTOXY(0,0);
    COMMANDLN:='';
    WRITE('YOUR COMMAND ?   ',CEOL);
    READLN(COMMANDLN);
    WRITE(CEOL);
    I:=1;
    WHILE I<= LENGTH(COMMANDLN) DO
      BEGIN
        IF COMMANDLN[I] = ' ' THEN 
          BEGIN
            DELETE(COMMANDLN,I,1);
            I:=I-1;
          END;
        I:=I+1;
      END;
      IF LENGTH(COMMANDLN)>0 THEN CH:=COMMANDLN[1];
      IF COMMANDLN='COMPARE' THEN COMMANDLN:='ALL';
      IF POS('=',COMMANDLN)>0 THEN SET_VARIABLE
                              ELSE PREPARE_PLOT;
  UNTIL CH IN ['D','Q'];
  NEXT_FRAME(BOTH,CLEAR,OFF,ALL,DONE);
  CLEARSCREEN;
END.

========================================================================================
DOCUMENT :usus Folder:VOL22:fact_stuff.text
========================================================================================

{This unit is was written by Henry E. Baumgarten to replace a unit, DGS_STUFF,
 missing in the Grundler submissions.  The exact composition of the missing unit
 is not known; thus, the routines given here could be worse (or better) than
 those in the original unit. There are several alternative ways of combining
 these procedures and functions. At present the N_FACTORIAL procedure will
 be undefined for arguments greater than 32.  There is an alternative 
 (probably better), iterative procedure for using long integers to determine n!
 in R. Clark's, "The UCSD Pascal Handbook." A recursive procedure was used here
 to avoid copyright problems. This procedure here uses integers for arguments
 up to 7 and long integers for 8 to 32. Two ways of computing ln(n!) are
 given, both of which use Stirling's approximation.  Stirling's approximation
 is described in Knuth's "Fundamental Algorithms" (Vol. 1). The function
 LN_FACTORIAL uses the N_FACTORIAL procedure for integer arguments up to 8
 and the Stirling approximation for larger arguments. In the function
 LX_FACTORIAL the Stirling approximation is also used, but with a real
 argument. The approximation appears to be fairly good, with most errors in the
 sixth digit. The function XFACTORIAL is also based on the Stirling
 approximation and appears to sufficiently accurate for use in calculating the
 gamma function, gamma(x) = (x-1)!, to 5 or 6 places. . According to Knuth,
 gamma(1.4616321450) = 0.8856031944. With 2-word reals the calculated
 gamma = 0.885602. Adding terms to the approximation might improve its accuracy
 but this was not tested. The binomial coefficents and their uses are also
 described in Knuth.  This unit was assembled in haste for review purposes and
 has been neither thoroughly tested nor carefully optimized. 
     If an out-of-range argument is used, the routines will return a value of
 zero (undefined) with F_ERROR set to TRUE and with a F_ERRORCODE set as
 follows:
          1 : argument out of range
          2 : argument too close to negative integer
          3 : not defined for negative argument}
                
 
UNIT FACTORIAL_STUFF;  {version 1.4 - 04 Jan 82}

INTERFACE

TYPE  LONGTYPE = INTEGER[36];

VAR   F_ERROR : BOOLEAN;
      F_ERRORCODE : INTEGER;
       
PROCEDURE NFACTORIAL(N : INTEGER; VAR NFACT : LONGTYPE);

FUNCTION XFACTORIAL(X : REAL) : REAL;

FUNCTION LN_FACTORIAL(N : INTEGER): REAL;

FUNCTION LX_FACTORIAL(X : REAL): REAL;

FUNCTION BINOM_COEFF(N,X : INTEGER): REAL;

FUNCTION LN_COMBINATION(N,X : INTEGER): REAL;

IMPLEMENTATION

CONST   LNSQRT2PI = 0.918938533204673;  {Values largely from Knuth, Vol. 1}
           SQRTPI = 1.772453850905516;
            SQRT2 = 1.414213562373095;

FUNCTION LONGTOREAL(LONG : LONGTYPE): REAL;
  VAR RESULT: LONGTYPE;
      RL,FRACTION : REAL;
      I : INTEGER;
      NEGNO : BOOLEAN;
  BEGIN
    NEGNO := FALSE;
    IF (LONG < 0) THEN
      BEGIN
        NEGNO := TRUE;
        LONG := -LONG
      END;
    I := 0;
    FRACTION := 0;
    IF (LONG > MAXINT) THEN
      REPEAT
        RESULT := LONG DIV 10;
        FRACTION := FRACTION + PWROFTEN(I)*TRUNC(LONG - RESULT*10);
        LONG := RESULT;
        I := I + 1;
      UNTIL (LONG < MAXINT);
    RL := TRUNC(LONG)*PWROFTEN(I) + FRACTION;
    IF NEGNO THEN RL := -RL;
    LONGTOREAL := RL
  END;
  
PROCEDURE BLUNDER(N : INTEGER);
  BEGIN
    F_ERRORCODE := N;
    F_ERROR := TRUE
  END;

FUNCTION INFACT(N : INTEGER): INTEGER; {for n <= 7 only}
  BEGIN
    F_ERROR := FALSE;
    IF N>7 THEN
      BEGIN
        BLUNDER(1);
        INFACT := 0
      END
    ELSE IF (N=0) THEN INFACT := 1
    ELSE INFACT := N*INFACT(N-1)
  END;

PROCEDURE NFACTORIAL{(N : INTEGER; VAR NFACT : LONGTYPE};
  VAR   I : INTEGER;
  BEGIN
    F_ERROR := FALSE;
    IF ((N>32) OR (N<0)) THEN
      BEGIN
        BLUNDER(1);
        NFACT := 0
      END
    ELSE IF (N=0) THEN NFACT := 1
    ELSE
      BEGIN
        IF (N<8) THEN
          BEGIN
            NFACT := INFACT(N);
            EXIT(NFACTORIAL)
          END
        ELSE NFACTORIAL(N-1,NFACT);
        NFACT := N*NFACT
      END
  END;
  
FUNCTION XFACTORIAL{(X : REAL): REAL)};
  VAR   ATEST2,XFACT : REAL;
        ATEST1,N : INTEGER;
        
  FUNCTION FACT(A:REAL; M:INTEGER): REAL;
    VAR B,BFACT : REAL;
    BEGIN
      B := A+M;
      BFACT := SQRTPI*SQRT2*EXP(LN(B)*(B+0.5)-B+(1-1/(30*B*B))/(12*B));
      FOR N := 0 TO M-1 DO BFACT := BFACT/(B-N);
      FACT := BFACT
    END;
    
  BEGIN
    F_ERROR := FALSE;
    IF ((X<=-20.0) OR (X>30.0)) THEN
      BEGIN
        BLUNDER(1);
        XFACT := 0
      END
    ELSE IF (X=0) THEN XFACT := 1
    ELSE IF (X>0) THEN XFACT := FACT(X,3)
    ELSE
      BEGIN
        ATEST1 := TRUNC(ABS(X)+0.1);
        IF (ATEST1>0) THEN
          BEGIN
            ATEST2 := ABS(ABS(X)-ATEST1);
            IF (((ATEST1 < 10) AND (ATEST2 < 0.00001)) 
            OR ((ATEST1 >= 10) AND (ATEST2 < 0.0001))) THEN
              BEGIN
                BLUNDER(2);
                XFACTORIAL := 0;
                EXIT(XFACTORIAL)
              END
          END;
        XFACT := FACT(X,TRUNC(ABS(X)+4))
      END;
    XFACTORIAL := XFACT
  END;
  
FUNCTION LXFACTORIAL{(X : REAL): REAL};
  VAR   B,LNXFACT,LNBFACT : REAL;
        N : INTEGER;
  BEGIN
    F_ERROR := FALSE;
    IF (X<0) THEN
      BEGIN
         BLUNDER(3);
         LNXFACT := 0
      END
    ELSE IF (X>10000) THEN
       BEGIN
         BLUNDER(1);
         LNXFACT := 0
       END
    ELSE IF (X=0) THEN LNXFACT := 0
    ELSE
      BEGIN
        B := X+3;
        LNBFACT := LNSQRT2PI+(LN(B)*(B+0.5))-B+(1-1/(30*B*B))/(12*B);
        FOR N := 0 TO 2 DO LNBFACT := LNBFACT-LN(B-N);
        LNXFACT := LNBFACT
      END;
    LXFACTORIAL := LNXFACT
  END;
  
FUNCTION LN_FACTORIAL{(N : INTEGER): REAL};
  VAR   RFACT : REAL;
        NFACT : LONGTYPE;
  BEGIN
    IF (N<8) THEN
        LN_FACTORIAL := LN(INFACT(N))
    ELSE LN_FACTORIAL := LX_FACTORIAL(N)
  END;

FUNCTION LN_COMBINATION{(N,X : INTEGER): REAL};
  BEGIN
    LN_COMBINATION := LN_FACTORIAL(N)-LN_FACTORIAL(N-X)-LN_FACTORIAL(X)
  END;
  
FUNCTION BINOM_COEFF{(N,X : INTEGER): REAL};
  VAR   TEMP : REAL;
  BEGIN
    TEMP := LN_COMBINATION(N,X); 
    IF (TEMP > 87.4) THEN BINOM_COEFF := 1.0E37
    ELSE BINOM_COEFF := EXP(TEMP)
  END;
  
    
END. {of unit}

========================================================================================
DOCUMENT :usus Folder:VOL22:func.text
========================================================================================

{$S+}
{$L-PLOT_FUNC.LIST}

{
                                              program by:  EDWARD J GRUNDLER
                                        modifications by:  KEN GAAL
                                        modifications by:  DENNIS E GRUNDLER
                                               edited by:  Henry E. Baumgarten
                                                           Clifford L. Bettis
   Changes made in editing and notes:
     Changed CEOL (clear_to_end_of_line) and RLF (reverse_line_feed)
       and removed these to the unit SCREEN_STUFF.  For use with the Terak
       the reviewer used Terak emulator code in SCREEN_STUFF.  RLF did not
       appear to function properly in all instances, but the screen display
       was legible. The orginal version would appear to be acceptable for the
       Terak in the TK emulator mode.
     Changed all instances of PAGE(OUTPUT) to CLEARSCREEN, which
       clears the text but not graphics portion of the screen (required
       by versions 1.5 and 2.0 from Terak). Changed the Boolean variable
       CLEAR_SCREEN to CLR_SCREEN.
     Initialized PSCALE to 6.0.  Was not initialized in original, leading
       on occasion to run-time errors depending on what was pointed to
       by PSCALE.
     Hiplot routines could not be checked on the Terak.  To test these
       the external procedures, DRAWLINE and THROTTLE, in the GRAPHICS unit
       were replaced with the commented-out procedures given there 
       (which should function acceptably but may not be as fast as the assembly
       language routines provided as intrinsics by Terak)  and all UNITWRITE's
       to unit 3 were commented out.  With these revisions the hard copy
       routines appeared to duplicate the screen output.  Note, however,
       that the plotter pen may hit the stops, and the plots are rather crude
       by current standards.  The routines are intended only for the small,
       dumb Hiplot, although they could be edited to function with any of
       the Hiplot series.
     POST_ENTRY_OF_FUNCTION may be replaced by POST_FIX if the extra features
       of the latter are desired.
     Despite assertions in the source program, the reviewers find that undefined
       values of F(X) ARE plotted (as the last defined value) and error counts
        are not reported.
}
PROGRAM FUNC;
USES {$U GRAPH.LIBRARY} SCREEN_STUFF,POST_ENTRY_OF_FUNCTION,GRAPHICS;

VAR NEW_FUNCTION,NEW_LIMITS,CLR_SCREEN,BREAK,HARDCOPY,TICK_MARKS:BOOLEAN;
    LF,ANS,CH:CHAR;
    R,I,XSTART,YSTART,YSTOP,ERROR_COUNT:INTEGER;
    X,X1,XL,XR,YL,YU,XRNG,YRNG,XINC,YINC,Y1,Y2,YTOP,YBOT,XTICK,YTICK:REAL;
    DEVICE:UNITTYPE;
    FIRST_TIME:BOOLEAN;

{  The modifications that were made by KEN GAAL served to make the number of
 dots along the X and Y axes equally proportional.  These modifications also
 changed the method of labeling the X and Y axes.  The SCREEN had boundaries
 placed upon it for a more appealing output. }
 
{  The modifications made by DENNIS E GRUNDLER were extensive modifications
 which enhanced the operation of the program considerably.  The user may now
 enter a constant expression when asked for a value (*even pi may be entered*).
   
   Many sections of the code were rewritten for clarification.  (* several of
 these modifications were fairly minor *) 
 
   The major modification was to bind in a unit (GRAPHICS) which allows the
 user to drive either the PLOTTER or the SCREEN or BOTH devices.  The unit
 gives the programmer more time to concentrate upon the program rather than
 having to figure out how to make the plot.}
 
FUNCTION INPUT_VALUE(PROMPT:STRING):REAL;

VAR SAVED_FUNCTION:STRING;

BEGIN
   SAVED_FUNCTION:=ENTERED_FUNCTION;
   WRITE(RLF,PROMPT,CEOL);
   GET_FUNCTION;
   INPUT_VALUE:=F(0,0,0);
   ENTERED_FUNCTION:=SAVED_FUNCTION;
   REPLACE_FUNCTION;
END;

PROCEDURE HELP;
BEGIN
  CLEARSCREEN;
  WRITELN('THIS PROGRAM PLOTS THE ENTERED FUNCTION');
  WRITELN;
  WRITELN('THE OPERATOR IS ASKED FOR THE FOLLOWING INPUTS:');
  WRITELN;
  WRITELN('F(X) = ');
  WRITELN('THE LOWER VALUE OF "X"');
  WRITELN('THE UPPER VALUE OF "X"');
  WRITELN('THE LOWER VALUE OF "Y"');
  WRITELN('THE UPPER VALUE OF "Y"');
  WRITELN;
  WRITELN('IF THE FUNCTION IS EVALUATED AT AN UNDEFINED POINT,');
  WRITELN('NOTHING IS PLOTTED');
  WRITELN;
  WRITELN('press RETURN to continue');
  READLN;
  CLEARSCREEN
END;

         
PROCEDURE INITIALIZE;

FUNCTION QUERY(PROMPT:STRING):BOOLEAN;

BEGIN
   WRITELN(RLF,PROMPT,CEOL);
   READ(KEYBOARD,ANS);
   QUERY:=ANS IN ['Y','y'];
END;

BEGIN {INITIALIZE}
  ERROR_COUNT:=0;
  GOTOXY(0,0);
  WRITE(CEOL,LF,CEOL,LF,CEOL);
  GOTOXY(0,0);
  IF NOT NEW_FUNCTION THEN
    BEGIN
      NEW_FUNCTION:=QUERY('DO YOU WANT TO ENTER A NEW FUNCTION? ');
    END;
  IF NEW_FUNCTION THEN
    REPEAT
      WRITE(RLF,'F(X) = ',CEOL);
      GET_FUNCTION;
      WRITE(CEOL,LF,CEOL);
      IF ERROR THEN
        CASE ERROR_CODE OF
        1:WRITELN('UNBALANCED PARENTHESES',RLF);
        2:WRITELN('UNRECOGNIZED SYMBOL',RLF);
        3:WRITELN('MULTIPLE DECIMAL POINTS IN A CONSTANT',RLF)
        END; {OF CASE}
      NEW_FUNCTION:=FALSE
    UNTIL NOT ERROR;
  GOTOXY(0,0);
  HARDCOPY:=QUERY('DO YOU WANT A HARDCOPY? ');
  IF NOT NEW_LIMITS THEN
         NEW_LIMITS:=QUERY('DO YOU WANT NEW LIMITS ON THE DISPLAY? ');
  IF NEW_LIMITS THEN
    BEGIN
      CLR_SCREEN:=TRUE;
      REPEAT
        CLEARSCREEN;
        XL:=INPUT_VALUE('ENTER THE LOWER VALUE OF "X" ');
        XR:=INPUT_VALUE('ENTER THE UPPER VALUE OF "X" ')
      UNTIL XL<XR;
      REPEAT
        CLEARSCREEN;
        YL:=INPUT_VALUE('ENTER THE LOWER VALUE OF "Y" ');
        YU:=INPUT_VALUE('ENTER THE UPPER VALUE OF "Y" ')
      UNTIL YL<YU;
      XRNG:=XR-XL;
      YRNG:=YU-YL;
      XINC:=XRNG/200;
      YINC:=YRNG/200;
      IF HARDCOPY THEN
        REPEAT
          GOTOXY(0,0);
          PSCALE:=INPUT_VALUE('SCALING FOR THE PLOTTER (6 for full size plot) = ');
        UNTIL (PSCALE>0.0) AND (PSCALE<20);
      GOTOXY(0,0);
      TICK_MARKS:=QUERY('DO YOU WANT CONTROL OF THE TICK MARKS ON THE GRAPH? ');
      IF TICK_MARKS THEN
        BEGIN
          REPEAT
            XTICK:=INPUT_VALUE('TICKS AT WHAT INTERVAL ALONG X-AXIS? ');
          UNTIL XTICK>0.0;
          REPEAT
            YTICK:=INPUT_VALUE('TICKS AT WHAT INTERVAL ALONG Y-AXIS? ');
          UNTIL YTICK>0.0;
        END;
    END;
  IF NOT CLR_SCREEN THEN 
         CLR_SCREEN:=QUERY('DO YOU WANT THE SCREEN CLEARED? ');
END;

PROCEDURE SET_SCREEN;

VAR XTEMP,YTEMP:INTEGER;
    TEMP_PSCALE:REAL;

BEGIN
  IF HARDCOPY THEN DEVICE:=BOTH ELSE DEVICE:=SCREEN;
  IF FIRST_TIME THEN
    BEGIN
      TEMP_PSCALE:=PSCALE;
      SETUP(DEVICE);
      PSCALE:=TEMP_PSCALE;
      FIRST_TIME:=FALSE;
    END
                ELSE NEXT_FRAME(DEVICE,CLR_SCREEN,ALL,ALL,NOT_DONE);
  IF CLR_SCREEN THEN
    BEGIN
      PICTURE(0,239,319,0,DOWN);
      IF ESCAPE_PLOT THEN EXIT(SET_SCREEN);
      PICTURE(319,0,-319,0,DOWN);
      IF ESCAPE_PLOT THEN EXIT(SET_SCREEN);
      PICTURE(29,24,201,0,DOWN);
      IF ESCAPE_PLOT THEN EXIT(SET_SCREEN);
      PICTURE(230,24,0,200,DOWN);
      IF ESCAPE_PLOT THEN EXIT(SET_SCREEN);
      PICTURE(230,224,-200,0,DOWN);
      IF ESCAPE_PLOT THEN EXIT(SET_SCREEN);
      PICTURE(30,224,0,-200,DOWN);
      IF XL*XR <= 0 THEN PICTURE(30+ROUND(-XL/XINC),24,0,200,DOWN);
      IF ESCAPE_PLOT THEN EXIT(SET_SCREEN);
      IF YU*YL <= 0 THEN PICTURE(230,224-ROUND(-YL/YINC),-200,0,DOWN);
      IF ESCAPE_PLOT THEN EXIT(SET_SCREEN);
      NEW_LIMITS:=FALSE;
      CLEARSCREEN;
      IF  TICK_MARK THEN
        BEGIN
          FOR I:= TRUNC(YU/YTICK) DOWNTO TRUNC(YL/YTICK) DO 
            BEGIN
              YTEMP:= 24+ROUND((I*YTICK-YL)/YINC);
              PICTURE(25,YTEMP,5,0,DOWN);
              IF ESCAPE_PLOT THEN EXIT(SET_SCREEN);
              GOTOXY(0,24-(YTEMP DIV 10));
              WRITE(I*YTICK:2:2);
            END;
          FOR I:= TRUNC(XL/XTICK) TO TRUNC(XR/XTICK) DO 
            BEGIN
              XTEMP:=30+ROUND((I*XTICK-XL)/XINC);
              PICTURE(XTEMP,229,0,-5,DOWN);
              IF ESCAPE_PLOT THEN EXIT(SET_SCREEN);
              GOTOXY((XTEMP DIV 4)-3,23);
              WRITE(I*XTICK:7:4);
            END;
        END
                    ELSE
        BEGIN
          FOR I:=0 TO 10 DO PICTURE(25,24+I*20,5,0,DOWN);
          IF ESCAPE_PLOT THEN EXIT(SET_SCREEN);
          FOR I:=0 TO 10 DO PICTURE(30+I*20,229,0,-5,DOWN);
          IF ESCAPE_PLOT THEN EXIT(SET_SCREEN);
          GOTOXY(0,2);
          FOR I:=0 TO 10 DO
            BEGIN
              WRITELN(YU-I*YRNG/10:2:2);
              IF I<>10 THEN WRITELN
            END;
          FOR I:=0 TO 5 DO
            BEGIN
              GOTOXY(2+10*I,23);
              WRITE(XL+I*XRNG/5:10:5);
            END
        END;
      CLR_SCREEN:=FALSE
    END;
  IF HARDCOPY THEN DRAW(XLOC,YLOC,NEW_COLOR);
  GOTOXY(0,0);
  WRITELN('F(X) = ',ENTERED_FUNCTION,CEOL);
  WRITE(CEOL);
END;

PROCEDURE TABLE;
VAR ANS: BOOLEAN;
    XSTART,DX,X: REAL;
    J: INTEGER;
    CH: CHAR;
BEGIN
  ANS:=TRUE;
  REPEAT
    GOTOXY(60,0); WRITELN('(X,F(X)) TABLE');
    GOTOXY(50,1); WRITELN('enter XSTART and X INCREMENT');
    GOTOXY(57,2); XSTART:=INPUT_VALUE('XSTART= ');
    GOTOXY(57,3); DX:=INPUT_VALUE('X INC = ');
    GOTOXY(50,1); WRITE(CEOL); 
    GOTOXY(57,2); WRITE(CEOL); GOTOXY(57,3); WRITE(CEOL);
    GOTOXY(62,1); WRITELN('X',' ':8,'F(X)');
    FOR J:=0 TO 20 DO
      begin
        GOTOXY(58,J+2); X:=XSTART+J*DX;
        WRITE(X:10:6,F(X,0,0):10:6)
      end;
    GOTOXY(60,0); WRITE(CEOL);
    GOTOXY(50,0); WRITE('another table? (Y/N)');
    READ(KEYBOARD,CH); GOTOXY(50,0); WRITE(CEOL);
    ANS:=CH IN ['Y','y'];
    FOR J:=2 TO 23 DO
      begin GOTOXY(58,J); WRITE(CEOL) end;
  UNTIL ANS=FALSE;
END;
    
FUNCTION BOUNDS(Y:REAL):REAL;
BEGIN
  IF Y>YTOP THEN BOUNDS:=YTOP ELSE BOUNDS:=Y;
  IF Y<YBOT THEN BOUNDS:=YBOT
END;

PROCEDURE PLOT_IT;

BEGIN
  YTOP:=YU+24*YINC;
  YBOT:=YL-15*YINC;
  Y1:=BOUNDS(F(XL,0,0));
  FOR I:=30 TO 229 DO
    BEGIN
      X:=XL+(I-30)*XINC;
      X1:=X+XINC;
      Y2:=BOUNDS(F(X1,0,0));
      IF ERROR THEN Y2:=Y1;
      Y1:=BOUNDS(F(X,0,0));
      IF ERROR THEN
        BEGIN
          Y1:=Y2;
          ERROR_COUNT:=ERROR_COUNT+1
        END;
      YSTART:=ROUND(224-(Y1-YL)/YINC);
      YSTOP:=ROUND(224-(Y2-YL)/YINC);
      PICTURE(I,YSTART,1,YSTOP-YSTART,DOWN);
      IF ESCAPE_PLOT THEN EXIT(PLOT_IT);
    END;
  DRAW(0,ROUND(1434/PSCALE),UP);
  IF ESCAPE_PLOT THEN EXIT(PLOT_IT);
  IF ERROR_COUNT>0 THEN
    BEGIN
      GOTOXY(0,1);
      WRITE(ERROR_COUNT,' POINT');
      IF ERROR_COUNT>1 THEN WRITE('S');
      WRITE(' NOT PLOTTED BECAUSE OF EVALUATION ERRORS')
    END;
END;


BEGIN {MAIN PROGRAM}
  PSCALE:=6.0;
  DEFINESTRINGS;
  LF:=CHR(10);
  QUIET:=FALSE;
  FIRST_TIME:=TRUE;
  NEW_FUNCTION:=TRUE;
  NEW_LIMITS:=TRUE;
  CLR_SCREEN:=TRUE;
  CLEARSCREEN;
  WRITELN('HELP IS AVAILABLE BY PRESSING "H" OR "?"');
  WRITELN;
  WRITELN('press SPACE to continue');
  READ(KEYBOARD,CH);
  IF CH IN ['H','h','/','?'] THEN HELP;
  REPEAT
    ESCAPE_PLOT:=FALSE;
    INITIALIZE;
    SET_SCREEN;
    PLOT_IT;
    GOTOXY(0,1);
    WRITE(CEOL);
    GOTOXY(30,1);
    WRITE('do you want a table of (x,F(x))? (Y/N)');
    READ(KEYBOARD,CH); GOTOXY(30,1); WRITE(CEOL);
    IF CH='Y' THEN TABLE;
    GOTOXY(40,0);
    WRITE('press RETURN to CONTINUE or "Q" to QUIT');
    READ(KEYBOARD,CH)
  UNTIL CH IN ['Q','q'];
  NEXT_FRAME(DEVICE,CLEAR,OFF,ALL,DONE);
  CLEARSCREEN
END.

========================================================================================
DOCUMENT :usus Folder:VOL22:graph.doc.text
========================================================================================

                            Terak Graphics Programs
                             
Reviewed by: Henry E. Baumgarten
             Department of Chemistry
             University of Nebraska-Lincoln
             Lincoln, Nebraska 68588-0304
                            
     The programs on this diskette were written by Edward J. Grundler, Dennis E.
Grundler, and Ken Gaal, apparently sometime in the period, 1978-1980. The
programs are intended for use with the Terak LSI-11-based computer and are
highly machine-dependent. Unfortunately, documentation for most of these
programs is not available, and several of the original units required are
missing from the package.  The brief description given here was written by the
reviewer, whose experience with the Terak has been limited to the three sessions
during which he and Clifford E. Bettis (Department of Physics, University of
Nebraska-Lincoln) attempted to run the programs on one of the Terak computers in
our undergraduate physics laboratory.  These Teraks run on version 2.0 of the
UCSD system; therefore, everything said here refers to that version.  Users of
more recent versions should make appropriate changes.

     We encountered a number of problems (besides those mentioned above) in
attempting to test these programs.  First, the Terak uses terminal emulators,
which are capable of emulating more than one conventional terminal.  The Teraks
in our physics department are set up with the "Terak terminal emulator" (which
appears to be similar in many respects to a VT-52 (or H19) terminal).  The
original programs were written for a different emulator.  Although changing to a
different emulator is not difficult (if the code files are available), it does
require maintaining a separate system disk just for these programs. Also, the
command PAGE(OUTPUT) was used in the original programs to clear the text (but
not the graphics) screen.  Apparently, this is no longer done, and certainly it
did nothing useful in our tests. Therefore, this reviewer decided to remove all
terminal-dependent code and place it in a unit called SCREEN_STUFF. Before
attempting to compile these programs and units, edit the file SCRN_STUFF to fit
your terminal emulator (or terminal), compile it, and place the code file in a
library called GRAPH.LIBRARY.

     A second problem encountered was in the array bounds for the various
definitions of a type generally called SCREENTYPE, which is used in calls to the
intrinsic DRAWLINE. In the orginal programs this type was defined as a PACKED
ARRAY[0..319,0..239] OF BOOLEAN, which is just backwards from the type
definition described in our manuals (from version 1.4 on), although even these
sources are ambiguous.  Since DRAWLINE is one of those intrinsics (written in
LSI-11/PDP-11 assembly language) that will write whereever it is directed), the
to us unexpected order of subscripts caused the program FUNC to die as soon as
DRAWLINE was called. Reversal of the array order (essentially to [Y,X])
corrected this problem. Oddly enough, two of the programs had the "correct"
order, causing us to wonder how the submitters managed to get all of the
programs to run. All of the programs on this diskette have been edited to the
order which worked for us. [In retrospect this reviewer should have placed
SCREENTYPE as a global type in SCREEN_STUFF so that it could be changed by users
in one convenient location.  To do so will require removing the type definition
from all of the programs and making certain that all DRAWLINE's use the same
TYPE.]

     Although there was no way of knowing what was in the missing units, the
reviewer attempted to assemble, edit, or (as a last resort) write these units
using more or less the same algorithms and style employed by the submitters.
These units have not been thoroughly tested, and some involve matters with which
the reviewer has had little experience.  They worked in the limited tests
carried out, but almost certainly could be improved upon.  The specific units
prepared in this way are: REAL_INPUT (based on the FUNCTION INPUT_VALUE, widely
used in these programs), PLOTTER (based on the Pascal implementation of DRAWLINE
given in the 1.5 manual---on which the Grundlers appear to base their line-
drawing routines), FACT_STUFF (based on algorithms in Knuth).

     In order to use the programs, the following procedure should work.  Edit
the file, SCRN_STUFF, and put it in the library, GRAPH.LIBRARY.  Then edit (if
necessary) the units, REAL_INPUT, POST_ENTRY, PLOTTER (must be edited to work
with your serial or parallel board or to use REMOUT with the plotter), GRAPHICS,
and FACT_STUFF, compile them, and place them in the same library on your system
disk. The comment blocks placed in the interface sections of some units have
been moved to the beginning of the unit (before the unit declaration) as
compilation with them in their original places would waste a lot of library
space (anything in the INTERFACE section will be put in the library).  Next the
individual programs can be edited (if necessary), compiled, and run in the usual
fashion.

     Because of limited access to the Teraks and the problems encountered in
testing the programs, it was not possible to test all of the programs. However,
all were compiled successfully, and some that could not be tested on the Terak
were tested on the reviewer's mongrel LSI-11/2 system, using a DMP2 Hiplot
plotter for output (something NOT recommended for the weak in heart).  If any
(brave? foolhardy?) user wants to try these programs but doesn't have a Terak,
here is how it can be done in a quick and dirty fashion.  First, set up the
plotter so it can be turned off quickly!  For any program using the units
PLOTTER or GRAPHICS and in which the hard copy option is clearly allowed, the
changes are simple.  For the former (1) Convert the DRAWLINE call from external
to a dummy procedure.  Find the line PROCEDURE DRAWLINE(...parameters...);
EXTERNAL; and change it to 
           PROCEDURE DRAWLINE(...parameters...);
             BEGIN
             END;
If the procedure THROTTLE appears as an external procedure comment it out.
(A Pascal version of THROTTLE is in one of the units but isn't needed here.)
(2) Remove (or comment out) all UNITWRITE's to unit 3 (the Terak screen). 
(3) If your computer isn't an LSI-11 or PDP-11, you will have to rewrite
PLOTTER to use REMOUT to output one char rather than the Pascal version of
assembly language provided in PLOTTER.  The program POLAR gives very good
results with the reviewer's LSI-11/2 and the DMP2 Hiplot.  If the programs uses
GRAPHICS, you will have to edit graphics following the instructions in the
graphics program, recompile, and place the unit in the library. That should be
the only required change for most programs.

     For those programs which do not use either GRAPHICS or PLOTTER, the
procedure is more complicated and the results may or may not be satisfactory.
However, if you wish, you may do the following. (1) Edit and compile the unit
REVIEW which contains DRAWLINE, HOME (the pen), and THROTTLE procedures which
are intended for use only with the Grundler-Gaal programs (because the (0,0)
point on the plotter corresponds to the (0,239) point on the screen and the
DRAWLINE procedure maps the screen coordinates onto the plotter coordinates) and
place the unit in GRAPH.LIBRARY. (2) Remove or comment out the definitions of
DRAWLINE and THROTTLE as external procedures in the program. (3) Remove or
comment out the type definition of SCREENTYPE (it is already in the unit
REVIEW). (4) At the beginning of the program add the line INITPLOT and at the
end HOME. (5) Either edit the program to compensate for the differences in the
resolution between the Terak and the plotter (the resolution of the Terak is 320
in the x-direction, the Hiplot 2000), or edit REVIEW to cause the plot to move 4
or 5 steps rather than 1 for each move in the x, y, or xy directions (this will
increase the size of the plot but it will be rather crude). PXMAX and PYMAX
should be defined to be either 2000 and 1400 or 319 and 239, depending on your
decision. (6) Remove or comment out all UNITWRITE's to unit 3.  With caution
considerable other code can be eliminated when only the plotter is being used.
Note that the output will be rather marginal with some programs and in some will
be almost weird. Only the graphics material will appear on the screen; the text
(axis labels, for example) will appear on the terminal, and the plots may appear
crude by plotter standards. All sorts of lines that you wouldn't use with a
plotter but might with a terminal will appear (if you haven't deleted the code),
and things will seem incrediby slow.  However, the program IVP gave fairly good
results after a thorough editing. Space does not permit including the edited
version on this diskette.

    Comments on individual programs follow.
    
     POST_ENTRY.  This is such a potentially useful unit that it is documented
separately as well as within the unit. Depending on the decision of the editor
of the library, it may appear on a different diskette from the rest of the
programs and units.  The unit is used for the entry of functions in algebraic
(infix) form as strings from the terminal and for the evaluation of the entered
function (in postfix form).  An excellent unit.

    REAL_INPUT.  The purpose of this unit is to facilitate the entering of
real numbers as strings from the terminal.  It appears to work quite well and
should be useful in any application in which a string (terminated with a
carriage return) is acceptable. It does accept scientific format and handles
most (but not all) improper entries without killing the system.

    SCRN_STUFF.  Screen control units for most of the programs on this diskette.
This unit should be edited for your terminal or terminal emulator, compiled and
put in GRAPH.LIBRARY before compiling most of the other units.

     PLOTTER.  A simple line drawing unit of the type used in the Grundler
programs, all of which appear to be based on the Pascal implementation of
DRAWLINE described in the version 1.5 manual. It is intended for the dumb
Hiplots but could (with care) be rewritten for the smart Hiplots or other
plotters.

     GRAPHICS. Apparently the final unit in a chain of development in which the
original PLOTTER unit was one link. This unit provides line drawing procedures
of several sorts for both the Terak graphics terminal and the DMP2 Hiplot
plotter. The unit is fairly well documented within the unit.  If you are trying
to adapt these program to some other graphics device and are not familiar with
the Terak, reading this unit will help. If you want to use the Hiplot but not
the Terak graphics parts, instructions are given in the unit for removing the
Terak stuff. In the opinion of the reviewer this unit contained one serious
error at the very end of the unit and some strange code in the middle. Using the
unit as received, the program DISTRIB could not plot properly with PSCALE set any
value other than 6.0. When the last line of code in GRAPHICS was changed from
    
  PICTURE(ROUND(PLOT_XLOC/PSCALE),239-ROUND(PLOT_YLOC/PSCALE), XEND-
    ROUND(PLOT_XLOC/PSCALE),YEND-239-ROUND(PLOT_YLOC/PSCALE)),PEN);
    
to that in this package, the program worked properly. This was discovered very
late in the review.  Hopefully the change will not foul up something else. 

    The strange code is found in procedure PLOT (in GRAPHICS) and is labeled
CORRECTION FOR STEPPER MOTOR SCALING.  One would assume that this was used to
correct for mechanical differences in stepper motors in the x- and y-directions.
However, when the reviewer removed this code entirely, he could discern no
difference in the plots, and he was concerned about the failure to initialize
the variables PLOT_XSTRT and PLOT_YSTRT, which appear no where else in the unit.
The code was left in---perhaps some more knowledgeable user can figure out why
it is there.

    FACT_STUFF. This unit contains several procedures or functions for
calculating n! and x! and their natural logarithms as well as related functions
required by the program DISTRIB. Documentation appears within the unit.  This
or some similar unit should be of general interest to persons needing factorials
for various purposes, e.g., calculating the gamma function or doing statistical
calculations.

    FUNC.  This program calculates and plots functions y = F(x) entered from
the terminal.  The program is interactive and fairly simple to run. It gave
good results on the Terak during our tests.  The Hiplot output was fairly
crude and better results could be achieved using POST_ENTRY with other
plotting routines. A potentially useful program for teaching purposes.

     POLAR.  This program calculates and plots functions r = F(theta) entered
from the console as r = F(x).  The program is interactive; however, the
functions of some of the entries are not defined on the screen.  Thus, you will
have to experiment with SCALE and UNIT_SCALE to determine their effect on your
plots.  Choosing SCALE too large will cause the plot to move outside the
boundaries on the screen and can jamb the plotter pen against the rail,
something to be avoided.  Therefore, do not use the default scale value: begin
with a scale of 0.1 or 0.2.  Some good functions to begin with are: (1) a
limacon of Pascal, r = 4*cos(x)+3 for x = 0 to 6.28, scale = 0.2; (2) r = x for
x = 0 to 25.12, scale = 0.05; (3) r = 8*(cos(3*x)), scale = 0.2; (4) r =
3*sqrt(1/x) for x = 0.1 to 18.8496, scale = 0.2; (5) r = r*sin(x)/x for x = -
3.1416 to 3.1416, scale = 0.2.  Worked well with both the Terak and the DMP2
Hiplot.

     DISTRIB.  This program plots normal, binomial, and Poisson distributions or
all of these for various entered values of sigma (standard deviation), p
(probability), n (number of trials), and mu (mean).  The program is interactive
but not particularly informative.  You have to understand what you are doing to
use this program.  Furthermore, the program sat indefinitely waiting for the
user to be clever enough to type an "A" to get things started.  Therefore, the
program was slightly revised to eliminate that requirement. Tested only on the
Hiplot, where the reviewer found the plots to be rather crude.  One unit
required for this procedure was missing; thus, a substitute was prepared (the
INPUT_VALUE function).  Whether this substitute is adequate is not known;
however, the program appears to function with the substitute.  

    SINES.  Plots two sine waves on the screen, sin(x) plus a*sin(b*x+c)+d.
Easy to use.  Worked very well on the Terak.  The reviewer made the mistake
of trying this one on the Hiplot using REVIEW.  This is definitely not
recommended.  The two plots are made simultaneously, one with solid and the
other with dashed lines. On the screen this is fine, but with the plotter it is
very, very slow, and the plotter jumps back and forth between the two curve
protesting loudly.

     HISTOGRAM.  Tested only with the Hiplot.  This program plots histograms of
data entered from the console of from a file.  The data file used by the
reviewer is on the diskette under the name HISTOGRAM.DATA.  This program is
fairly interactive, but you will have to hang in there insisting on getting the
data plotted the way you want it, because the program tries to change things the
way it wants. The number of histogram bars that can be plotted is limited to 22,
although presumably this could be changed by editing.  This program is probably
all right on the Terak where changes can be made fairly rapidly, and perhaps on
experimenting with the input parameters the program would be found to be more
flexible than it appears to the reviewer.

    CURVE_FIT.  A program to fit data to a polynomial and plot the resulting
function.  Was compiled but not tested. Apparently this was the first part of
a planned general program for fitting data to several types of functions.

    CONTOUR.  Apparently this program plots the intersection of a plane parallel
to the xy plane with a surface defined by z = F(x,y).  The user-program
interface is not quite as good as in some of the other programs; therefore, you
will have to experiment with the various input parameters.  Tested only on the
Hiplot using REVIEW, using as the surface a sphere impaled on the z-axis.
The program appears to be quite clever as an appropriate intersection is sought
and the contour line is plotted.  It coped very well with the lower half of the
sphere but couldn't handle the upper surface.

     TRIANGLE.  This program accept as input a partial definition of a triangle
(e.g., the length of one side and the two angles at the ends of that side), then
computes the remaining sides and angles and plots the resultant triangle.
Compiled but not tested.

    TRAVERSE.  According a colleague in the Department of Civil Engineering,
this is a program for surveyors.  It accepts the usual input for calculating
traverses, computes areas, angles, makes corrections, etc. Compiled but not
tested.

     IVP.  This program accepts a differential equation of the type y' = F(x,y)
and appropriate boundary conditions, y(X0) = y0. It then "solves" the
differential equation using either the Euler method or a fourth-order Runge-
Kutta technique. If this doesn't mean anything to you, either this program is
not for you or you will have do some reading elsewhere (Conte and de Boor,
"Elementary Numerical Analysis, Chapter 8, give FORTRAN versions which should be
easy to translate into Pascal if you would like alternative procedures, and the
Runge-Kutta method was described briefly in Micro, No. 46, p. 13ff (1982) along
with a BASIC program). The numerical solution by either or both methods may be
plotted (along with the analytical solution if that is known to you so that it
can be entered) on the screen.  The program worked very well on the Terak and
when adapted to the Hiplot. The tic marks on the axes are arbitrarily placed at
intervals of 1/10th of the axis length.  Therefore, the plots will look best if
you choose x and y limits accordingly. The review edited his copy to turn of the
TABLE_OPTION toggle (set it FALSE in INITIALIZE) because it really slows down
the plot unless you need to see the actual calculated values. To try the program
you can use the default example, the examples in Conte and de Boor, make up your
own, or use some simple differential equation such as y' = cos(X) for y(0) = 2.

========================================================================================
DOCUMENT :usus Folder:VOL22:graphics.text
========================================================================================

{  Provided in this unit are the necessary routines to drive both the graphics
 for the "TERAK" CONSOLE: and the "HOUSTON INSTRUMENT DIGITAL PLOTTER".
   
   The user of these routines needn't worry about how to lay out a SCREEN
 ARRAY or how to talk directly to the PLOTTER.
   
   To use this graphical unit the user must call PROCEDURE SETUP(DEVICE);
 where device is one of the following: SCREEN,BOTH, or PLOTTER.  This is
 necessary since this routine initializes variables only accessable to this
 unit.

   PROCEDURE NEXT_FRAME(DEVICE,CLEARSCREEN,GRAFICS,TXT,FINISHED); is the
 procedure to use whenever you have finished the last plot and you wish to 
 make another plot.  The DEVICE is the same as called for by PROCEDURE 
 SETUP.  CLEARSCREEN is a BOOLEAN variable which allows the user to specify
 that the screen is to be cleared if it was used; or if the plotter was
 used it indicates that a new sheet of paper has been inserted.  The user
 may use CLEAR or NO_CLEAR if desired.  GRAFICS and TXT are parameters that
 specify which sections of the screen are to be devoted to either GRAPHICS
 or TEXT (* above you will find the options under: SECTIONS_OF_SCREEN*)
   
   The SCREEN can be turned on in the following modes:
              0: OFF (all three sections);
              1: BOTTOM (only the bottom section on);
              2: MIDDLE (only the middle section on);
              3: LOW (the bottom and middle sections on);
              4: TOP (only the top section on);
              5: SPLIT (the top and bottom sections on);
              6: HIGH (the top and middle sections on);
              7: ALL (all three sections on);
 
    FINISHED is a BOOLEAN variable indicating that the user has finished 
  with the plotting.  This unit then turns the graphics off if used and it
  also returns the PLOTTER'S pen to the lower left corner.  The user may
  choose to use DONE and NOT_DONE as the parameter value.
  
  
    PROCEDURE PICTURE(XSTART,YSTART,DX,DY,PEN); is the routine to use if 
  one wants to specify the beginning coordinate and the change in each of
  the X and Y directions.  The pen can take on the values 0 through 4.  
  The top two rows of constants can be used as the parameter for the pen.
  If PEN=4 nothing will be drawn on either the screen or the PLOTTER; 
  however, if the SCREEN was being used the unit will return the distance
  to the nearest line along the path that would have been drawn.  If PEN=3
  the PLOTTER will draw dashed lines while the screen will draw white dots
  where blacks ones existed and visa-versa.
  
    PROCEDURE DRAW(XEND,YEND,PEN); provides all of the same functions as
  PROCEDURE PICTURE; the major difference lies in the fact that the old
  ending location is used as the starting point and the line is drawn to
  the user specified location.
  
    The present graphic's cursor is always available to the user as the
  point(XLOC,YLOC). (*this is immune to changes to these variables*)
 
   If the user presses the ESCape key during the plot the ESCAPE_PLOT variable
 will be set to TRUE.  If this happens the user must set it to false or call
 PROCEDURE SETUP again; otherwise, nothing will be plotted.
 
   PSCALE is a variable that is used to adjust the size of the plot on the
 plotter.  The default value is 6.  6 is the number which gives you a full size
 plot using the same numbers as you would for the screen.
 
   QUIET is a BOOLEAN variable that is used to tell the UNIT GRAPHICS that it
 is not to output messages (*supposedly the user doesn't want any messages or
 they are writing there own*).
 
   SET_PEN is a BOOLEAN variable that indicates that the user should print a
 message indicating that the plotter's pen should be positioned.
 
  Changes made in editing: The array bounds for SCREENTYPE were reversed.  The
                           current Terak DRAWLINE intrinsic expects to receive
                           its screen array in the form, SCREEN[Y,X].
                           
                           Revised the procedure DRAW to make PSCALE operate
                           properly.
                            
                           Note that it should be possible to use these
                           routines with any computer and a dumb Hiplot plotter
                           by the following procedures.
                           
                             Comment out all UNITWRITE's to UNIT 3 (Terak
                               screen).
                             Convert PROCEDURE DRAWLINE from an external
                               to a dummy procedure of the form
                                  BEGIN
                                  END;
                             Replace the external PROCEDURE THROTTLE with
                               any procedure that will produce a delay for
                               pen changes (from up to down and vice versa).
                               This could involve a software loop or a line-
                               time clock routine where this is possible.
                               See the THROTTLE procedure in the units
                               PLOTTER and REVIEW for a example that works
                               with LSI-11's.
                             
                             Note that REMINOUT is used for the Hiplot.  This
                               could be easily changed, if desired.  See
                               PLOTTER and REVIEW.
                              
                                      ---Henry E. Baumgarten
                                         Clifford L. Bettis
}
{$S+}
{$L-GRAPHICS.LIST}
UNIT GRAPHICS;

INTERFACE

{
                                                     unit by:  DENNIS E GRUNDLER
                        based primarily upon UNIT PLOTTER by:  EDWARD J GRUNDLER
}

CONST UP=0; DOWN=1; NEW_COLOR=2; DASHES=3; NO_COLOR=4;
      NONE=0; WHITE=1; BLACK=2; REVERSE=3; RADAR=4;
      CLEAR=TRUE; NO_CLEAR=FALSE; DONE=TRUE; NOT_DONE=FALSE;

TYPE SECTION_OF_SCREEN = (OFF,BOTTOM,MIDDLE,LOW,TOP,SPLIT,HIGH,ALL);
     UNITTYPE = (SCREEN,BOTH,PLOTTER);
     PENTYPE = 0..4;
     
VAR ESCAPE_PLOT,QUIET,SET_PEN:BOOLEAN;
    RANGE,XLOC,YLOC:INTEGER;
    PSCALE:REAL;
    PEN:PENTYPE;

PROCEDURE PICTURE(XSTART,YSTART,DX,DY:INTEGER; PEN:PENTYPE);
PROCEDURE DRAW(XEND,YEND:INTEGER; PEN:PENTYPE);
PROCEDURE SETUP(DEVICE:UNITTYPE);
PROCEDURE NEXT_FRAME(DEVICE:UNITTYPE; CLEARSCREEN:BOOLEAN; GRAFICS,TXT:
  SECTION_OF_SCREEN; FINISHED:BOOLEAN);

IMPLEMENTATION

TYPE SCREENTYPE = PACKED ARRAY [0..239,0..319] OF BOOLEAN;

VAR PLOT_XLOC,PLOT_YLOC,PLOT_XSTRT,PLOT_YSTRT:INTEGER;
    OLDPEN:PENTYPE;
    S:SCREENTYPE;
    CURRENT_DEVICE:UNITTYPE;

PROCEDURE THROTTLE(TICKS:INTEGER);
EXTERNAL;
PROCEDURE DRAWLINE(VAR RANGE:INTEGER; VAR S:SCREENTYPE; ROWWIDTH,
  XSTART,YSTART,DELTAX,DELTAY:INTEGER; INKPEN:PENTYPE);
EXTERNAL;

PROCEDURE SETUP;

VAR OUT:STRING[3];

BEGIN
  ESCAPE_PLOT:=FALSE;
  OLDPEN:=UP;
  OUT:='y  ';{ lift pen }
  UNITWRITE(8,OUT,3,,1);
  FILLCHAR(S,SIZEOF(S),0);
  IF DEVICE IN [SCREEN,BOTH] THEN UNITWRITE(3,S,63);
  PLOT_XLOC:=0;
  PLOT_YLOC:=0;
  SET_PEN:=(DEVICE IN [PLOTTER,BOTH])AND QUIET;
  IF (DEVICE IN [PLOTTER,BOTH]) AND NOT(QUIET) THEN
    BEGIN
      GOTOXY(0,1);
      WRITE('Position PLOTTER''S pen to the LOWER LEFT CORNER!!',
        '  press RETURN to continue.');
      READLN;
    END;
  PSCALE:=6.0;
  CURRENT_DEVICE:=DEVICE;
END;

PROCEDURE PLOT(PEN:PENTYPE;PLOT_XEND,PLOT_YEND:INTEGER);FORWARD;

PROCEDURE NEXT_FRAME;


BEGIN
  IF CURRENT_DEVICE=SCREEN THEN
    BEGIN
      XLOC:=0;
      YLOC:=239;
      PLOT_XLOC:=0;
      PLOT_YLOC:=0
    END;
  IF FINISHED THEN 
    BEGIN
      IF CLEARSCREEN THEN
        BEGIN
          FILLCHAR(S,SIZEOF(S),0);
          UNITWRITE(3,S,7);
        END;
      IF CURRENT_DEVICE IN [PLOTTER,BOTH] THEN PLOT(UP,0,0);
      EXIT(NEXT_FRAME);
    END;
  IF DEVICE IN [SCREEN,BOTH] THEN
    BEGIN
      UNITWRITE(3,S,8*ORD(GRAFICS)+ORD(TXT));
      IF CLEARSCREEN THEN FILLCHAR(S,SIZEOF(S),0);
    END;
  SET_PEN:=(CURRENT_DEVICE=SCREEN) AND (DEVICE IN [PLOTTER,BOTH]) AND QUIET;
  IF DEVICE IN [PLOTTER,BOTH] THEN
    BEGIN
      IF CURRENT_DEVICE=SCREEN THEN 
        IF NOT(QUIET) THEN
          BEGIN
            GOTOXY(0,0);
            WRITELN('Position the PLOTTER''S pen to the lower left corner!');
            WRITE('press RETURN to continue');
            READLN;
          END
                            ELSE    ELSE PLOT(UP,0,0);
    END;
  CURRENT_DEVICE:=DEVICE;
END;

PROCEDURE PLOT;

CONST X_SCALE = 32767;  {PLOTTER S/N 7919-9}
      Y_SCALE =   100;  {PLOTTER S/N 7919-9}
VAR XINC,YINC1,YINC3,MOVE,DX,DY,X_CORR,Y_CORR:INTEGER;
    OUT:ARRAY[1..3] OF CHAR;
    UP_DOWN:BOOLEAN;
    SAVE_PEN:PENTYPE;
    CH:CHAR;

PROCEDURE HANDLE_KEYBOARD;

BEGIN
  IF ESCAPE_PLOT THEN EXIT(HANDLE_KEYBOARD);
  IF CH = CHR(27{ESCape}) THEN
    BEGIN
      ESCAPE_PLOT:=TRUE;
      NEXT_FRAME(CURRENT_DEVICE,NO_CLEAR,OFF,ALL,DONE);
      EXIT(PICTURE);
    END;
  UNITREAD(2,CH,1,,1);
END;

PROCEDURE CHECK_PEN;

BEGIN
  IF ((PEN=DOWN) AND (OLDPEN=UP)) OR ((PEN=UP) AND (OLDPEN=DOWN)) THEN
    BEGIN
      OLDPEN:=PEN;
      IF PEN = DOWN THEN OUT[1]:='z' ELSE OUT[1]:='y';
      UNITWRITE(8,OUT,3,,1);
      SAVE_PEN:=PEN;
      IF UP_DOWN THEN PEN:=SAVE_PEN;
      THROTTLE(10);
    END
END;

PROCEDURE PLOTPOINT;
  
  BEGIN
    CASE MOVE OF
    -4: OUT[1]:='u';
    -3: OUT[1]:='t';
    -2: OUT[1]:='s';
    -1: OUT[1]:='v';
     1: OUT[1]:='r';
     2: OUT[1]:='w';
     3: OUT[1]:='p';
     4: OUT[1]:='q';
    END{OF CASE};
    UNITWRITE(8,OUT,3,,1)
  END;
  
PROCEDURE DO_FOR_X;   {MORE HORIZONTAL}
  
  VAR ERROR,I:INTEGER;
  BEGIN
    IF DX=0 THEN EXIT(PLOT);
    ERROR:=DX DIV 2;
    I:=DX;
    REPEAT
      IF NOT(UNITBUSY(2)) THEN HANDLE_KEYBOARD;
      MOVE:=XINC;
      ERROR:=ERROR+DY;
      IF ERROR>=DX THEN
        BEGIN
          ERROR:=ERROR-DX;
          PLOT_YLOC:=PLOT_YLOC+YINC1;
          MOVE:=MOVE+YINC3
        END;
      PLOT_XLOC:=PLOT_XLOC+XINC;
      PLOTPOINT;
      I:=I-1;
      IF (I MOD 8 = 0) AND UP_DOWN THEN CHECK_PEN;
    UNTIL I=0
  END;
  
PROCEDURE DO_FOR_Y;   {MORE VERTICAL}
  
  VAR ERROR,I:INTEGER;
  BEGIN
    ERROR:=DY DIV 2;
    I:=DY;
    REPEAT
      IF NOT(UNITBUSY(2)) THEN HANDLE_KEYBOARD;
      MOVE:=YINC3;
      ERROR:=ERROR+DX;
      IF ERROR>=DY THEN
        BEGIN
          ERROR:=ERROR-DY;
          MOVE:=MOVE+XINC;
          PLOT_XLOC:=PLOT_XLOC+XINC
        END;
      PLOT_YLOC:=PLOT_YLOC+YINC1;
      PLOTPOINT;
      I:=I-1;
      IF (I MOD 8 = 0) AND UP_DOWN THEN CHECK_PEN;
    UNTIL I=0
  END;

BEGIN {PLOT}
  IF PEN = NO_COLOR THEN EXIT(PICTURE);
  UP_DOWN:=PEN = DASHES;
  IF UP_DOWN THEN PEN:=DOWN;
  UNITREAD(2,CH,1,,1);
  OUT[2]:=' ';
  OUT[3]:=' ';
  CHECK_PEN;
  X_CORR:=(PLOT_XLOC-PLOT_XSTRT) DIV X_SCALE;     {CORRECTION}
  PLOT_XLOC:=PLOT_XLOC+X_CORR;                    {FOR       }
  X_CORR:=(PLOT_XEND-PLOT_XSTRT) DIV X_SCALE;     {STEPPER   }
  PLOT_XEND:=PLOT_XEND+X_CORR;                    {MOTOR     }
  Y_CORR:=(PLOT_YLOC-PLOT_YSTRT) DIV Y_SCALE;     {SCALING   }
  PLOT_YLOC:=PLOT_YLOC+Y_CORR;
  Y_CORR:=(PLOT_YEND-PLOT_YSTRT) DIV Y_SCALE;
  PLOT_YEND:=PLOT_YEND+Y_CORR;
  WHILE NOT ((PLOT_XLOC=PLOT_XEND) AND (PLOT_YLOC=PLOT_YEND)) DO
    BEGIN
      DX:=PLOT_XEND-PLOT_XLOC;
      DY:=PLOT_YEND-PLOT_YLOC;
      IF DX<0 THEN
        BEGIN
          XINC:=-1;
          DX:=-DX
        END
      ELSE XINC:=1;
      IF DY<0 THEN
        BEGIN
          YINC1:=-1;
          YINC3:=-3;
          DY:=-DY
        END
      ELSE
        BEGIN
          YINC1:=1;
          YINC3:=3
        END;
      IF DX>=DY THEN DO_FOR_X ELSE DO_FOR_Y;
    END;
  PLOT_XEND:=PLOT_XEND-X_CORR;        {REMOVE THE CORRECTIONS}
  PLOT_XLOC:=PLOT_XEND;
  XLOC:=ROUND(PLOT_XLOC/PSCALE);
  PLOT_YEND:=PLOT_YEND-Y_CORR;
  PLOT_YLOC:=PLOT_YEND;
  YLOC:=239-ROUND(PLOT_YLOC/PSCALE);
  UNITCLEAR(2);
END {PLOT};


PROCEDURE PICTURE;

VAR XSTRT,YSTRT:INTEGER;
    CH:CHAR;

FUNCTION BOUNDS(VALUE,LIMIT:INTEGER):INTEGER;

VAR TEMP:INTEGER;

BEGIN 
  TEMP:=VALUE;
  IF VALUE>LIMIT THEN TEMP:=LIMIT;
  IF VALUE<0 THEN TEMP:=0;
  BOUNDS:=TEMP;
END;

FUNCTION DELTA(VALUE,LIMIT:INTEGER):INTEGER;

VAR TEMP,TEMP1:INTEGER;
    FLAG:BOOLEAN;
    
BEGIN
  FLAG:= LIMIT = 319;
  IF FLAG THEN TEMP:=VALUE+BOUNDS(XSTART,319) ELSE 
    TEMP:=VALUE+BOUNDS(YSTART,239);
  TEMP1:=BOUNDS(TEMP,LIMIT);
  DELTA:=TEMP1-TEMP+VALUE;
END;

BEGIN {PICTURE}
  IF ESCAPE_PLOT THEN EXIT(PICTURE);
  UNITREAD(2,CH,1,,1);
  IF CURRENT_DEVICE IN [SCREEN,BOTH] THEN 
    BEGIN
      DRAWLINE(RANGE,S,20,BOUNDS(XSTART,319),BOUNDS(YSTART,239),
        DELTA(DX,319),DELTA(DY,239),PEN);
      IF CURRENT_DEVICE=SCREEN THEN
        BEGIN
          XLOC:=BOUNDS(XSTART,319)+DELTA(DX,319);
          YLOC:=BOUNDS(YSTART,239)+DELTA(DY,239);
          PLOT_XLOC:=ROUND(XLOC*PSCALE);
          PLOT_YLOC:=ROUND((239-YLOC)*PSCALE)
        END
    END;
  IF NOT(UNITBUSY(2)) THEN ESCAPE_PLOT:= CH = CHR(27);
  UNITCLEAR(2);
  IF ESCAPE_PLOT THEN EXIT(PICTURE);
  IF CURRENT_DEVICE IN [PLOTTER,BOTH] THEN 
    BEGIN
      IF PEN=NEW_COLOR THEN
        BEGIN
          IF NOT(QUIET) THEN
            BEGIN
              GOTOXY(0,1);
              WRITE('You may change colors now!  press RETURN to continue');
            END;
          PLOT(UP,PLOT_XLOC,PLOT_YLOC);
          READLN;
          PEN:=DOWN;
        END;
      XSTRT:=ROUND(PSCALE*BOUNDS(XSTART,ROUND(1914/PSCALE)));
      YSTRT:=ROUND(1434-PSCALE*BOUNDS(YSTART,ROUND(1434/PSCALE)));
      IF NOT(XSTRT = PLOT_XLOC) OR NOT(YSTRT = PLOT_YLOC) THEN
        PLOT(UP,XSTRT,YSTRT);
      IF NOT((DX=0) AND (DY=0)) THEN
        PLOT(PEN,ROUND(PSCALE*BOUNDS(XSTART+DX,ROUND(1914/PSCALE))),
          ROUND(1434-PSCALE*BOUNDS(YSTART+DY,ROUND(1434/PSCALE))));
    END;
END {PICTURE};

PROCEDURE DRAW;

BEGIN
  PICTURE(ROUND(PLOT_XLOC/PSCALE),ROUND((1434-PLOT_YLOC)/PSCALE),XEND-
    ROUND(PLOT_XLOC/PSCALE),YEND-ROUND((1434-PLOT_YLOC)/PSCALE),PEN);
END;
END. {END OF UNIT GRAPHICS}

========================================================================================
DOCUMENT :usus Folder:VOL22:histogram.data
========================================================================================

< binary file -- not listed >

========================================================================================
DOCUMENT :usus Folder:VOL22:histogram.text
========================================================================================

{$L- HISTOGRAM.LIST}

{
                                                  program by:  EDWARD J GRUNDLER
                                                  
     Changes made by reviewer:
       Reversed ranges in type SCREEN.
       Replaced PAGE(OUTPUT) by CLEARSCREEN.
       Replaced missing unit EDS_STUFF by REAL_INPUT.
                              ---Henry E. Baumgarten
}

PROGRAM HISTOGRAM;

USES {$U GRAPH.LIBRARY} SCREEN_STUFF, REAL_INPUT;

TYPE OPEN_OR_CLOSED = (OPEN,CLOSED);
     SCREEN = PACKED ARRAY[0..239,0..319] OF BOOLEAN;
VAR CH:CHAR;
    DATA:FILE OF
           RECORD
             NUMBER_OF_POINTS:INTEGER;
             DATA_POINT:ARRAY[1..255]OF REAL
           END; {OF RECORD}
    STARTED,OLD_DATA_AVAILABLE,NEW_DATA_USED:BOOLEAN;
    MIN,MAX,CLASS_WIDTH,LEFT_START:REAL;
    NUMB_OF_CLASSES,R:INTEGER;
    LEFT_END,RIGHT_END:OPEN_OR_CLOSED;
    CLASS:PACKED ARRAY[1..22] OF INTEGER;
    CLASS_LIMIT:ARRAY[0..22] OF REAL;

PROCEDURE DRAWLINE(VAR R:INTEGER; VAR S:SCREEN; RW,XS,YS,DX,DY,INK:INTEGER);
EXTERNAL;

PROCEDURE THROTTLE(TICKS:INTEGER);
EXTERNAL;

PROCEDURE DRAW_HISTOGRAM;
VAR I,Y_SCALE,XSTART,XSTOP,Y:INTEGER;
    S:SCREEN;
    RNG,LEFT,RIGHT,INC:REAL;
BEGIN {DRAW_HISTOGRAM}
  Y_SCALE:=0;
  FOR I:=1 TO NUMB_OF_CLASSES DO IF CLASS[I]>Y_SCALE THEN Y_SCALE:=CLASS[I];
  WHILE NOT (Y_SCALE IN [9,18,45,90,180,270]) DO Y_SCALE:=Y_SCALE+1;
  CLEARSCREEN;
  FILLCHAR(S,SIZEOF(S),CHR(0));
  UNITWRITE(3,S,63);
  GOTOXY(0,4);
  FOR I:=0 TO 9 DO
    BEGIN
      DRAWLINE(R,S,20,24,44+I*20,5,0,1);
      WRITELN(Y_SCALE DIV 9*(9-I):6);
      IF I<>9 THEN WRITELN
    END;
  RNG:=CLASS_WIDTH*NUMB_OF_CLASSES/18;
  LEFT:=LEFT_START-RNG;
  RIGHT:=LEFT+20*RNG;
  RNG:=RIGHT-LEFT;
  FOR I:=0 TO 10 DO
    BEGIN
      DRAWLINE(R,S,20,39+I*28,224,0,-5,1);
      GOTOXY(3+7*I,23);
      WRITE(LEFT+I*RNG/10:7:2)
    END;
  GOTOXY(0,0);
  INC:=RNG/280;
  DRAWLINE(R,S,20,24,43,0,181,1);
  DRAWLINE(R,S,20,24,224,295,0,1);
  FOR I:=1 TO NUMB_OF_CLASSES DO
    BEGIN
      XSTART:=319-ROUND((RIGHT-CLASS_LIMIT[I-1])/INC);
      XSTOP:=319-ROUND((RIGHT-CLASS_LIMIT[I])/INC);
      Y:=224-ROUND(CLASS[I]/Y_SCALE*180);
      DRAWLINE(R,S,20,XSTART,224,0,Y-224,1);
      DRAWLINE(R,S,20,XSTOP,224,0,Y-224,1);
      DRAWLINE(R,S,20,XSTART,Y,XSTOP-XSTART,0,1)
    END;
  WRITE('press RETURN to continue');
  READLN;
  UNITWRITE(3,S,7);
  CLEARSCREEN
END; {DRAW_HISTOGRAM}

PROCEDURE WRITE_FREQUENCY_DISTRIBUTION;
VAR I:INTEGER;
BEGIN {WRITE_FREQUENCY_DISTRIBUTION}
  CLEARSCREEN;
  FOR I:=1 TO NUMB_OF_CLASSES DO
    IF I=1 THEN
      WRITELN('CLASS',I:3,'  LEFT BOUNDRY = ',CLASS_LIMIT[I-1]:7:2,
              '  RIGHT BOUNDRY = ', CLASS_LIMIT[I]:7:2,'  NUMBER IN CLASS = ',
              CLASS[I]:3)
    ELSE WRITELN(I:8,CLASS_LIMIT[I-1]:24:2,CLASS_LIMIT[I]:25:2,CLASS[I]:23);
  WRITELN;
  WRITE('press RETURN to continue');
  READLN
END; {WRITE_FREQUENCY_DISTRIBUTION}

PROCEDURE SCAN_AND_ASSIGN_TO_CLASSES;
VAR I,J:INTEGER;
BEGIN {SCAN_AND_ASSIGN_TO_CLASSES}
  WRITELN;
  WRITE('SCANNING THE DATA');
  CLASS_LIMIT[0]:=LEFT_START;
  FOR I:=1 TO NUMB_OF_CLASSES DO
    BEGIN
      CLASS[I]:=0;
      CLASS_LIMIT[I]:=CLASS_LIMIT[I-1]+CLASS_WIDTH
    END;
  WITH DATA^ DO
    FOR I:=1 TO NUMBER_OF_POINTS DO
      BEGIN
        J:=0;
        WHILE J<NUMB_OF_CLASSES DO
          BEGIN
            J:=J+1;
            IF (J=1) AND (LEFT_END = OPEN) THEN
              IF DATA_POINT[I]<CLASS_LIMIT[J] THEN
                BEGIN
                  CLASS[J]:=CLASS[J]+1;
                  J:=NUMB_OF_CLASSES
                END
              ELSE
            ELSE
              IF (J=NUMB_OF_CLASSES) AND (RIGHT_END=OPEN) THEN
                IF DATA_POINT[I]>CLASS_LIMIT[J-1] THEN CLASS[J]:=CLASS[J]+1
                ELSE
              ELSE
                IF (DATA_POINT[I]>=CLASS_LIMIT[J-1]) AND
                   (DATA_POINT[I]<CLASS_LIMIT[J]) THEN
                  BEGIN
                    CLASS[J]:=CLASS[J]+1;
                    J:=NUMB_OF_CLASSES
                  END
          END
      END
END; {SCAN_AND_ASSIGN_TO_CLASSES}

PROCEDURE SET_UP_CLASSES;

  PROCEDURE COMPUTE_CLASS_WIDTH;
  BEGIN {COMPUTE_CLASS_WIDTH}
    CLASS_WIDTH:=(MAX-MIN)/NUMB_OF_CLASSES;
    IF CLASS_WIDTH=0 THEN CLASS_WIDTH:=0.8/NUMB_OF_CLASSES
    ELSE CLASS_WIDTH:=CLASS_WIDTH+CLASS_WIDTH*0.01/NUMB_OF_CLASSES;
    LEFT_START:=MIN-CLASS_WIDTH*0.005;
  END; {COMPUTE_CLASS_WIDTH}
  
  PROCEDURE WRITE_OUTPUT;
  BEGIN {WRITE_OUTPUT}
    CLEARSCREEN;
    WRITELN('NUMBER OF CLASSES = ',NUMB_OF_CLASSES);
    WRITELN('CLASS WIDTH = ',CLASS_WIDTH:8:6);
    WRITELN('LEFT BOUNDRY = ',LEFT_START:8:6);
    WRITE('LEFT BOUNDRY IS ');
    IF LEFT_END=CLOSED THEN WRITELN('CLOSED') ELSE WRITELN('OPEN');
    WRITE('RIGHT BOUNDRY IS ');
    IF RIGHT_END=CLOSED THEN WRITELN('CLOSED') ELSE WRITELN('OPEN');
    WRITELN
  END; {WRITE_OUTPUT}

  PROCEDURE ASK_ABOUT_CHANGES;
  VAR CH:CHAR;
  BEGIN {ASK_ABOUT_CHANGES}
    REPEAT
      WRITE('DO YOU WANT TO CHANGE ANY OF THIS DATA? ');
      REPEAT READ(KEYBOARD,CH) UNTIL CH IN ['Y','y','N','n'];
      IF CH IN ['Y','y'] THEN
        BEGIN
          WRITELN;
          WRITELN;
          WRITELN('N(umber of classes');
          WRITELN('W(idth');
          WRITELN('left B(oundry value');
          WRITELN('L(eft boundry condition');
          WRITELN('R(ight boundry condition');
          WRITELN;
          WRITELN('PLEASE SELECT BY PRESSING ONLY THE UPPER CASE LETTER! ');
          REPEAT
            READ(KEYBOARD,CH)
          UNTIL CH IN ['N','n','W','w','B','b','L','l','R','r'];
          CASE CH OF
          'N','n':
            BEGIN
              REPEAT
                WRITE('HOW MANY CLASSES? ');
                NUMB_OF_CLASSES:=ROUND(INPUT_VALUE);
                IF NOT(NUMB_OF_CLASSES IN [1..22]) THEN
                  WRITELN('ONLY VALUES BETWEEN 1 AND 22 MAY BE ENTERED. ')
              UNTIL NUMB_OF_CLASSES IN [1..22];
              WRITE('SHOULD I RECOMPUTE THE CLASS LIMITS? ');
              REPEAT READ(KEYBOARD,CH) UNTIL CH IN ['Y','y','N','n'];
              IF CH IN ['Y','y'] THEN COMPUTE_CLASS_WIDTH;
              CH:=' '
            END;
          'W','w':
            BEGIN
              WRITE('CLASS WIDTH = ');
              CLASS_WIDTH:=INPUT_VALUE
            END;
          'B','b':
            BEGIN
              WRITE('LEFT BOUNDRY VALUE = ');
              LEFT_START:=INPUT_VALUE
            END;
          'L','l':IF LEFT_END=OPEN THEN LEFT_END:=CLOSED ELSE LEFT_END:=OPEN;
          'R','r':IF RIGHT_END=OPEN THEN RIGHT_END:=CLOSED ELSE RIGHT_END:=OPEN
          END; {OF CASE}
          WRITE_OUTPUT
        END;
    UNTIL CH IN ['N','n'];
  END; {ASK_ABOUT_CHANGES}

BEGIN {SET_UP_CLASSES}
  LEFT_END:=CLOSED;
  RIGHT_END:=CLOSED;
  NUMB_OF_CLASSES:=ROUND(SQRT(DATA^.NUMBER_OF_POINTS));
  IF NUMB_OF_CLASSES<5 THEN NUMB_OF_CLASSES:=5
  ELSE IF NUMB_OF_CLASSES>15 THEN NUMB_OF_CLASSES:=15;
  COMPUTE_CLASS_WIDTH;
  WRITE_OUTPUT;
  ASK_ABOUT_CHANGES
END; {SET_UP_CLASSES}

PROCEDURE SCAN_FOR_LIMITS;
VAR I:INTEGER;
BEGIN {SCAN_FOR_LIMITS}
  WITH DATA^ DO
    BEGIN
      MIN:=DATA_POINT[1];
      MAX:=MIN;
      FOR I:=2 TO NUMBER_OF_POINTS DO
        IF DATA_POINT[I]<MIN THEN MIN:=DATA_POINT[I]
        ELSE IF DATA_POINT[I]>MAX THEN MAX:=DATA_POINT[I]
    END
END; {SCAN_FOR_LIMITS}

PROCEDURE GET_DATA;
VAR FLAG:BOOLEAN;
    CH:CHAR;
BEGIN {GET_DATA}
  FLAG:=FALSE;
  IF NOT STARTED THEN
    BEGIN
      STARTED:=TRUE;
{$I-}{TURN OFF I/O CHECKING}
      RESET(DATA,'HISTOGRAM.DATA');
      FLAG:=IORESULT<>0;
{$I+}{TURN ON I/O CHECKING}
      OLD_DATA_AVAILABLE:=NOT FLAG
    END;
  IF FLAG THEN REWRITE(DATA,'HISTOGRAM.DATA')
  ELSE
    BEGIN
      WRITE('DO YOU WANT TO USE');
      IF OLD_DATA_AVAILABLE THEN
        BEGIN
          WRITE(' THE D(iskfile DATA');
          IF NEW_DATA_USED THEN WRITE(',')
        END;
      IF NEW_DATA_USED THEN WRITE(' THE E(ntered DATA');
      WRITE(' OR N(ew DATA? ');
      REPEAT
        READ(KEYBOARD,CH);
        IF OLD_DATA_AVAILABLE AND (CH IN ['D','d']) THEN
          BEGIN
            NEW_DATA_USED:=FALSE;
            SEEK(DATA,0);
            GET(DATA);
            CH:=CHR(128)
          END;
        IF NEW_DATA_USED AND (CH IN ['E','e']) THEN CH:=CHR(128);
        IF CH IN ['N','n'] THEN
          BEGIN
            FLAG:=TRUE;
            CH:=CHR(128)
          END
      UNTIL CH=CHR(128)
    END;
  CLEARSCREEN;
  IF FLAG THEN
    WITH DATA^ DO
      BEGIN
        NEW_DATA_USED:=TRUE;
        NUMBER_OF_POINTS:=0;
        WRITELN('ENTER the DATA as requested');
        WRITELN;
        WRITELN('press ETX in place of RETURN after the LAST entry is made');
        WRITELN;
        WHILE (NUMBER_OF_POINTS<>255) AND NOT EOF DO
          BEGIN
            NUMBER_OF_POINTS:=NUMBER_OF_POINTS+1;
            WRITE('POINT ',NUMBER_OF_POINTS,' = ');
            DATA_POINT[NUMBER_OF_POINTS]:=INPUT_VALUE
          END;
        IF EOF THEN
          BEGIN
            RESET(INPUT);
            IF DATA_POINT[NUMBER_OF_POINTS]=0 THEN
              BEGIN
                WRITELN;
                WRITE('DID YOU INTEND FOR THE LAST POINT TO BE ZERO? ');
                REPEAT READ(KEYBOARD,CH) UNTIL CH IN ['Y','y','N','n'];
                IF CH IN ['N','n'] THEN NUMBER_OF_POINTS:=NUMBER_OF_POINTS-1;
                CH:=CHR(128)
              END
          END
        ELSE
          BEGIN
            WRITE('255 POINTS IS THE MAXIMUM');
            THROTTLE(180)
          END
      END
END; {GET_DATA}

PROCEDURE INITIALIZE;
BEGIN {INITIALIZE}
  CLEARSCREEN;
  STARTED:=FALSE;
  NEW_DATA_USED:=FALSE
END; {INITIALIZE}

BEGIN {HISTOGRAM}
  INITIALIZE;
  REPEAT
    GET_DATA;
    SCAN_FOR_LIMITS;
    SET_UP_CLASSES;
    SCAN_AND_ASSIGN_TO_CLASSES;
    WRITE_FREQUENCY_DISTRIBUTION;
    DRAW_HISTOGRAM;
    WRITE('IS THAT THE LAST HISTOGRAM? ');
    REPEAT READ(KEYBOARD,CH) UNTIL CH IN ['Y','y','N','n'];
    CLEARSCREEN
  UNTIL CH IN ['Y','y'];
  SEEK(DATA,0);
  IF NOT OLD_DATA_AVAILABLE THEN PUT(DATA)
  ELSE
    IF NEW_DATA_USED THEN
      BEGIN
        WRITELN('DO YOU WANT THE NEW DATA SAVED');
        WRITE('IN PLACE OF THE OLD ON THE DISK? ');
        REPEAT READ(KEYBOARD,CH) UNTIL CH IN ['Y','y','N','n'];
        IF CH IN ['Y','y'] THEN PUT(DATA)
      END;
  CLOSE(DATA,LOCK)
END {HISTOGRAM}.

========================================================================================
DOCUMENT :usus Folder:VOL22:ivp.text
========================================================================================

{$L-,S- IVP.LIST}
PROGRAM IVP;  { written by Ken Gaal, 1-25-80 }
              { last modified on 2-6-80}
{
       This program obtains numerical solutions to an arbitrary Initial
   Value Problem (IVP).  The user types in the differential equation
   (DE) dy/dx=f(x,y), the initial conditions (IC) Xo Yo, and various 
   other values used to control the form of the graphical display.
       The main program IVP consists of 2 procedures: 
              INITIALIZE
              OPTIONS
       INITIALIZE assigns nominal values to the DE, IC and other variables.
       The procedure OPTIONS allows the user to select various options.
       
       The PROCEDURES used in this program appear in the code in the 
  following order.  Indenting indicates that the procedure is local to
  the procedure above it.
  
       Utility Procedures:
           GET_FUNCTION     (in the unit post_entry_of_function) 
           REPLACE_FUNCTION (in the unit post_entry_of_function)
           DRAWLINE         (an external procedure)
           CLEAR            (clears text on a section of a row)
           INPUT_FUNC       (to type in a function expression)
           INPUT_CONST      (to type in a constant expression)
           SET_SCREEN       (clears and resets xy grid)
                BOUNDRIES      (draws boundries for xy grid)
                AXES           (draws xy axes)
                LABEL_AXES     (prints scale values for xy grid)
           CONVERT          (converts xy from actual to screen pt. values)
           PRTOK            (boolean fuction: true if pt is on screen)
           TABLE_HEAD       (prints heading for xy table)
           LIST_TABLE       (prints x,y or x,y,y-Y table values)
           
       Program Structure:
           INITIALIZE       (initializes values of functions and variables)
                ZAP_AXES         (erases or plots xy axes)
                DESCRIBE_PROGRAM (describes program options)
           OPTIONS      (displays options)
                ENTER_DE     (to enter dy/dx=F(x,y) )
                ENTER_IC     (to enter Xo,Yo)
                ENTER_SOLN   (to enter Y(x) )
                OMIT_SOLN    (omits Y(x) )
                ENTER_DX     (to enter Dx increment value)
                ENTER_XF     (to enter final x value (Xf) )
                SCREEN_LIMITS(for xy grid limits)
                     GET_XRANGE  (options for xmin,xmax values)
                     GET_YRANGE  (options for ymin,ymax values)
                         COMPUTE_YRANGE (computes ymin and ymax)
                SW_TAB_OPT   (displays table_option as ON or OFF)
                PLOT_SOLN    (plots Y(x) vs x )
                EULER        (Euler <increment> soln to IVP)
                RUNGE        (4th order Runge-Kutta soln to IVP)
                
     Changes made by reviewer:
        Removed definitions of RLF and CEOL.
        Added line DEFINESTRINGS.
        Replaced PAGE(OUTPUT) with CLEARSCREEN.
        Reversed ranges in SCREENTYPE.
                ---Henry E. Baumgarten
}

USES {$U GRAPH.LIBRARY} SCREEN_STUFF, POST_ENTRY_OF_FUNCTION;
   { POST_ENTRY was written by Ed Grundler. This unit contains procedures:
      GET_FUNCTION and REPLACE_FUNCTION; the interface variables are:
      ENTERED_FUNCTION and  ERROR_CODE }
        
CONST RW=20;
      XLEFT=28; XRIGHT=228; { screen boundries }
      YTOP=25; YBOT=225;    { for x,y graph    }
   
TYPE SCREENTYPE=PACKED ARRAY[0..239,0..319] OF BOOLEAN;
     XSCREEN=0..319;
     YSCREEN=0..239;
     XTEXT=0..79;
     YTEXT=0..23;

VAR X0,Y0,XF,DX,XSCALE,YSCALE,YMIN,YMAX,XMIN,XMAX,XRANGE,YRANGE: REAL;
    Y_AT_BOT,Y_AT_TOP: REAL;
    L: YSCREEN;
    R,XSTART,YSTART: INTEGER;
    S: SCREENTYPE;
    ESC,LF,KB: CHAR;
    SOLN,XSTOP,TABLE_OPTION,LISTING_SOLN,LIST_OPTIONS: BOOLEAN;
    FXY,FX: STRING;
    XTAB,YTAB: ARRAY[1..17] OF REAL;
    OPTION_KEYS: SET OF CHAR;
    
PROCEDURE DRAWLINE(VAR RANGE:INTEGER;VAR SCREEN:SCREENTYPE;RW,
    XSTART,YSTART,DX,DY,INK:INTEGER); EXTERNAL;
    { Drawline is an external procedure }
    

PROCEDURE CLEAR(ROW:YTEXT; LEFT,RIGHT:XTEXT);
VAR COL: XTEXT;
BEGIN
    GOTOXY(LEFT,ROW);
    IF RIGHT = 79
        THEN WRITE(CEOL)
        ELSE FOR COL:= LEFT TO RIGHT DO WRITE(' ');
END;

PROCEDURE INPUT_FUNC;
BEGIN
  IF EOF THEN RESET(INPUT); { recovers from accidental etx entry }
  GET_FUNCTION;
  IF ERROR THEN
    BEGIN
      GOTOXY(10,3); WRITE('***INPUT ERROR***');
      GOTOXY(10,4);
      CASE ERROR_CODE OF
        1: WRITELN('UNBALANCED PARENTHESES');
        2: WRITELN('UNRECOGNIZED SYMBOL');
        3: WRITELN('MULTIPLE DEC. PT. IN CONSTANT');
       15: WRITELN('ARGUMENT NOT IN PARENTHESES');
        END;
      GOTOXY(10,6); WRITE('sp bar to re-enter data');
      READ(KEYBOARD,KB);
      FOR L:=3 TO 6 DO CLEAR(L,10,40);
    END;
END; { of procedure input_func }

PROCEDURE INPUT_CONST(VAR V:REAL; ROW:YTEXT; LEFT,RIGHT:XTEXT);
BEGIN
  REPEAT
    CLEAR(ROW,LEFT,RIGHT);
    GOTOXY(LEFT,ROW);
    INPUT_FUNC;
  UNTIL NOT ERROR;
  V:=F(0,0,0);
END; { or procedure input_const }
    
PROCEDURE SET_SCREEN;
   
   PROCEDURE BOUNDRIES; { local to procedure set_screen }
   BEGIN { draw boarders }
     DRAWLINE(R,S,RW,0,0,319,0,1); { top screen }
     DRAWLINE(R,S,RW,319,0,0,239,1); { right screen }
     DRAWLINE(R,S,RW,319,239,-319,0,1); { bottom screen }
     DRAWLINE(R,S,RW,0,239,0,-239,1); { left screen }
     DRAWLINE(R,S,RW,XLEFT-1,YTOP,XRIGHT-XLEFT+1,0,1); { top grid }
     DRAWLINE(R,S,RW,XRIGHT,YTOP,0,YBOT-YTOP,1); { right grid }
     DRAWLINE(R,S,RW,XRIGHT,YBOT,-(XRIGHT-XLEFT),0,1); { bottom grid }
     DRAWLINE(R,S,RW,XLEFT,YBOT,0,-(YBOT-YTOP),1); { left grid }
   END; { of procedure boundries }
   
   PROCEDURE AXES; { local to procedure set_screen }
   BEGIN
     IF YMIN*YMAX<=0 THEN { draw x axes }
        DRAWLINE(R,S,RW,XLEFT,YBOT-ROUND(-YMIN*YSCALE),XRIGHT-XLEFT,0,1);
     IF XMIN*XMAX<=0 THEN { draw y axes }
        DRAWLINE(R,S,RW,XLEFT+ROUND(-XMIN*XSCALE),YTOP,0,YBOT-YTOP,1);
   END; { of procedure axes }
   
   PROCEDURE LABEL_AXES; { local to procedure set_screen }
   VAR I: INTEGER;
       XDIV,YDIV: REAL;
   BEGIN { put numeric lables on axes }
     YDIV:=(YBOT-YTOP)/10.0;
     FOR I:=0 TO 10 DO DRAWLINE(R,S,RW,XLEFT,YTOP+ROUND(YDIV*I),4,0,1);
     XDIV:=(XRIGHT-XLEFT)/10.0;
     FOR I:=0 TO 10 DO DRAWLINE(R,S,RW,XLEFT+ROUND(XDIV*I),YBOT,0,-4,1);
     { the following numeric lable values assume a "200 by 200" graph }
     GOTOXY(0,2);
     FOR I:=0 TO 10 DO
       BEGIN
         WRITELN(YMAX-I*YRANGE/10:7:3);
         IF I<>10 THEN WRITELN
       END;
     FOR I:=0 TO 5 DO
       BEGIN
         GOTOXY(10*I,23);
         WRITE(XMIN+I*XRANGE/5:10:5);
       END;
   END; { of procedure label_axes }

BEGIN { procedure set_screen }
  FILLCHAR(S,9600,CHR(0)); { clear graphics }
  BOUNDRIES;
  AXES;
  LABEL_AXES
END; { of procedure set_screen }
  
PROCEDURE CONVERT(X,Y:REAL; VAR XPLOT,YPLOT:INTEGER);
BEGIN
  IF ABS((X-XMIN)*XSCALE) < 32000
     THEN XPLOT:=XLEFT+ROUND((X-XMIN)*XSCALE)
     ELSE XPLOT:=0; { pt will not be plotted }
  IF (Y > Y_AT_BOT) AND (Y < Y_AT_TOP) THEN YPLOT:=YBOT-ROUND((Y-YMIN)*YSCALE);
  IF Y <= Y_AT_BOT THEN YPLOT:=239; { below screen values = bot of screen }
  IF Y >= Y_AT_TOP THEN YPLOT:=0;   { above screen values = top of screen }
END; { of procedure convert }
  
FUNCTION PRTOK(X1,Y1,X2,Y2:INTEGER):BOOLEAN;
BEGIN
  PRTOK:=(X1 IN [0..319]) AND (X2 IN [0..319])
          AND (Y1 IN [0..239]) AND (Y2 IN [0..239]);
  IF (Y1<YTOP) AND (Y2>YBOT) THEN PRTOK:=FALSE; { a check to avoid plotting }
  IF (Y1>YBOT) AND (Y2<YTOP) THEN PRTOK:=FALSE; { "discontinuities" in Y(x) }
END; {  of function prtok }

PROCEDURE TABLE_HEAD;
BEGIN
  GOTOXY(57,4);
  IF SOLN 
      THEN WRITE('   X    Y approx Y-Y(x)')
      ELSE WRITE('     X       Y approx. ');
END; { of procedure table_head }

PROCEDURE LIST_TABLE(N:INTEGER);
BEGIN
  IF SOLN THEN
    BEGIN ENTERED_FUNCTION:=FX; REPLACE_FUNCTION END;
  FOR L:=1 TO N DO
    BEGIN
      GOTOXY(58,L+4); { line L+4 }
      IF (NOT SOLN) OR (LISTING_SOLN)
         THEN WRITE(XTAB[L]:10:4,YTAB[L]:11:5)
         ELSE WRITE(XTAB[L]:7:3,YTAB[L]:7:3,YTAB[L]-F(XTAB[L],0,0):7:4);
    END;
  GOTOXY(58,5+N);
  WRITE('sp_bar or E)nd plot');
  READ(KEYBOARD,KB);
  FOR L:=5 TO (N+5) DO CLEAR(L,55,79);
  IF KB='E' THEN XSTOP:=TRUE;
  IF SOLN AND (NOT LISTING_SOLN) THEN
    BEGIN ENTERED_FUNCTION:=FXY; REPLACE_FUNCTION END;
END; { of procedure list_table }

{ end of the utility procedures }

{ beginning of program procedures }

PROCEDURE INITIALIZE;

   PROCEDURE ZAP_AXES(INK:INTEGER); { local to procedure initialize }
      BEGIN
        IF YMIN*YMAX<=0 THEN { draw x axes }
           DRAWLINE(R,S,RW,XLEFT,YBOT-ROUND(-YMIN*YSCALE),XRIGHT-XLEFT,0,INK);
        IF XMIN*XMAX<=0 THEN { draw y axes }
           DRAWLINE(R,S,RW,XLEFT+ROUND(-XMIN*XSCALE),YTOP,0,YBOT-YTOP,INK);
      END; { of procedure zap_axes }
   
   PROCEDURE DESCRIBE_PROGRAM; { local to procedure initialize }
     BEGIN
       GOTOXY(15, 3); WRITE('******Initial Value Problem (IVP)*******');
       GOTOXY(15, 4); WRITE('  An IVP consists of a differential');
       GOTOXY(15, 5); WRITE('equation, dy/dx, and initial conditions,');
       GOTOXY(15, 6); WRITE('(Xo,Yo).');
       GOTOXY(15, 7); WRITE('  This program plots solutions to IVPs.');
       GOTOXY(15, 8); WRITE('You will have various options to modify');
       GOTOXY(15, 9); WRITE('the IVP, the solution method, and the');
       GOTOXY(15,10); WRITE('screen display.');
       GOTOXY(15,12); WRITE('****Instructions****');
       GOTOXY(15,13); WRITE('  To select an option: type the letter');
       GOTOXY(15,14); WRITE('     associated with the option.');
       GOTOXY(15,15); WRITE('  To enter data: type the expression');
       GOTOXY(15,16); WRITE('     then type the RETURN key.');
       GOTOXY(15,18); WRITE('  Type SPACE_BAR to see the OPTIONS ');
     END; { of procedure describe_program }
   
 BEGIN { procedure initialize }
   ESC:=CHR(27); LF:=CHR(10); DEFINESTRINGS;
   CLEARSCREEN;
   FILLCHAR(S,9600,CHR(0));
   UNITWRITE(3,S,63);
   OPTION_KEYS:=['F','I','Y','O','D','X','C','L','T','P','E','R','B','Q',
                 'f','i','y','o','d','x','c','l','t','p','e','r','b','q'];
   X0:=0; Y0:=-0.5; XF:=2; DX:=0.1;
   XMIN:=-2; XMAX:=2; XRANGE:=XMAX-XMIN;
   YMIN:=-1; YMAX:=3; YRANGE:=YMAX-YMIN;
   XSCALE:=(XRIGHT-XLEFT)/XRANGE;
   YSCALE:=(YBOT-YTOP)/YRANGE;
   Y_AT_BOT:=YMIN-(239-YBOT)/YSCALE; { y value at bottom of screen }
   Y_AT_TOP:=YMAX+YTOP/YSCALE;       { y value at top of screen }
   SET_SCREEN;
   FXY:='X';
   GOTOXY(0,0); WRITE('dy/dx=F(x,y)= ',FXY);
   GOTOXY(40,0); WRITE('Xo=',X0:8:4);
   GOTOXY(40,1); WRITE('Yo=',Y0:8:4);
   FX:='XX/2 - 1/2';
   SOLN:=TRUE;
   LISTING_SOLN:=FALSE;
   TABLE_OPTION:=TRUE;
   LIST_OPTIONS:=TRUE;
   GOTOXY(0,1); WRITE('Soln=Y(x)= ',FX);
   GOTOXY(60,0); WRITE('Xf=',XF:8:4);
   GOTOXY(60,1); WRITE('Dx=',DX:8:4);
   ZAP_AXES(2);
   DESCRIBE_PROGRAM;
   READ(KEYBOARD,KB);
   FOR L:=3 TO 18 DO CLEAR(L,15,79);
   ZAP_AXES(1);
END; { of procedure initialize }

PROCEDURE OPTIONS;
  
    PROCEDURE ENTER_DE; { local to procedure opions }
    BEGIN
      REPEAT
        CLEAR(0,13,39);
        GOTOXY(13,0);
        INPUT_FUNC;
      UNTIL NOT ERROR;
      FXY:=ENTERED_FUNCTION
    END; { of procedure enter_de }

    PROCEDURE ENTER_IC; { local to procedure opions }
    BEGIN
      CLEAR(0,43,59);
      GOTOXY(43,0); INPUT_CONST(X0,0,43,59);
      CLEAR(0,43,59);
      GOTOXY(43,0); WRITE(X0:8:4);
      CLEAR(1,43,59);
      GOTOXY(43,1); INPUT_CONST(Y0,1,43,59);
      CLEAR(1,43,59);
      GOTOXY(43,1); WRITE(Y0:8:4);
    END; { of procedure enter_ic }

    PROCEDURE ENTER_SOLN; { local to procedure options}
    BEGIN
      REPEAT
        CLEAR(1,10,39);
        GOTOXY(10,1);
        INPUT_FUNC;
      UNTIL NOT ERROR;
      SOLN:=TRUE;
      FX:=ENTERED_FUNCTION
    END; { of procedure enter_soln }
    
    PROCEDURE OMIT_SOLN; { local to procedure options }
    BEGIN
      CLEAR(1,10,39);
      GOTOXY(10,1); WRITE('<no solution entered>');
      SOLN:=FALSE
    END; { of porcedure omit_soln }
    
    PROCEDURE ENTER_DX; { local to procedure options }
    BEGIN
      CLEAR(1,63,79);
      GOTOXY(63,1);
      INPUT_CONST(DX,1,63,79);
      CLEAR(1,63,79);
      GOTOXY(63,1); WRITE(DX:8:4);
    END; { of procedure enter_dx }

    PROCEDURE ENTER_XF; { local to procedure options }
    BEGIN
      CLEAR(0,63,79);
      GOTOXY(63,0);
      INPUT_CONST(XF,0,63,79);
      CLEAR(0,63,79);
      GOTOXY(63,0); WRITE(XF:8:4);
    END; { of procedure enter_xf }
    
    PROCEDURE SCREEN_LIMITS; { local to procedure options }
    
      PROCEDURE GET_XRANGE; { local to procedure screen_limits }
      BEGIN
        GOTOXY(60,3);  WRITE('  X LIMITS ON GRAPH ');
        GOTOXY(60,4);  WRITE('XMIN=',XMIN:8:3);
        GOTOXY(60,5);  WRITE('XMAX=',XMAX:8:3);
        GOTOXY(60,6);  WRITE('***OPTIONS***');
        GOTOXY(60,7);  WRITE('*FOR X RANGE*');
        GOTOXY(60,9);  WRITE('(N) No change');
        GOTOXY(60,10); WRITE('(I) Input new values');
        GOTOXY(60,11); WRITE('(U) Use Xo Xf values');
        REPEAT
          GOTOXY(60,13);
          WRITE('type N,I, or U');
          READ(KEYBOARD,KB);
        UNTIL KB IN ['N','I','U','n','i','u'];
        IF KB IN ['n','i','u'] THEN KB:=CHR(ORD(KB)-32); {to upper case}
        IF KB <> 'I'
             THEN FOR L:=3 TO 13 DO CLEAR(L,60,79)
             ELSE FOR L:=6 TO 13 DO CLEAR(L,60,79);
        CASE KB OF
          'N': EXIT(GET_XRANGE);
          'I': BEGIN
                 REPEAT
                   INPUT_CONST(XMIN,4,65,79);
                   INPUT_CONST(XMAX,5,65,79)
                 UNTIL XMAX > XMIN;
                 FOR L:=3 TO 5 DO CLEAR(L,60,79);
               END;
          'U': BEGIN
                 XMIN:=X0; XMAX:=XF
               END;
          END; { of case opt }
        XRANGE:=XMAX-XMIN;
        XSCALE:=(XRIGHT-XLEFT)/XRANGE; { graphic pts / x units }
        SET_SCREEN
      END; { of procedure get_xrange }
      
      PROCEDURE GET_YRANGE; { local to procedure screen_limits }
      VAR X1,Y1,DELX: REAL;
         
         PROCEDURE COMPUTE_YRANGE; { local to procedure get_yrange}
         BEGIN
           GOTOXY(60,3); WRITE('*computing y range*');
           Y1:=F(XMIN,0,0);
           YMIN:=Y1; YMAX:=Y1;
           DELX:=1/XSCALE;
           IF SOLN 
             THEN
               BEGIN
                 GOTOXY(60,4); WRITE('* using soln Y(x) *');
                 ENTERED_FUNCTION:=FX;
                 REPLACE_FUNCTION;
                 X1:=XMIN;
                 REPEAT
                   Y1:=F(X1,0,0);
                   IF Y1>YMAX THEN YMAX:=Y1;
                   IF Y1<YMIN THEN YMIN:=Y1;
                   X1:=X1+DELX;
                 UNTIL X1>XMAX;
               END
             ELSE
               BEGIN
                 GOTOXY(60,4); WRITE('using DE dy/dx');
                 ENTERED_FUNCTION:=FXY;
                 REPLACE_FUNCTION;
                 X1:=X0; Y1:=Y0;
                 REPEAT
                   Y1:=Y1+F(X1,Y1,0)*DELX;
                   IF Y1>YMAX THEN YMAX:=Y1;
                   IF Y1<YMIN THEN YMIN:=Y1;
                   X1:=X1+DELX
                 UNTIL X1>XMAX;
                 X1:=X0; Y1:=Y0;
                 REPEAT
                   Y1:=Y1+F(X1,Y1,0)*(-DELX);
                   IF Y1>YMAX THEN YMAX:=Y1;
                   IF Y1<YMIN THEN YMIN:=Y1;
                   X1:=X1-DELX
                 UNTIL X1<XMIN;
               END;
           IF YMAX > 2000 THEN YMAX:=2000;
           IF YMIN < -2000 THEN YMIN:=-2000;
           YRANGE:=YMAX-YMIN;
           IF YRANGE=0
             THEN { yrange=0 only if y=constant }
               BEGIN
                 YMIN:=YMIN-0.5; YMAX:=YMAX+0.5;
                 YRANGE:=1
               END
             ELSE
               BEGIN
                 YMIN:=YMIN-0.1*YRANGE;
                 YMAX:=YMAX+0.1*YRANGE;
                 YRANGE:=1.2*YRANGE
               END;
           FOR L:=3 TO 4 DO CLEAR(L,60,79)
        END; { of procedure compute_yrange }
            
      BEGIN { of procedure get_yrange }
        GOTOXY(60,3);  WRITE('Y LIMITS ON GRAPH   ');
        GOTOXY(60,4);  WRITE('YMIN=',YMIN:8:3);
        GOTOXY(60,5);  WRITE('YMAX=',YMAX:8:3);
        GOTOXY(60,6);  WRITE('***OPTIONS***');
        GOTOXY(60,7);  WRITE('*FOR Y RANGE*');
        GOTOXY(60,9);  WRITE('(N) No change');
        GOTOXY(60,10); WRITE('(I) Input new values');
        GOTOXY(60,11); WRITE('(C) Compute values');
        REPEAT
          GOTOXY(60,13);
          WRITE('type N,I, or C');
          READ(KEYBOARD,KB);
        UNTIL KB IN ['N','I','C','n','i','c'];
        IF KB IN ['n','i','c'] THEN KB:=CHR(ORD(KB)-32); {to upper case}
        IF KB <> 'I'
             THEN FOR L:=3 TO 13 DO CLEAR(L,60,79)
             ELSE FOR L:=6 TO 13 DO CLEAR(L,60,79);
        CASE KB OF
          'N': EXIT(GET_YRANGE);
          'I': BEGIN
                 REPEAT
                   INPUT_CONST(YMIN,4,65,79);
                   INPUT_CONST(YMAX,5,65,79)
                 UNTIL YMAX > YMIN;
                 YRANGE:=YMAX-YMIN;
                 FOR L:=3 TO 5 DO CLEAR(L,60,79);
               END;
          'C': COMPUTE_YRANGE
          END;
        YSCALE:=(YBOT-YTOP)/YRANGE; { graphic pts / y units }
        Y_AT_BOT:=YMIN-(239-YBOT)/YSCALE; { y value at bottom of screen }
        Y_AT_TOP:=YMAX+YTOP/YSCALE;       { y value at top of screen }
        SET_SCREEN
      END; { of procedure get_yrange }
    
    BEGIN { procedure screen_limits }
      GET_XRANGE;
      GET_YRANGE
    END; { of procedure screen_limits }

    PROCEDURE SW_TAB_OPT(K: CHAR); { local to procedure options }
    BEGIN
      IF K='Y' THEN TABLE_OPTIONS:=NOT TABLE_OPTIONS;
      GOTOXY(77,14);
      IF TABLE_OPTIONS
          THEN WRITE('ON ')
          ELSE WRITE('OFF');
    END; { of procedure sw_tab_opt }
    
    PROCEDURE PLOT_SOLN; { local to procedure options }
    VAR X,XINC: REAL;
        PX1,PX2,PY1,PY2,I: INTEGER;
    BEGIN { procedure plot_soln }
      IF (NOT SOLN) THEN EXIT(PLOT_SOLN);
      GOTOXY(60,3); WRITE('* plotting Y(x) *');
      LISTING_SOLN:=TABLE_OPTION;
      IF TABLE_OPTION THEN
         BEGIN
           GOTOXY(60,4); WRITE('  x         Y(x)')
         END;
      ENTERED_FUNCTION:=FX; REPLACE_FUNCTION;
      XINC:=1/XSCALE;
      X:=XMIN-XINC;
      REPEAT
        I:=0;
        REPEAT
          I:=I+1;
          X:=X+XINC;
          CONVERT(X,F(X,0,0),PX1,PY1);
          CONVERT(X,F(X+XINC,0,0),PX2,PY2);
          IF PRTOK(PX1,PY1,PX2,PY2) THEN
            DRAWLINE(R,S,RW,PX1,PY1,1,PY2-PY1,1);
          IF TABLE_OPTION THEN
             BEGIN XTAB[I]:=X; YTAB[I]:=F(X,0,0) END;
          XSTOP:=X>=XMAX
        UNTIL (XSTOP) OR (I>=16);
        IF TABLE_OPTION THEN
          BEGIN
            XTAB[I+1]:=X+XINC; YTAB[I+1]:=F(X+XINC,0,0);
            LIST_TABLE(I+1)
          END;
      UNTIL XSTOP;
      FOR L:=3 TO 4 DO CLEAR(L,60,79);
      LISTING_SOLN:=FALSE
    END; { of procedure plot_soln }
  
    PROCEDURE EULER; { local to options }
    VAR X,Y: REAL;
        DELTAX,DELTAY,XNEW,YNEW,I: INTEGER;
    BEGIN
      GOTOXY(57,2); WRITE('**Plotting EULER Soln**');
      GOTOXY(57,3); WRITE('  for approx. y values');
      ENTERED_FUNCTION:=FXY; REPLACE_FUNCTION;
      IF TABLE_OPTION THEN TABLE_HEAD;
      X:=X0; Y:=Y0;
      REPEAT
        I:=0;
        REPEAT
          I:=I+1;
          IF TABLE_OPTION THEN
            BEGIN
              XTAB[I]:=X; YTAB[I]:=Y
            END;
          CONVERT(X,Y,XSTART,YSTART);
          Y:=Y+F(X,Y,0)*DX; X:=X+DX; 
          CONVERT(X,Y, XNEW,YNEW);
          DELTAX:=XNEW-XSTART; DELTAY:=YNEW-YSTART;
          IF PRTOK(XSTART,YSTART,XNEW,YNEW) THEN 
              DRAWLINE(R,S,RW,XSTART,YSTART,DELTAX,DELTAY,1);
          IF DX>0 THEN XSTOP:=X>XF ELSE XSTOP:=X<XF;
        UNTIL (XSTOP) OR (I>=16);
        IF TABLE_OPTION THEN
          BEGIN
            XTAB[I+1]:=X; YTAB[I+1]:=Y;
            LIST_TABLE(I+1)
          END;
      UNTIL XSTOP;
      FOR L:=2 TO 4 DO CLEAR(L,57,79);
    END; { of procedure euler }

    PROCEDURE RUNGE; { local to procedure options }
    VAR X,Y,K,K1,K2,K3,K4,H: REAL;
        I,XOLD,YOLD,XNEW,YNEW,DELTAX,DELTAY: INTEGER;
    BEGIN
      GOTOXY(57,2); WRITE('**Plotting RUNGE-KUTTA*');
      GOTOXY(57,3); WRITE('soln for approx y val.');
      ENTERED_FUNCTION:=FXY; REPLACE_FUNCTION;
      IF TABLE_OPTION THEN TABLE_HEAD;
      H:=DX;
      X:=X0; Y:=Y0;
      REPEAT
        I:=0;
        REPEAT
          I:=I+1;
          K1:=F(X,Y,0);
          K2:=F(X+H/2,Y+K1*H/2,0);
          K3:=F(X+H/2,Y+K2*H/2,0);
          K4:=F(X+H, Y+K3*H,0);
          K:=(K1+2*K2+2*K3+K4)/6;
          IF TABLE_OPTION THEN
            BEGIN
              XTAB[I]:=X; YTAB[I]:=Y
            END;
          CONVERT(X,Y,XOLD,YOLD);
          X:=X+H; Y:=Y+K*H;
          CONVERT(X,Y,XNEW,YNEW);
          DELTAX:=XNEW-XOLD; DELTAY:=YNEW-YOLD;
          IF PRTOK(XOLD,YOLD,XNEW,YNEW) THEN 
            DRAWLINE(R,S,RW,XOLD,YOLD,DELTAX,DELTAY,1);
          IF DX>0 THEN XSTOP:=X>XF ELSE XSTOP:=X<XF;
        UNTIL (XSTOP) OR (I>=16);
      IF TABLE_OPTION THEN
        BEGIN
          XTAB[I+1]:=X; YTAB[I+1]:=Y;
          LIST_TABLE(I+1)
        END;
      UNTIL XSTOP;
      FOR L:=2 TO 4 DO CLEAR(L,57,79);
    END; { of procedure runge }
  
BEGIN { procedure options }
  REPEAT
    IF LIST_OPTIONS THEN
      BEGIN
        GOTOXY(57,3); WRITE('KEY******OPTIONS*******');
        GOTOXY(57,4); WRITE('**data change options**');
        GOTOXY(57,5); WRITE(' F  dy/dx = F(x,y)     ');
        GOTOXY(57,6); WRITE(' I  Initial cond. Xo,Yo');
        GOTOXY(57,7); WRITE(' Y  Soln. Y(x)         ');
        GOTOXY(57,8); WRITE(' O  Omit soln. Y(x)    ');
        GOTOXY(57,9); WRITE(' D  Dx integration step');
        GOTOXY(57,10);WRITE(' X  Xf = final x value ');
        GOTOXY(57,11);WRITE('****screeen options****');
        GOTOXY(57,12);WRITE(' C  Clear graph        ');
        GOTOXY(57,13);WRITE(' L  Limits on screen   ');
        GOTOXY(57,14);WRITE(' T  xy Table is now '); SW_TAB_OPT('N');
        GOTOXY(57,15);WRITE('*soln plotting options*');
        GOTOXY(57,16);WRITE(' P  Plot soln. Y(x)    ');
        GOTOXY(57,17);WRITE(' E  Euler (increment)  ');
        GOTOXY(57,18);WRITE(' R  Runge 4th order    ');
        GOTOXY(57,19);WRITE('**termination options**');
        GOTOXY(57,20);WRITE(' B  Begin program again');
        GOTOXY(57,21);WRITE(' Q  Quit program       ');
      END;
    REPEAT
      GOTOXY(61,23); WRITE('TYPE OPTION KEY:');
      READ(KEYBOARD,KB);
    UNTIL KB IN OPTION_KEYS;
    IF KB IN ['a'..'z'] THEN KB:=CHR(ORD(KB)-32); { convert to upper case }
    CLEAR(23,61,79);
    LIST_OPTIONS:=KB IN ['L','P','E','R'];
    IF LIST_OPTIONS THEN FOR L:=3 TO 22 DO CLEAR(L,57,79);
    CASE KB OF
      'F': ENTER_DE;
      'I': ENTER_IC;
      'Y': ENTER_SOLN;
      'O': OMIT_SOLN;
      'D': ENTER_DX;
      'X': ENTER_XF;
      'C': SET_SCREEEN;
      'L': SCREEN_LIMITS;
      'T': SW_TAB_OPT('Y');
      'P': PLOT_SOLN;
      'E': EULER;
      'R': RUNGE;
      'B': EXIT(OPTIONS);
      'Q': BEGIN
             FILLCHAR(S,SIZEOF(S),FALSE);
             CLEARSCREEN;
             EXIT(IVP);
           END
       END;
  UNTIL FALSE;
END; { of procedure options }
  
BEGIN { main program ivp }
  REPEAT
    INITIALIZE;
    OPTIONS
  UNTIL FALSE;
END. { of main program ivp }


========================================================================================
DOCUMENT :usus Folder:VOL22:plotter.text
========================================================================================

{
 This unit was assembled for use with Grundler programs using the PLOTTER unit.
 DMP2PLOT must be edited to use your serial board addresses or replaced with
 the following or something similar:
     TYPE BYTE = PACKED ARRAY[0..0] OF 0..255;
     PROCEDURE DMP2PLOT(CH : CHAR);
     VAR  OUTCODE : BYTE;
     BEGIN
       OUTCODE := ORD(CH);
       UNITWRITE(8,OUTCODE,1)
     END;
 to use REMOUT (not recommended). HPXMAX and HPYMAX will have to be redefined
 for use with the large, "dumb" Hiplot. The "smart" Hiplots may also be used
 but require more complex routines than those given here. 
      The THROTTLE routine may be removed by Terak users as a similar routine
 is in the Terak library.
 }

UNIT PLOTTER;   {Version 1.1, 23 Dec 1982}
INTERFACE

VAR     PENSTATE,PLOT_XLOC,PLOT_YLOC,OLDIPX,OLDIPY  : INTEGER;
        OLDPEN : BOOLEAN;
        
PROCEDURE THROTTLE(TICKS: INTEGER);

PROCEDURE PLOT(PMODE,X,Y : INTEGER);

PROCEDURE INITPLOT;

IMPLEMENTATION

CONST   HPXMAX = 2000;  (*maximum horizontal plotter steps*)
        HPYMAX = 1400;  (*maximum vertical plotter steps*)

PROCEDURE THROTTLE(*TICKS:INTEGER*);
  
  VAR   COUNT,HITIME,START,STOP,TIMEDIFF : INTEGER;
  BEGIN
    COUNT := 0;
    TIME(HITIME,START);
    REPEAT
      COUNT := COUNT+1;  (*Without counter routine, CPU is too fast and
                           will stop and give the error message even if 
                           the clock is on.  The value 1000 works but has not
                           been optimized. Presumably it could be smaller.*)
      TIME(HITIME,STOP);
      TIMEDIFF := STOP-START;
      IF (TIMEDIFF < 0) THEN TIMEDIFF := TIMEDIFF+32767;
      IF ((TIMEDIFF = 0) AND (COUNT = 1000)) THEN
        BEGIN
          GOTOXY(0,23);
          WRITE(CHR(7),'Turn on the line time clock! Type <RTN> to continue.');
          READLN
        END;
      UNTIL (TIMEDIFF >= TICKS)
  END;
  
PROCEDURE DMP2PLOT(CH : CHAR);

{Note: address of serial board receiver status register and receiver buffer
 must be specified in decimal.  The easy way to do this is illustrated for
 the standard REMOUT addresses, 177524 and 177526 (not used by the reviewer):
    200000 - 177524 = 0252 (8)   (using octal arithmetic)
    (0*512)+(2*64)+(5*8)+(2*1) = 172 (10)
    PXCSR = -172
    PXBUF = -170}

  CONST PXCSR = -684 (*176524 (octal); also reviewer's REMOUT address
                        but seems to cause no problems*);
        PXBUF = -682 (*176526 (octal)*); 
        BITNO = 7;
  TYPE  INFO = PACKED RECORD CASE BOOLEAN OF
          TRUE : (CH : PACKED ARRAY [0..1] OF CHAR);
          FALSE : (BIT : PACKED ARRAY [0..15] OF BOOLEAN);
        END;
        IOPORT = PACKED RECORD CASE BOOLEAN OF
          TRUE : (ADDR : INTEGER);
          FALSE : (PNTR : ^INFO)
        END;
  VAR   XCSR,XBUF : IOPORT;
  
  BEGIN
    REPEAT
      XCSR.ADDR := PXCSR
    UNTIL XCSR.PNTR^.BIT[BITNO];
    XBUF.ADDR := PXBUF;
    XBUF.PNTR^.CH[0] := CH;
  END;

PROCEDURE ENCODE(COMMAND : INTEGER);

  CONST SP = ' ';
        DELAY = 24;  (*delay for pen changes*)
  
  VAR   PENCODE2 : CHAR;
        I : INTEGER;
        
  BEGIN
    IF (COMMAND IN [0..10]) THEN
      BEGIN
        CASE COMMAND OF
          0 : PENCODE2 := ' ';     (*delay*)
          1 : PENCODE2 := 't';     (*-y*)
          2 : PENCODE2 := 'p';     (*+y*)
          3 : PENCODE2 := 'z';     (*pen down*)
          4 : PENCODE2 := 'v';     (*-x*)
          5 : PENCODE2 := 'u';     (*-x,-y*)
          6 : PENCODE2 := 'w';     (*-x,+y*)
          7 : PENCODE2 := 'y';     (*pen up*)
          8 : PENCODE2 := 'r';     (*+x*)
          9 : PENCODE2 := 's';     (*+x,-y*)
         10 : PENCODE2 := 'q';     (*+x,+y*)
       END;
       DMP2PLOT(PENCODE2);
       IF ((COMMAND IN [3,7]) AND (COMMAND <> PENSTATE)) THEN
         BEGIN 
           PENSTATE := COMMAND;
           FOR I := 1 TO DELAY DO DMP2PLOT(SP)  (*Output spaces for pen delay*)
        END                                   (*Could use THROTTLE(10) instead*)
     END;
  END;

PROCEDURE PLOTMOVE(PMODE,PMOVE : INTEGER);
  BEGIN
    IF NOT (PMODE IN [0..4]) THEN EXIT(PLOTMOVE);
    CASE PMODE OF
      0 : IF (OLDPEN) THEN
            BEGIN
              ENCODE(7);  (*raise before*)
              OLDPEN := FALSE
            END;
      1 : IF (NOT OLDPEN) THEN
            BEGIN
              ENCODE(3);  (*lower before*)
              OLDPEN := TRUE
            END;
      2 : BEGIN
            OLDIPX := 0;     (*set current pen position as plotter origin*)
            OLDIPY := 0;
            PENSTATE := 0;
            EXIT(PLOTMOVE)
          END;
      3,4 : ;
    END; (*case*)
    ENCODE(PMOVE)
  END;
  
  {The following is based on the Grundler GRAPHICS unit, which appears to
   be based on the DRAWLINE implementation described in the UCSD manual for
   version 1.5} 

PROCEDURE PLOT(*PMODE,X,Y : INTEGER*);

VAR     DELTAX,DELTAY,XINC,YINC,XCODE,YCODE,XYCODE,PMOVE : INTEGER;

  PROCEDURE DOFORX;   {MORE HORIZONTAL}
  
    VAR ERROR,I:INTEGER;
    BEGIN
      IF DELTAX=0 THEN EXIT(PLOT);
      ERROR:=DELTAX DIV 2;
      I:=DELTAX;
      REPEAT
        X := X+XINC;
        ERROR:=ERROR+DELTAY;
        IF ERROR>=DELTAX THEN
          BEGIN
            ERROR:=ERROR-DELTAX;
            Y := Y+YINC;
            PMOVE := XYCODE;
          END
        ELSE PMOVE := XCODE;
        PLOTMOVE(PMODE,PMOVE);
        I:=I-1;
      UNTIL I=0
    END (*DOFORX*);
    
  PROCEDURE DOFORY;   {MORE VERTICAL}
    
    VAR ERROR,I:INTEGER;
    BEGIN
      ERROR:=DELTAY DIV 2;
      I:=DELTAY;
      REPEAT
        Y := Y+YINC;
        ERROR:=ERROR+DELTAX;
        IF ERROR>=DELTAY THEN
          BEGIN
            ERROR:=ERROR-DELTAY;
            X := X+XINC;
            PMOVE := XYCODE;
          END
        ELSE PMOVE := YCODE;
        PLOTMOVE(PMODE,PMOVE);
        I:=I-1;
      UNTIL I=0
    END (*DOFORY*);
    
    BEGIN (*PLOT*)
      IF (X>HPXMAX) THEN DELTAX := HPXMAX-PLOT_XLOC
        ELSE IF (X<0) THEN DELTAX := -PLOT_XLOC
        ELSE DELTAX := X-PLOT_XLOC;
      IF (Y>HPYMAX) THEN DELTAY := HPYMAX-PLOT_YLOC
        ELSE IF (X<0) THEN DELTAX := -PLOT_YLOC
        ELSE DELTAY := Y-PLOT_YLOC;
      OLDIPX := X;
      OLDIPY := Y;
      PLOT_XLOC := PLOT_XLOC+DELTAX;
      PLOT_YLOC := PLOT_YLOC+DELTAY;
      IF DELTAX < 0 THEN
        BEGIN
          XCODE := 4;
          XINC := -1;
          DELTAX := -DELTAX
        END
      ELSE
        BEGIN
          XCODE := 8;
          XINC := 1
        END;
      IF DELTAY < 0 THEN
        BEGIN
          YCODE := 1;
          YINC := -1;
          DELTAY := -DELTAY
        END
      ELSE
        BEGIN
          YCODE := 2;
          YINC := 1
        END;
      XYCODE := XCODE+YCODE;
      IF DELTAX >= DELTAY THEN DOFORX ELSE DOFORY;
    END (*PLOT*);

PROCEDURE INITPLOT;
  BEGIN
    PLOTMOVE(2,0);
    ENCODE(7);
    OLDPEN := FALSE;
    PLOT_XLOC := 0;      (*actual pen coordinates for limiting pen motion*)
    PLOT_YLOC := 0;    (*assumes that origin will be extreme lower, left corner*)
  END;
END.

========================================================================================
DOCUMENT :usus Folder:VOL22:polar.text
========================================================================================

{$S+}

{
                                                  program by: DENNIS E. GRUNDLER
     Changes made and comments by reviewer:
       Changed CHR(CLR_EOL) to CEOL and removed definition of CLR_EOL.
       Placed definition of CLEAR_LINE in SCREEN_STUFF.
       Changed PAGE(OUTPUT) to CLEARSCREEN.
       Added USES SCREEN_STUFF.
       Provided unit PLOTTER.
       Reversed range of subscripts in SCREENTYPE.
       Added boolean variable, PLOT_STARTED (apparently in
         original PLOTTER unit).
       Added line PLOT_STARTED := FALSE; in procedure PLOT_IT.
       Defined UP and DOWN (apparently in original plotter unit).
       FUNCTION CHECK does NOT protect the plotter; if used with the simple
         Hiplots, it may be wise to consider rewriting this function.
       The Grundlers routinely use the system to define pi, using 
         PI := 4*ATAN(1). This is all right as long as ATAN gives the
         same accuracy as real number accuracy, but why not just enter
         PI = 3.14159 26535 89793 23846 as a constant to the accuracy of
         your choice.
       Added error message 15.
}
PROGRAM POLAR;

USES {$U GRAPH.LIBRARY} SCREEN_STUFF, PLOTTER,
  POST_ENTRY{the latter by: EDWARD J. GRUNDLER };

CONST ROWWIDTH=20;
      INK=1;
      UP=0;
      DOWN=1;
TYPE SCREENTYPE = PACKED ARRAY [0..239,0..319] OF BOOLEAN;

VAR SCREEN:SCREENTYPE;
    HIPLOT,TABLE,FIRST_TIME:BOOLEAN;
    RANGE:INTEGER;
    PI,SCALE,UNIT_SCALE,XI,XF,DELTA_ANGLE:REAL;
    MODE: 1..3;
    CH:CHAR;
    SAVED_FUNCTION:STRING;
    PLOT_STARTED:BOOLEAN;
    
PROCEDURE DRAWLINE(VAR RANGE:INTEGER; VAR SCREEN:SCREENTYPE; ROWWIDTH,
                   XSTART,YSTART,DX,DY,INK:INTEGER);EXTERNAL;
                   
PROCEDURE INITIALIZE;

PROCEDURE GET_VALUE(PROMPT:STRING;VAR VALUE:REAL);

BEGIN{ GET_VALUE}
   SAVED_FUNCTION:=ENTERED_FUNCTION;
   GOTOXY(5,7);
   WRITE(PROMPT);
   GET_FUNCTION;
   VALUE:=F(0,0,0);
   GOTOXY(0,7);
   WRITE(CEOL);
   ENTERED_FUNCTION:=SAVED_FUNCTION;
   REPLACE_FUNCTION;
END;

PROCEDURE MODIFY_VARIABLES;

PROCEDURE CHANGE_EM(TEMP:REAL);

BEGIN {CHANGE_EM}
   XI:=XI*TEMP;
   XF:=XF*TEMP;
   DELTA_ANGLE:=DELTA_ANGLE*TEMP;
   GOTOXY(18,8);
   WRITE(XI:10:4,CEOL);
   GOTOXY(18,9);
   WRITE(XF:10:4,CEOL);
   GOTOXY(18,10);
   WRITE(DELTA_ANGLE:10:4,CEOL);
   GOTOXY(23,11);
   CASE MODE OF
     1 : WRITE('DEGREES',CEOL);
     2 : WRITE('RADIANS',CEOL);
     3 : WRITE('PI RADIANS',CEOL);
   END{ OF CASE};
END {OF CHANGE_EM};

BEGIN {MODIFY_VARIABLES}
   CASE CH OF 
     'F','f' : BEGIN
                  REPEAT
                     GOTOXY(0,5);
                     WRITE('r(x) = ',CEOL);
                     GET_FUNCTION;
                     IF ERROR THEN 
                        BEGIN
                           GOTOXY(0,6);
                           WRITE(CHR(7{BELL}));
                           CASE ERROR_CODE OF
                             1 : WRITE('<<<< UNBALANCED PARENTHESIS >>>>',CEOL);
                             2 : WRITE('<<<< UNRECOGNIZED SYMBOL >>>>',CEOL);
                             3 : WRITE('<< MULTIPLE DECIMAL POINTS IN A CONSTANT >>',CEOL);
                            15 : WRITE('<< INVALID FUNCTION OR MISSING PARENS >>',CEOL);
                           END{ OF CASE};
                        END;
                  UNTIL NOT(ERROR);
                  GOTOXY(0,5);
                  WRITELN('r(x) = ',ENTERED_FUNCTION,CEOL);
                  WRITELN(CEOL);
               END;
     'B','b' : REPEAT
                  GET_VALUE('New starting angle = ',XI);
                  IF XF<>XI THEN 
                     BEGIN
                        GOTOXY(18,8);
                        WRITE(XI:10:4,CEOL);
                     END;
               UNTIL(XF<>XI);
     'E','e' : REPEAT
                  GET_VALUE('New ending angle = ',XF);
                  IF XF<>XI THEN 
                     BEGIN
                        GOTOXY(18,9);
                        WRITE(XF:10:4,CEOL);
                     END;
               UNTIL(XF<>XI);
     'D','d' : REPEAT
                  GET_VALUE('New Delta angle = ',DELTA_ANGLE);
                  IF DELTA_ANGLE<>0 THEN
                     BEGIN
                        GOTOXY(18,10);
                        WRITE(DELTA_ANGLE:10:4,CEOL);
                     END;
               UNTIL (DELTA_ANGLE<>0);
     'S','s' : BEGIN
                  GET_VALUE('New Scale magnification = ',SCALE);
                  IF SCALE<>0 THEN 
                     BEGIN
                        GOTOXY(8,12);
                        WRITE(SCALE:10:4,CEOL);
                     END;
               END;
     'U','u' : REPEAT
                  GET_VALUE('ENTER THE MAXIMUM RADIUS EXPECTED: ',UNIT_SCALE);
                  IF UNIT_SCALE>0 THEN
                     BEGIN
                        GOTOXY(13,13);
                        UNIT_SCALE:=100.0/UNIT_SCALE;
                        WRITE(UNIT_SCALE:10:4,CEOL);
                     END;
               UNTIL UNIT_SCALE>0;
     'M','m' : BEGIN
                  IF MODE = 3 THEN MODE:=1 ELSE MODE:=MODE+1;
                  CASE MODE OF
                    1 : CHANGE_EM(180/(PI*PI));
                    2 : CHANGE_EM(PI/180);
                    3 : CHANGE_EM(PI);
                  END;
               END;
     'C','c' : BEGIN
                  FILLCHAR(SCREEN,SIZEOF(SCREEN),0);
                  DRAWLINE(RANGE,SCREEN,ROWWIDTH,61,120,200,0,INK) {X-AXIS};
                  DRAWLINE(RANGE,SCREEN,ROWWIDTH,160,21,0,200,INK) {Y-AXIS};
               END;
     'Q','q' : BEGIN
                  UNITWRITE(3,SCREEN,7);
                  CLEARSCREEN;
                  EXIT(POLAR);
               END;
     'H','h' : HIPLOT:=TRUE;
   END {OF THE CASE};
   GOTOXY(5,24);
END {OF MODIFY_VARIABLES};
   

BEGIN {INITIALIZE}
   IF FIRST_TIME THEN
      BEGIN
         TABLE:=FALSE;
         FILLCHAR(SCREEN,SIZEOF(SCREEN),0);
         REPEAT
            CLEARSCREEN;
            WRITE('r(x) = ');
            GET_FUNCTION;
         UNTIL NOT(ERROR);
         DRAWLINE(RANGE,SCREEN,ROWWIDTH,61,120,200,0,INK) {X-AXIS};
         DRAWLINE(RANGE,SCREEN,ROWWIDTH,160,21,0,200,INK) {Y-AXIS};
         DELTA_ANGLE:=PI/180;
         XI:=0;
         XF:=8.0*ATAN(1.0);
         MODE:=2;
         SCALE:=1;
         UNIT_SCALE:=100;
         CLEARSCREEN;
         GOTOXY(0,4);
         WRITELN('THE ENTERED FUNCTION IS:',CEOL);
         WRITELN('r(x) = ',ENTERED_FUNCTION);
         WRITELN; WRITELN; 
         WRITELN('Beginning angle = ',XI:10:4);
         WRITELN('Ending angle =    ',XF:10:4);
         WRITELN('Delta angle =     ',DELTA_ANGLE:10:4);
         WRITE('Angular MODE is set at ');
         CASE MODE OF
           1 : WRITELN('DEGREES');
           2 : WRITELN('RADIANS');
           3 : WRITELN('PI RADIANS');
         END {OF CASE};
         WRITELN('Scale = ',SCALE:10:4);
         WRITELN('Unit scale = ',UNIT_SCALE:10:4);
         GOTOXY(0,15);
         WRITELN('The bell will sound at the end of the plot. ');
         WRITELN('Pressing any key will continue the program.');
         FIRST_TIME:=FALSE;
      END {OF FIRST TIME INITIALIZATIONS};
   UNITWRITE(3,SCREEN,7);
   GOTOXY(0,0);
   WRITELN('new F(unction; B(eginning angle; E(nding angle; D(elta angle; ');
   WRITE('S(cale magnification; angle M(ode; C(learscreen; ');
   WRITELN('U(nit scale; Q(uit the program.');
   WRITELN('H(ardcopy, press "P" to PLOT r(x)');
   WRITELN;
   HIPLOT:=FALSE;
   REPEAT
      READ(KEYBOARD,CH);
      MODIFY_VARIABLES;
      IF XF>XI THEN DELTA_ANGLE:= ABS(DELTA_ANGLE) ELSE DELTA_ANGLE:= 
          -ABS(DELTA_ANGLE);
   UNTIL (CH IN ['P','p']);
END {OF INITIALIZE};

PROCEDURE PLOTIT;

CONST  CR=13{ Carriage Return};
       
VAR X,Y,START_ANGLE,END_ANGLE,ANGLE_CHANGE,TEMP:REAL;
    XPLOT,YPLOT,XSTART,YSTART,DX,DY:INTEGER;
    

FUNCTION IN_RANGE:BOOLEAN;

BEGIN {IN RANGE}
   IN_RANGE:=(XSTART<320) AND (XSTART>-1) AND (YSTART<240) AND (YSTART>-1) AND
   (XSTART+DX<320) AND (XSTART+DX>-1) AND (YSTART+DY<240) AND (YSTART+DY>-1);
END {IN_RANGE};
   
FUNCTION CHECK(VALUE:REAL):INTEGER;
   
   BEGIN
      IF ABS(VALUE)>32767 THEN VALUE:=32767*ABS(VALUE)/VALUE;
      CHECK:=ROUND(VALUE);
   END;
   
PROCEDURE PLOT_OUT;

FUNCTION XRANGE:INTEGER;
VAR TEMP:INTEGER;
    DX_PLOTTER:INTEGER;

BEGIN
   DX_PLOTTER:=1000+CHECK(X*SCALE*UNIT_SCALE*7)-PLOT_XLOC;
   TEMP:=PLOT_XLOC+DX_PLOTTER;
   IF TEMP>2000 THEN TEMP:=2000;
   IF TEMP<0 THEN TEMP:=0;
   XRANGE:=TEMP;
END;

FUNCTION YRANGE:INTEGER;
VAR TEMP:INTEGER;
    DY_PLOTTER:INTEGER;

BEGIN
   DY_PLOTTER:=700+CHECK(Y*SCALE*UNIT_SCALE*7)-PLOT_YLOC;
   TEMP:=PLOT_YLOC+DY_PLOTTER;
   IF TEMP>1400 THEN TEMP:=1400;
   IF TEMP<0 THEN TEMP:=0;
   YRANGE:=TEMP;
END;

   
BEGIN {PLOT_OUT}
   IF NOT PLOT_STARTED THEN
      BEGIN
         GOTOXY(0,0);
         WRITELN('Position the plotter''s pen to the lower left corner.',
            CEOL);
         UNITCLEAR(2);
         WRITELN('Press RETURN to continue');
         READLN;
         {The next couple of lines clear the top three lines of text.}
         GOTOXY(0,0);
         WRITE(CLEAR_LINE,CLEAR_LINE,CLEAR_LINE);
         GOTOXY(35,0);
         WRITELN('POLAR PLOT');
         PLOT_STARTED:=TRUE;
         PLOT(UP,0,700);
         PLOT(DOWN,2000,700);
         PLOT(UP,1000,0);
         PLOT(DOWN,1000,1400);
         PLOT(UP,XPLOT,YPLOT);
         WRITELN('YOU MAY WANT TO CHANGE COLORS, press RETURN to continue');
         READLN;
         GOTOXY(0,1);
         WRITELN(CEOL);
         UNITREAD(2,CH,1,,1);
      END;
   IF NOT ERROR THEN PLOT(DOWN,XRANGE,YRANGE);
END;
   
BEGIN {PLOTIT}
   IF HIPLOT THEN INITPLOT;
   PLOT_STARTED := FALSE;
   UNITWRITE(3,SCREEN,60);
   {The next couple of lines clear the top three lines of text.}
   GOTOXY(0,0);
   WRITE(CLEAR_LINE,CLEAR_LINE,CLEAR_LINE);
   GOTOXY(35,0);
   WRITELN('POLAR PLOT');
   UNITREAD(2,CH,1,,1);{ read the keyboard while processing continues}
   CASE MODE OF
     1 : BEGIN
            START_ANGLE:=XI*PI/180;
            END_ANGLE:=XF*PI/180;
            ANGLE_CHANGE:=DELTA_ANGLE*PI/180;
         END;
     2 : BEGIN
            START_ANGLE:=XI;
            END_ANGLE:=XF;
            ANGLE_CHANGE:=DELTA_ANGLE;
         END;
     3 : BEGIN
            START_ANGLE:=XI*PI;
            END_ANGLE:=XF*PI;
            ANGLE_CHANGE:=DELTA_ANGLE*PI;
         END;
   END {OF CASE};
   TEMP:=F(START_ANGLE,0,0);
   X:=TEMP*COS(START_ANGLE);
   Y:=TEMP*SIN(START_ANGLE);
   XPLOT:=1000+CHECK(X*SCALE*7*UNIT_SCALE);
   YPLOT:=700+CHECK(Y*SCALE*7*UNIT_SCALE);
   XSTART:=160+CHECK(X*SCALE*UNIT_SCALE);
   YSTART:=120-CHECK(Y*SCALE*UNIT_SCALE);
   REPEAT
     IF NOT UNITBUSY(2) THEN
       BEGIN
         IF CH = CHR(27{ESC}) THEN 
            BEGIN
               IF HIPLOT THEN PLOT(UP,0,0);
               EXIT(PLOTIT);
            END;
         UNITREAD(2,CH,1,,1);
       END;
     START_ANGLE:=START_ANGLE+ANGLE_CHANGE;
     TEMP:=F(START_ANGLE,0,0);
     X:=TEMP*COS(START_ANGLE);
     Y:=TEMP*SIN(START_ANGLE);
     DX:=160+CHECK(X*SCALE*UNIT_SCALE)-XSTART;
     DY:=120-CHECK(Y*SCALE*UNIT_SCALE)-YSTART;
     IF HIPLOT THEN PLOT_OUT;
     IF IN_RANGE AND NOT ERROR THEN 
        DRAWLINE(RANGE,SCREEN,ROWWIDTH,XSTART,YSTART,DX,DY,INK);
     XSTART:=XSTART+DX;
     YSTART:=YSTART+DY;
   UNTIL (START_ANGLE>END_ANGLE);
   IF HIPLOT THEN PLOT(UP,0,0);
   IF UNITBUSY(2) THEN UNITCLEAR(2);
END {OF PLOTIT};


BEGIN {POLAR}

   PI:=4*ATAN(1);
   DEFINESTRINGS;
   FIRST_TIME:=TRUE;
   REPEAT
      INITIALIZE;
      PLOTIT;
      WRITE('Press any key to continue ',CHR(7{BELL}));
      READ(CH);
   UNTIL FALSE {The program is exited from INITIALIZE};
END {OF THE PROGRAM}.

========================================================================================
DOCUMENT :usus Folder:VOL22:post.doc.text
========================================================================================

                             POST_ENTRY_OF_FUNCTION
                      
Reviewed by:  Henry E. Baumgarten
              Department of Chemistry
              University of Nebraska-Lincoln
              Lincoln, Nebraska 68588-0304

     The unit POST_ENTRY_OF_FUNCTION was written by Edward J. Grundler,
apparently in 1978 or early 1979 (the original text file is dated 11 Feb 1979).
The purpose of this unit is to make possible the entry of functions of one to
three variables in algebraic form from the console or other input device. The
function may then be used as the basis for plotting the function on a graphics
terminal or hard-copy plotter, or for calculations of various sorts.  Several
programs using this unit have been submitted to the USUS library by Edward J.
Grundler, Dennis E. Grundler, and Ken Gaal.

     The unit is fairly well documented internally; however, use of the unit may
be facilitated by a brief analysis of its operation.  After a function F(x,y,z)
is entered as a string, ENTERED_FUNCTION, at the terminal, the string is scanned
(1) to remove blanks, (2) to convert lower char to upper case, (3) to make
certain that parentheses are balanced, (4) to replace the identifiers for all of
its standard functions and its extra functions (those provided by the unit but
not in UCSD Pascal) by a single char code (e.g., COS is replaced by C and ASIN
by H), and (5) to check for invalid chars left after steps (1) through (4). In
the present version an additional step has been added because of problems
encountered during review. The string is scanned to make certain that the
arguments of all functions are enclosed in parentheses. In the original version
this was not required (i.e., sinx and sin(x) were equivalent).  Although this
has obvious advantages, it can cause problems when valid functions NOT present
in this unit are entered. Thus, once again, the lamb of convenience had to be
sacrified on the altar of reliability.

     If no errors are encountered, the function string is transformed from
algebraic (infix) to postfix (RPN) form by a sequence of operations resembling
that used as a part of some compilers. From this process the function emerges as
a string, FUNC, in postfix form together with a constant array V, in which all
of the real constants of the function are stored in proper order (all numerical
quantities are treated as real numbers). When the unit is called upon to
evaluate the function by the call, some VAR := F(x,y,z), evaluation proceeds in
typical RPN fashion using a STACK. If errors are noted, an error flag, ERROR, is
set TRUE, and the variable, ERROR_CODE, is assigned an appropriate error number.
In such instances the function becomes undefined (something that can cause
problems if not properly prepared for).

     Consider, for example, a limacon of Pascal, F(x) = 4*COS(X) + 3, where x is
really theta (the counter-clockwise angle from the x-axis) and F(x) is r (the
radial distance from the origin).  To enter this function, 4*COS(X) + 3 is typed
at the terminal (with or without the blanks or spaces). After the initial scan
the function string is reduced to the form, 4*C(X)+3. Then this string is
rearranged to the postfix form needed in FUNC, VXC*V+, where V is the code for a
"value" (or real constant).  The actual values, 4 and 3, are stored as the first
and second elements, respectively, of the real array, V. At this point the
function is ready to accept input values of x (theta).  Assume that we wish to
evaluate the function at x = 0.  By whatever Pascal procedure we may devise we
enter some VAR = F(0,0,0).  Note that x = 0, and we set the other values (y and
z) also to zero because they are not being used by this particular function. The
evaluation of the function proceeds by calling each operator in turn from the
function string, performing its operation on the stack, and appropriately
incrementing or decrementing the stack pointer. For the example function these
operations and the contents of the stack can by decribed as in the following
chart.

     Operator        Top_of_stack     Top_of_stack_minus_one
        V              4.00000
        X              0.00000             4.00000
        C              1.00000             4.00000
        *              4.00000
        V              3.00000             4.00000
        +              7.00000

     At the end, the value of F(x) = 7 (from the top of the stack) is assigned
to VAR.  The operations used were (in order):  V, push V[1] on stack; X, push
X = 0 on stack; C, replace tos with COS(tos); *, replace tos with tos*tos-1,
V, push V[2] on stack; +, replace tos with tos+tos-1.

     The unit provides three procedures or functions, GET_FUNCTION, REPLACE_
FUNCTION, and F(X,Y,Z : REAL) : REAL. GET_FUNCTION is intended for use in
obtaining the input function string from the console.  It contains a terminal-
dependent code line, WRITE(CHR(31)). For the Terak terminal emulator used by
the Grundlers, this code causes a reverse line feed, something apparently
required by many of the Grundler graphics programs for the Terak computer.
In some applications this line could cause problems---particularly for
non-Terak computers. If POST_ENTRY is not being used with the Grundler programs,
it is recommended that this line be removed and the whole section of code in
which it is found be revised. For the Grundler-Gaal programs the line should
be edited to fit the terminal emulator (or terminal) being used.

     REPLACE_FUNCTION may be used to reenter a function (saved in some fashion)
after using POST_ENTRY to enter a second function (or a value).  However, it can
be used in place of GET_FUNCTION if properly coded. If so, note that the
reverse line feed still takes place, AND, if a zero-length string or a string of
blanks is entered via REPLACE_FUNCTION, the program will probably go into an
indefinite loop, waiting for corrective action that cannot be taken: one more
reason to get rid of that reverse line feed. Two typical uses of REPLACE_
FUNCTION might be:

  (1)    SAVECURSOR(XCUR,YCUR);  (routine that saves cursor coordinates)
         REPEAT
           READLN(STRG);
           FOR I := LENGTH(STRG) DOWNTO 1 DO IF STRG[I] = ' ' THEN
             DELETE(STRG,I,1);
           IF (LENGTH(STRG)=0) THEN GOTOXY(XCUR,YCUR);
         UNTIL ((LENGTH(STRG)>0);
         ENTERED_FUNCTION := STRG;
         REPLACE_FUNCTION;

  (2)    SAVED_FUNCTION := ENTERED_FUNCTION; (saves original function)
         GET_FUNCTION;  (enter number string, VALUE_STRG, from terminal)
         INPUT_VALUE := F(0,0,0);  ("computes" the real number)
         ENTERED_FUNCTION := SAVED_FUNCTION;
         REPLACE_FUNCTION;

     Note that in example (1) the possibility of a indefinite loop is
circumvented.  In (2) the routines are used to enter a real number from
the terminal (hopefully protecting the user from some of the vagaries of the
usual system input idiosyncracies).

     Some of the original forgiveness in this unit has been left in.  Thus,
some missing '*' will be inserted.  For example: X9 -- > X*9; XX -- > X*X;
COS(X)X -- > COS(X)*X.

     Restrictions imposed by POST_ENTRY include:
      (1) Input function string is limited to 80 char (on one line from
            console).
      (2) Scientific format for real constants is not implemented.
      (3) The negative unary operator is processed by GET_UNARY, converting
             function codes to lower case,
                COS(X) --> C(X)          (chr(67))
               -COS(X) --> c(X)          (chr(67+32))
              --COS(X) --> chr(121)(X)   (chr(67+32+32))
             so don't enter a string of minus signs.

     The only change of any consequence made by the reviewer was the
following. The original would not enforce encapsulation of function
arguments in parentheses.  The following pairs were equivalent: sinx + sin(x);
sinxx + sin(x)*x; sinxcosx + sin(x)*cos(x).  However, the original also accepted
cosh(x) (hyperbolic cosine, not provided in the unit), converted it to CH(X),
and discarded the C (in the GET_UNARY routine), leaving FUNC = XH (i.e., the
arcsin(x), an initially baffling surprise to the reviewers.  In this version
PROCEDURE VERIFY insists that parentheses surround arguments of functions.

     In an attempt to retain the original procedure's relaxed attitude toward
parentheses, a number of expedients were examined without much success. However,
in the process POST_ENTRY was rather thoroughly reorganized and rewritten by the
reviewer. Several new functions and debugging facilities were added.  The
resulting unit was entitled, POST_FIX.  For many users POST_ENTRY is entirely
adequate; for a few the additional capabilities of POST_FIX may be helpful. The
principal changes or enhancements found in POST_FIX are as follows:

     (1) Standard and extra functions are mapped to the user-defined char set
(chr(128)-chr(255)) creating space for a total of 50 functions and 13 constants
compared with 26 total constants, functions, and unary operators in POST_ENTRY.

     (2) The functions COSH, SINH, TANH, ERF, ERFC, MOD, LNFACT(orial) plus
the operator ! (for factorial) have been added.  ARCCOS, ARCSIN, and ARCTAN are
accepted as well as ACOS, ASIN, and ATAN. (For electrochemists and others doing
electrochemical research, the implementation of EXP(SQR(Z))*ERFC(Z) as a single
function for a very wide range of Z values is very simple.)

     (3) Input of real constants in scientific format is permitted.  Present
real constant limits are 1.0E-37 to 1.0E37, with constants smaller than
1.0E-37 being converted to zero (a WARNING flag is set and a WARNING message
is made available when this conversion occurs).

     (4) More extensive checking for errors is carried out.

     (5) Error messages (as well as error code numbers) are available
using a function ERROR_MESSAGE.

     (6) For debugging purposes (or for pure curiosity) provision is made
for step-wise evaluation with output of the post-fix function, the
constant stack (array), and of the evaluation stack at each step of the
evaluation.

     (7) Multiple unary inputs (----X, -----X, etc.) are handled correctly.

     (8) Functions of greater length can be handled.
     
     POST_FIX is already being used in both research and interactive educational
applications at the University of Nebraska-Lincoln.  The POST_FIX unit will be
submitted by the reviewer to the USUS library along with examples of its
applications.

========================================================================================
DOCUMENT :usus Folder:VOL22:post_entry.text
========================================================================================

{$I-}{$R-}

{Note that there is one terminal dependent line of code, marked (*****).
 This line should be replaced by whatever will provide a reverse line feed on
 your terminal.  If this unit is not to be used with the Grundler programs,
 this line should be deleted and that section of the unit revised for maximum
 generality, leaving the terminal-handling code to the main program or other
 units.---heb

       PROCEDURE GET_FUNCTION asks for an entry of a three variable
  function.  If only one or two variables are needed, the extra variables
  are ignored.  The variables must be X,Y and Z.  The procedure
  recognizes the standard PASCAL functions.  PI, ASIN, ACOS, TAN and ^
  for EXPONENTIATION are also recognized.

       PROCEDURE REPLACE_FUNCTION enables one to replace a string-variable
  expression for use as F(X,Y,Z). This is done as follows:
             ENTERED_FUNCTION:= string var
             REPLACE FUNCTION
            

       FUNCTION F(X,Y,Z:REAL):REAL evaluates the function entered in
  GET_FUNCTION.  If all of the variables are not used, set the other
  variables to ZERO.  For example: ANSWER:=F(0,Y,0).

       If an error is encountered in GET_FUNCTION, control is passed back
  to the calling program with ERROR set to TRUE and ERROR_CODE set as
  follows:

          1  UNBALANCED PARENTHESES
          2  UNRECOGNIZED SYMBOL
          3  MULTIPLE DECIMAL POINTS IN A CONSTANT
         15  FUNCTION ARGUMENT NOT IN PARENTHESES

       If an error is encountered in F(X,Y,Z), control is passed back to
  the calling program with the function undefined, ERROR set to TRUE and
  ERROR_CODE set as follows:

          4  ATTEMPT TO UNROLL THE STACK PAST ITS ORIGIN
          5  ATTEMPT TO DIVIDE BY ZERO
          6  ATTEMPT TO EXPONENTIATE A NEGATIVE NUMBER (*USES LN EVALUATION*)
          7  ATTEMPT TO EVALUATE THE TANGENT WITH THE COSINE EQUAL TO ZERO
          8  ATTEMPT TO TRUNC OR ROUND AN ABSOLUTE VALUE > 32767
          9  ATTEMPT TO TAKE LOG OR LN OF A ZERO OR NEGATIVE NUMBER
         10  ATTEMPT TO TAKE THE SQUARE ROOT OF A NEGATIVE NUMBER
         11  STACK POINTER NOT AT BOTTOM OF THE STACK AT END OF THE EVALUATION
         12  ATTEMPT TO TAKE ARCSIN WITH ABS(argument) > 1
         13  ATTEMPT TO TAKE ARCCOS WITH ABS(argument) > 1
         14  ATTEMPT TO EXPONENTIATE WOULD CAUSE OVERFLOW


       The function that is entered is available to the calling program
  in ENTERED_FUNCTION.
  
       Changes made by reviewer:
           Changed one line intended to a cause a reverse line feed at the
  terminal to be compatible with the Terak in the Terak emulator mode.
           Added the procedure VERIFY, which requires that the arguments of
  the standard and additional functions be surrounded by parentheses.  Otherwise
  the unit will accept COSH(X) (a function not present in this unit) but will
  tranform it into the equivalent of ARCSIN(X), a result that can be confusing
  to the unwary.
           Changed STR to STRG.
           Insert missing index [I] in line marked (**) and removed a duplicate
  line of code (no longer necessary after the insertion) in procedure
  SCAN_STRING.
                                          ---Henry E. Baumgarten
}

UNIT POST_ENTRY_OF_FUNCTION;

INTERFACE

{
                                                     unit by:  EDWARD J GRUNDLER
}

VAR ERROR:BOOLEAN;
    ERROR_CODE:INTEGER;
    ENTERED_FUNCTION:STRING;

PROCEDURE GET_FUNCTION;
PROCEDURE REPLACE_FUNCTION;
FUNCTION F(X,Y,Z:REAL):REAL;

IMPLEMENTATION

VAR V:ARRAY[1..20]OF REAL;
    FUNC:STRING;
    J:INTEGER;

PROCEDURE GET_F(READIN:BOOLEAN);
VAR CH:CHAR;
    CH_STR:STRING;
    STR_2:STRING[1];
    I:INTEGER;
  
  PROCEDURE MISTAKE(I:INTEGER);
  BEGIN {MISTAKE}
    ERROR_CODE:=I;
    ERROR:=TRUE;
    EXIT(GET_FUNCTION)
  END; {MISTAKE}
  
  PROCEDURE VERIFY;
    VAR  K,LEN : INTEGER;
    BEGIN
      LEN := LENGTH(CH_STR);
      FOR K := 1 TO LEN DO
        IF NOT(CH_STR[K] IN ['('..'+','-'..'9','A'..'I','L','N','P'..'V',
          'X'..'Z']) THEN MISTAKE(2);
      IF (LEN>1) THEN FOR K := 2 TO LEN DO
        IF ((CH_STR[K-1] IN ['A'..'I','L','Q'..'U']) AND
          (NOT(CH_STR[K] = '('))) THEN MISTAKE(15)
    END;
  
  PROCEDURE SCAN_STRING;
  VAR I,J:INTEGER;
  BEGIN{SCAN_STRING}
    J:=0;
    FOR I:=1 TO LENGTH(CH_STR) DO
      BEGIN
        IF CH_STR[I] IN ['a'..'z'] THEN CH_STR[I]:=CHR(ORD(CH_STR[I])-32);
        IF CH_STR[I]='(' THEN J:=J+1 ELSE IF CH_STR[I]=')' THEN J:=J-1
      END;
    IF J<>0 THEN MISTAKE(1);
    REPEAT                                { CODES USED }
      I:=POS('ASIN',CH_STR);              { A  ATAN    }
      IF I>0 THEN                         { B  SQR     }
        BEGIN                             { C  COS     }
          DELETE(CH_STR,I,4);             { D  ABS     }
          INSERT('H',CH_STR,I)            { E  EXP     }
        END                               { F  PI      }
    UNTIL I=0;                            { G  LOG     }
    REPEAT                                { H  ASIN    }
      I:=POS('SIN',CH_STR);               { I  TRUNC   }
      IF I>0 THEN DELETE(CH_STR,I+1,2)    { J          }
    UNTIL I=0;                            { K          }
    REPEAT                                { L  LN      }
      I:=POS('ACOS',CH_STR);              { M          }
      IF I>0 THEN                         { N  NEGATE  }
        BEGIN                             { O          }
          DELETE(CH_STR,I,4);             { P  + UNARY }
          INSERT('U',CH_STR,I)            { Q  SQRT    }
        END                               { R  ROUND   }
    UNTIL I = 0;                          { S  SIN     }
    REPEAT                                { T  TAN     }
      I:=POS('COS',CH_STR);               { U  ACOS    }
      IF I>0 THEN DELETE(CH_STR,I+1,2)    { V  VALUE   }
    UNTIL I=0;                            { W          }
    REPEAT                                { X  X ARG   }
      I:=POS('ATAN',CH_STR);              { Y  Y ARG   }
      IF I>0 THEN DELETE(CH_STR,I+1,3)    { Z  Z ARG   }
    UNTIL I=0;
    REPEAT
      I := POS('TANH', CH_STR);
      IF I>0 THEN
        BEGIN
          DELETE(CH_STR,I,4);
          INSERT('M',CH_STR,I)
        END
    UNTIL I = 0;
    REPEAT
      I:=POS('TAN',CH_STR);
      IF I>0 THEN DELETE(CH_STR,I+1,2)
    UNTIL I=0;
    REPEAT
      I:=POS('TRUNC',CH_STR);
      IF I>0 THEN
        BEGIN
          DELETE(CH_STR,I,5);
          INSERT('I',CH_STR,I)
        END
    UNTIL I=0;
    REPEAT
      I:=POS('ROUND',CH_STR);
      IF I>0 THEN DELETE(CH_STR,I+1,4)
    UNTIL I=0;
    REPEAT
      I:=POS('LN',CH_STR);
      IF I>0 THEN DELETE(CH_STR,I+1,1)
    UNTIL I=0;
    REPEAT
      I:=POS('LOG',CH_STR);
      IF I>0 THEN DELETE(CH_STR,I,2)
    UNTIL I=0;
    REPEAT
      I:=POS('EXP',CH_STR);
      IF I>0 THEN DELETE(CH_STR,I+1,2)
    UNTIL I=0;
    REPEAT
      I:=POS('SQRT',CH_STR);
      IF I>0 THEN
        BEGIN
          DELETE(CH_STR,I+2,2);
          DELETE(CH_STR,I,1)
        END
    UNTIL I=0;
    REPEAT
      I:=POS('ABS',CH_STR);
      IF I>0 THEN
        BEGIN
          DELETE(CH_STR,I,3);
          INSERT('D',CH_STR,I)
        END
    UNTIL I=0;
    REPEAT
      I:=POS('SQR',CH_STR);
      IF I>0 THEN
        BEGIN
          DELETE(CH_STR,I,3);
          INSERT('B',CH_STR,I)
        END
    UNTIL I=0;
    REPEAT
      I:=POS('PI',CH_STR);
      IF I>0 THEN
        BEGIN
          DELETE(CH_STR,I,2);
          INSERT('F',CH_STR,I)
        END
    UNTIL I=0;
    I:=2;
    WHILE I<=LENGTH(CH_STR) DO
      BEGIN
        IF (CH_STR[I] IN ['(','X'..'Z']) AND
           (CH_STR[I-1] IN ['F','X'..'Z','0'..'9','.']) THEN
          INSERT('*',CH_STR,I)
        ELSE
          IF (CH_STR[I-1] IN ['X'..'Z',')']) AND
             (CH_STR[I] IN ['F','X'..'Z','0'..'9','.']) THEN
            INSERT('*',CH_STR,I)
          ELSE
            IF (CH_STR[I-1] IN ['0'..'9','.','X'..'Z']) AND
               NOT(CH_STR[I] IN ['0'..'9','.','+','-','*','/','^',')']) THEN
              INSERT('*',CH_STR,I);
        I:=I+1
      END;
    VERIFY
  END; {SCAN_STRING}
  
  PROCEDURE FIND;
  BEGIN {FIND}
    I:=I+1;
    IF I>LENGTH(CH_STR) THEN STR_2:=',' ELSE STR_2:=COPY(CH_STR,I,1);
    CH:=STR_2[1]
  END; {FIND}
  
  PROCEDURE EXPRESSION;
  VAR OP:STRING[1];
    
    PROCEDURE TERM;
    VAR OP1:STRING[1];
      
      PROCEDURE EXPONENT;
      VAR OP2:STRING[1];
        
        PROCEDURE FACTOR;
        VAR UNARY:BOOLEAN;
            PREFIX:STRING[1];
          
          PROCEDURE GET_UNARY;
          VAR SAVE:CHAR;
          BEGIN {GET_UNARY}
            UNARY:=TRUE;
            IF NOT (CH IN ['+','-','A'..'E','Q'..'U','L','G'..'I']) THEN
              MISTAKE(2);
            IF CH='+' THEN PREFIX:='P'
            ELSE IF CH='-' THEN PREFIX:='N' ELSE PREFIX:=STR_2;
            FIND;
            IF NOT (CH IN ['F','X'..'Z','0'..'9','(','.']) THEN
              BEGIN
                SAVE:=PREFIX[1];
                GET_UNARY;
                IF SAVE='N' THEN PREFIX[1]:=CHR(ORD(PREFIX[1])+32)
              END
          END; {GET_UNARY}
          
          PROCEDURE GET_VALUE;
          VAR STR:STRING;
              X:REAL;
            
            FUNCTION IN_VALUE(INP:STRING):REAL;
            VAR I:INTEGER;
                DEC,OK:BOOLEAN;
                J,X:REAL;
            BEGIN {IN_VALUE}
              DEC:=FALSE;
              OK:=TRUE;
              FOR I:=1 TO LENGTH(INP) DO
                BEGIN
                  OK:=OK AND NOT(DEC AND(INP[I]='.'));
                  IF NOT DEC THEN DEC:=(INP[I]='.');
                END;
              IF NOT OK THEN MISTAKE(3);
              X:=0;
              DEC:=FALSE;
              J:=1;
              FOR I:=1 TO LENGTH(INP) DO
                BEGIN
                  IF NOT DEC THEN DEC:=(INP[I]='.');
                  IF DEC THEN
                    BEGIN
                      IF INP[I]<>'.' THEN
                        BEGIN
                          J:=J/10;
                          X:=X+(ORD(INP[I])-ORD('0'))*J
                        END
                      ELSE {NOTHING}
                    END
                  ELSE X:=X*10+ORD(INP[I])-ORD('0')
                END;
              IN_VALUE:=X
            END; {IN_VALUE}
          
          BEGIN {GET_VALUE}
            STR:='';
            WHILE CH IN ['.','0'..'9'] DO
              BEGIN
                STR:=CONCAT(STR,STR_2);
                FIND
              END;
            X:=IN_VALUE(STR);
            J:=J+1;
            V[J]:=X;
            FUNC:=CONCAT(FUNC,'V');
            I:=I-2;
            FIND
          END; {GET_VALUE}
        
        BEGIN {FACTOR}
          UNARY:=FALSE;
          IF NOT (CH IN ['F','X'..'Z','.','0'..'9','(']) THEN GET_UNARY;
          IF CH = '(' THEN
            BEGIN
              FIND;
              EXPRESSION;
            END
          ELSE
            IF CH IN ['0'..'9','.'] THEN GET_VALUE
            ELSE FUNC:=CONCAT(FUNC,STR_2);
          IF UNARY THEN
            BEGIN
              FUNC:=CONCAT(FUNC,PREFIX);
              UNARY:=FALSE
            END;
          FIND
        END; {FACTOR}
      
      BEGIN {EXPONENT}
        FACTOR;
        WHILE CH = '^' DO
          BEGIN
            OP2:=STR_2;
            FIND;
            FACTOR;
            FUNC:=CONCAT(FUNC,OP2)
          END
      END; {EXPONENT}
    
    BEGIN {TERM}
      EXPONENT;
      WHILE CH IN ['*','/'] DO
        BEGIN
          OP1:=STR_2;
          FIND;
          EXPONENT;
          FUNC:=CONCAT(FUNC,OP1)
        END
    END; {TERM}
  
  BEGIN {EXPRESSION}
    TERM;
    WHILE CH IN ['+','-'] DO
      BEGIN
        OP:=STR_2;
        FIND;
        TERM;
        FUNC:=CONCAT(FUNC,OP)
      END
  END; {EXPRESSION}

BEGIN {GET_F}
  J:=0;
  FUNC:='';
  ERROR:=FALSE;
  ERROR_CODE:=0;
  REPEAT
    IF READIN THEN READLN(ENTERED_FUNCTION);
    CH_STR:=ENTERED_FUNCTION;
(**) FOR I:=LENGTH(CH_STR) DOWNTO 1 DO IF CH_STR[I]=' ' THEN DELETE(CH_STR,I,1);
    {WRITE(CHR(27),'I');  Reverse Line Feed for H19}  (*****)
    WRITE(CHR(11));   {Reverse Line Feed for Terak in Terak emulator mode}
  UNTIL LENGTH(CH_STR)>0;
  SCAN_STRING;
  I:=0;
  FIND;
  EXPRESSION;
END; {GET_F}

PROCEDURE GET_FUNCTION;
  BEGIN
    GET_F(TRUE)
  END;

PROCEDURE REPLACE_FUNCTION;
  BEGIN
    GET_F(FALSE)
  END;

FUNCTION F;
VAR I,J,K:INTEGER;
    STACK:ARRAY[1..20] OF REAL;
    OP:CHAR;

  PROCEDURE PUSH;
  BEGIN {PUSH}
    J:=J+1;
    CASE OP OF
    'X':STACK[J]:=X;
    'Y':STACK[J]:=Y;
    'Z':STACK[J]:=Z;
    'F':STACK[J]:=4*ATAN(1);
    'V':
      BEGIN
        K:=K+1;
        STACK[J]:=V[K]
      END
    END {OF CASE}
  END; {PUSH}
  
  PROCEDURE WRONG(I:INTEGER);
  BEGIN {WRONG}
    ERROR_CODE:=I;
    ERROR:=TRUE;
    EXIT(F)
  END; {WRONG}
  
  PROCEDURE CHECK_EXPONENT(X:REAL);
  BEGIN {CHECK_EXPONENT}
    IF X>87.498233 THEN WRONG(14)
  END; {CHECK_EXPONENT}
  
  PROCEDURE ALGEBRA;
  BEGIN {ALGEBRA}
    IF J<2 THEN WRONG(4);
    CASE OP OF
    '+':STACK[J-1]:=STACK[J-1]+STACK[J];
    '-':STACK[J-1]:=STACK[J-1]-STACK[J];
    '*':STACK[J-1]:=STACK[J-1]*STACK[J];
    '/':IF STACK[J]=0 THEN WRONG(5) ELSE STACK[J-1]:=STACK[J-1]/STACK[J];
    '^':IF STACK[J-1]<=0 THEN WRONG(6)
      ELSE
        BEGIN
          CHECK_EXPONENT(LN(STACK[J-1])*STACK[J]);
          STACK[J-1]:=EXP(LN(STACK[J-1])*STACK[J])
        END
    END; {OF CASE}
    J:=J-1
  END; {ALGEBRA}
  
PROCEDURE ARCCOSINE;
VAR AC,HPI,PI_IF_AC_NEG:REAL;
begin
  HPI:=2*ATAN(1);
  AC:=STACK[J];
  IF AC<>0 THEN PI_IF_AC_NEG:=HPI*(1-AC/ABS(AC));
  IF ABS(AC)>1
     THEN WRONG(13)
     ELSE IF (ABS(AC)=1) OR (AC=0)
             THEN STACK[J]:=HPI*(1-AC)
             ELSE STACK[J]:=ATAN(SQRT(1-AC*AC)/AC)+PI_IF_AC_NEG
end; { of procedure ARCCOSINE }

BEGIN {F(X,Y,Z)}
  ERROR:=FALSE;
  ERROR_CODE:=0;
  J:=0;
  K:=0;
  FOR I:=1 TO LENGTH(FUNC) DO
    BEGIN
      OP:=FUNC[I];
      CASE OP OF
      'X','Y','Z','F','V':PUSH;
      '+','-','*','/','^':ALGEBRA;
      'S','s':STACK[J]:=SIN(STACK[J]);
      'C','c':STACK[J]:=COS(STACK[J]);
      'T','t':IF COS(STACK[J])=0 THEN WRONG(7)
        ELSE STACK[J]:=SIN(STACK[J])/COS(STACK[J]);
      'I','i','R','r':
        BEGIN
          IF ABS(STACK[J])>32767 THEN WRONG(8)
          ELSE
            CASE OP OF
            'I','i':STACK[J]:=TRUNC(STACK[J]);
            'R','r':STACK[J]:=ROUND(STACK[J]);
            END {OF CASE}
        END;
      'L','l','G','g':
        BEGIN
          IF STACK[J]<=0 THEN WRONG(9)
          ELSE
            CASE OP OF
            'L','l':STACK[J]:=LN(STACK[J]);
            'G','g':STACK[J]:=LOG(STACK[J]);
            END {OF CASE}
        END;
      'H','h':
        BEGIN
          IF ABS(STACK[J])>1 THEN WRONG(12)
          ELSE
            IF ABS(STACK[J])=1 THEN STACK[J]:=2*ATAN(STACK[J])
            ELSE STACK[J]:=ATAN(STACK[J]/SQRT(1-SQR(STACK[J])))
        END;
      'U','u':ARCCOSINE;
      'D','d':STACK[J]:=ABS(STACK[J]);
      'A','a':STACK[J]:=ATAN(STACK[J]);
      'E','e':
        BEGIN
          CHECK_EXPONENT(STACK[J]);
          STACK[J]:=EXP(STACK[J])
        END;
      'Q','q':IF STACK[J]<0 THEN WRONG(10) ELSE STACK[J]:=SQRT(STACK[J]);
      'B','b':STACK[J]:=SQR(STACK[J]);
      'P':;
      'N':STACK[J]:=-STACK[J];
      END; {OF CASE}
      IF OP IN ['a'..'z'] THEN STACK[J]:=-STACK[J]
    END;
  IF NOT (J=1) THEN WRONG(11);
  F:=STACK[1]
END {F(X,Y,Z)}

END {END OF UNIT POST_ENTRY_OF_FUNCTION}.

========================================================================================
DOCUMENT :usus Folder:VOL22:real_input.text
========================================================================================


{
  This unit was reconstructed from a function in the program LEVEL_CURVES in
  the file, CONTOUR.TEXT, to replace a missing unit, EDS_STUFF, in the
  Grundler submissions. The function INPUT_VALUE was written by Edward J.
  Grundler (ca. Aug 1979). If the unit is not used with the Grundler programs
  it may be necessary to edit the lines marked (*****) to fit the console
  display requirements of your program.
 }
UNIT REAL_INPUT;

INTERFACE
  USES {$U GRAPH.LIBRARY} SCREEN_STUFF;  (*****)

FUNCTION INPUT_VALUE:REAL;

IMPLEMENTATION

FUNCTION INPUT_VALUE{:REAL};
VAR I:INTEGER;
    INP:STRING;
    DEC,NEX,EX,NEG,OK:BOOLEAN;
    EXPO,J,X:REAL;
BEGIN
  REPEAT
    DEC:=FALSE;
    EX:=FALSE;
    READLN(INP);
    IF LENGTH(INP)=0 THEN INP:='0';
    OK:=NOT(INP[1]='E');
    IF LENGTH(INP)>1 THEN
      OK:=OK AND NOT((INP[1] IN ['+','-','.']) AND (INP[2]='E'));
    FOR I:=1 TO LENGTH(INP) DO
      BEGIN
        OK:=OK AND (INP[I] IN ['.','-','+','E','0'..'9']);
        IF (I>1) AND NOT EX THEN OK:=OK AND (INP[I] IN ['.','E','0'..'9']);
        OK:=OK AND NOT(DEC AND(INP[I]='.'));
        IF NOT DEC THEN DEC:=(INP[I]='.');
        OK:=OK AND NOT(EX AND (INP[I]='E'));
        IF NOT EX THEN EX:=(INP[I]='E');
        IF I>1 THEN
          OK:=OK AND NOT(EX AND (INP[I] IN ['+','-']) AND NOT(INP[I-1]='E'));
        OK:=OK AND NOT(EX AND (INP[I]='.'))
      END;
    OK:=OK AND (INP[LENGTH(INP)] IN ['0'..'9','.']);
    OK:=OK AND NOT(EX AND NOT(INP[LENGTH(INP)] IN ['0'..'9']));
    IF NOT OK THEN WRITE(RLF,'READ ERROR, TRY AGAIN ',CEOL)   (*****)
  UNTIL OK;
  X:=0;
  DEC:=FALSE;
  EXPO:=0;
  NEG:=FALSE;
  EX:=FALSE;
  J:=1;
  FOR I:=1 TO LENGTH(INP) DO
    BEGIN
      IF NOT DEC THEN DEC:=(INP[I]='.');
      IF NOT NEG THEN NEG:=NOT EX AND (INP[I]='-');
      IF NOT NEX THEN NEX:=EX AND (INP[I]='-');
      IF NOT EX THEN EX:=(INP[I]='E');
      IF EX AND NOT(INP[I] IN ['+','-','E']) THEN
        EXPO:=EXPO*10+ORD(INP[I])-ORD('0');
      IF NOT EX THEN
        BEGIN
          IF DEC AND NOT(INP[I] IN ['.','+','-']) THEN
            BEGIN
              J:=J/10;
              X:=X+(ORD(INP[I])-ORD('0'))*J
            END
          ELSE
            IF NOT(INP[I] IN ['.','+','-']) THEN X:=X*10+ORD(INP[I])-ORD('0')
        END
    END;
  IF EX AND NEX THEN EXPO:=-EXPO;X:=X*EXP(LN(10)*EXPO);
  IF NEG THEN INPUT_VALUE:=-X ELSE INPUT_VALUE:=X
END;

END.

========================================================================================
DOCUMENT :usus Folder:VOL22:review.text
========================================================================================

{$L- PRINTER:}
UNIT REVIEW;

INTERFACE

CONST   PXMAX = 2000; {for small Hiplot}
        PYMAX = 1400;

TYPE    SCREENTYPE = PACKED ARRAY [0..4,0..4] OF BOOLEAN;

VAR     PENSTATE,OLDIPX,OLDIPY  : INTEGER;
        OLDPEN : BOOLEAN;
        

PROCEDURE INITPLOT;

PROCEDURE DRAWLINE(VAR RANGE:INTEGER; VAR S:SCREENTYPE; ROWWIDTH,
  XSTART,YSTART,DELTAX,DELTAY,INK:INTEGER);

PROCEDURE HOME;

PROCEDURE THROTTLE(TICKS : INTEGER);


IMPLEMENTATION

PROCEDURE DMP2PLOT(CH : CHAR);

{Note: address of serial board receiver status register and receiver buffer
 must be specified in decimal.  The easy way to do this is illustrated for
 the standard REMOUT addresses, 177524 and 177526 (not used by the reviewer):
    200000 - 177524 = 252 (8)   (using octal arithmetic)
    (0*512)+(2*64)+(5*8)+(2*1) = 172 (10)
    PXCSR = -172
    PXBUF = -170}

  CONST PXCSR = -684 (*176524 (octal); DLV11J address*);
        PXBUF = -682 (*176526 (octal); DLV11J address*);
        BITNO = 7;
  TYPE  INFO = PACKED RECORD CASE BOOLEAN OF
          TRUE : (CH : PACKED ARRAY [0..1] OF CHAR);
          FALSE : (BIT : PACKED ARRAY [0..15] OF BOOLEAN);
        END;
        IOPORT = PACKED RECORD CASE BOOLEAN OF
          TRUE : (ADDR : INTEGER);
          FALSE : (PNTR : ^INFO)
        END;
  VAR   XCSR,XBUF : IOPORT;
  
  BEGIN
    REPEAT
      XCSR.ADDR := PXCSR
    UNTIL XCSR.PNTR^.BIT[BITNO];
    XBUF.ADDR := PXBUF;
    XBUF.PNTR^.CH[0] := CH;
  END;

PROCEDURE ENCODE(COMMAND : INTEGER);

  CONST SP = ' ';
        DELAY = 24;  (*delay for pen changes*)
  
  VAR   PENCODE2 : CHAR;
        I : INTEGER;
        
  BEGIN
    IF (COMMAND IN [0..10]) THEN
      BEGIN
        CASE COMMAND OF
          0 : PENCODE2 := ' ';     (*NOP*)
          1 : PENCODE2 := 't';     (*-y*)
          2 : PENCODE2 := 'p';     (*+y*)
          3 : PENCODE2 := 'z';     (*pen down*)
          4 : PENCODE2 := 'v';     (*-x*)
          5 : PENCODE2 := 'u';     (*-x,-y*)
          6 : PENCODE2 := 'w';     (*-x,+y*)
          7 : PENCODE2 := 'y';     (*pen up*)
          8 : PENCODE2 := 'r';     (*+x*)
          9 : PENCODE2 := 's';     (*+x,-y*)
         10 : PENCODE2 := 'q';     (*+x,+y*)
       END;
       DMP2PLOT(PENCODE2);
       IF ((COMMAND IN [3,7]) AND (COMMAND <> PENSTATE)) THEN
         BEGIN 
           PENSTATE := COMMAND;
           FOR I := 1 TO DELAY DO DMP2PLOT(SP)
         END
     END;
  END;

PROCEDURE PLOT(MOVE,INK : INTEGER);
  BEGIN
    IF NOT (INK IN [0..2]) THEN EXIT(PLOT);
    CASE INK OF
      0 : BEGIN
            OLDIPX := 0;     (*set current pen position as plotter origin*)
            OLDIPY := 0;     (*and initializes pen to undefined state*)
            PENSTATE := 0;
            EXIT(PLOT)
          END;
      1 : IF (NOT OLDPEN) THEN
            BEGIN
              ENCODE(3);  (*lower before*)
              OLDPEN := TRUE
            END;
      2 : IF (OLDPEN) THEN
            BEGIN
              ENCODE(7);  (*raise before*)
              OLDPEN := FALSE
            END;
    END; (*case*)
    ENCODE(MOVE)
  END;
PROCEDURE DRAWLINE(*VAR RANGE:INTEGER; VAR S:SCREENTYPE; ROWWIDTH,
  XSTART,YSTART,DELTAX,DELTAY,INK:INTEGER*);

{This is a revision of the  Pascal implementation from Version 1.5 manual.
 Added or revised code in lower case.  Several lines were deleted.}

  VAR   X,Y,XINC,YINC,mode,move,xcode,ycode,xycode,dx,dy : INTEGER;
  
PROCEDURE DOFORX;   {MORE HORIZONTAL}
  
  VAR ERROR,I:INTEGER;
  BEGIN
    IF DELTAX=0 THEN EXIT(DRAWLINE);
    ERROR:=DELTAX DIV 2;
    I:=DELTAX;
    REPEAT
      X := X+XINC;
      ERROR:=ERROR+DELTAY;
      IF ERROR>=DELTAX THEN
        BEGIN
          ERROR:=ERROR-DELTAX;
          Y := Y+YINC;
          move := xycode;
          if (y>PYMAX) or (y<0) then move := move-ycode
        END
      else
        begin
          move := xcode;
          if (x>PXMAX) or (x<0) then move := 0
        end;
      plot(move,ink);
      I:=I-1;
    UNTIL I=0
  END (*DOFORX*);
  
PROCEDURE DOFORY;   {MORE VERTICAL}
  
  VAR ERROR,I:INTEGER;
  BEGIN
    ERROR:=DELTAY DIV 2;
    I:=DELTAY;
    REPEAT
      Y := Y+YINC;
      ERROR:=ERROR+DELTAX;
      IF ERROR>=DELTAY THEN
        BEGIN
          ERROR:=ERROR-DELTAY;
          X := X+XINC;
          move := xycode;
          if (x>PXMAX) or (x<0) then move := move-xcode
        END
      else
        begin
          move := ycode;
          if (y>PYMAX) or (y<0) then move := 0
        end;
      plot(move,ink);
      I:=I-1;
    UNTIL I=0
  END (*DOFORY*);
  
  BEGIN (*DRAWLINE*)
    X := XSTART;
    Y := pymax-YSTART; {in pen coordinates}
    DELTAY := -DELTAY; {in pen coordinates}
    if (X<>oldipx) or (Y<>oldipy) then
      begin
        dx := x-oldipx;
        dy := oldipy-y;
        drawline(RANGE,S,ROWWIDTH,oldipx,pymax-oldipy,dx,dy,2);
      end;
    oldipx := x+deltax;
    oldipy := y+deltay;
    IF DELTAX < 0 THEN
      BEGIN
        xcode := 4;
        XINC := -1;
        DELTAX := -DELTAX
      END
    ELSE
      begin
        xcode := 8;
        XINC := 1
      end;
    IF DELTAY < 0 THEN
      BEGIN
        ycode := 1;
        YINC := -1;
        DELTAY := -DELTAY
      END
    else
      begin
        ycode := 2;
        YINC := 1
      end;
    xycode := xcode+ycode;
    IF DELTAX >= DELTAY THEN DOFORX ELSE DOFORY;
  END (*DRAWLINE*);
  
PROCEDURE INITPLOT;
  BEGIN
    PLOT(0,0);
    ENCODE(7);
    OLDPEN := FALSE;
  END;
  
PROCEDURE HOME;
  VAR RANGE,R:INTEGER;
      S:SCREENTYPE;
  BEGIN
    DRAWLINE(RANGE,S,R,OLDIPX,PYMAX-OLDIPY,-OLDIPX,OLDIPY,2);
  END;
  
PROCEDURE THROTTLE(*TICKS:INTEGER*);
  
  VAR   COUNT,HITIME,START,STOP,TIMEDIFF : INTEGER;
  BEGIN
    COUNT := 0;
    TIME(HITIME,START);
    REPEAT
      COUNT := COUNT+1;
      TIME(HITIME,STOP);
      TIMEDIFF := STOP-START;
      IF (TIMEDIFF < 0) THEN TIMEDIFF := TIMEDIFF+32767;
      IF ((TIMEDIFF = 0) AND (COUNT = 1000)) THEN
        BEGIN
          GOTOXY(0,23);
          WRITE(CHR(7),'Turn on the line time clock! Type <RTN> to continue.');
          READLN
        END;
      UNTIL (TIMEDIFF >= TICKS)
  END;

END.

========================================================================================
DOCUMENT :usus Folder:VOL22:scrn_stuff.text
========================================================================================

{
 This unit was written to put in one place the screen handling conventions
 employed in the Grundler submissions.  This unit will have to be edited to
 fit your terminal or (in the case of the Terak) your terminal emulator.
 The parameters given here are for the Terak in the Terak terminal emulator
 mode (which was used by the reviewers).  Except for RLF, these will work also
 for the H19. The RLF given here for the H19 could work for the Terak (as 
 apparently there are some undocumented alternatives), but this was not tested.
 The original parameters from the Grundler submission are also given; presumably
 these are for a different terminal emulator. In the original submission,
 CLEARSCREEN appeared as PAGE(OUTPUT), and was intended to clear the screen
 of TEXT.  This will not work on our Teraks with UCSD version 2.0---and is
 considered by us to be obsolete. You will have to enter the proper code for
 the clearing of your TEXT screen without clearing the graphics screen.---
 Clifford L. Bettis and Henry E. Baumgarten
 }
 
{$L- PRINTER:}
UNIT SCREEN_STUFF;

INTERFACE

TYPE    SHORTSTRING = STRING[3];

VAR     CEOL,CEOP,RLF,CLEAR_LINE : SHORTSTRING;
        
PROCEDURE CLEARSCREEN;

PROCEDURE DEFINESTRINGS;

IMPLEMENTATION

PROCEDURE CLEARSCREEN;    {Clears the TEXT screen}
  VAR   CS : PACKED ARRAY[0..1] OF 0..255;
  BEGIN
    CS[0] := 27;
    CS[1] := ORD('E');
    UNITWRITE(1,CS,2)
  END;

PROCEDURE DEFINESTRINGS;
  BEGIN
    CEOL := '12';        {CEOL clears from cursor to end of line}
    CEOL[1] := CHR(27);
    CEOL[2] := 'K';
    {The following was used by the Grundlers
    CEOL := '1';
    CEOL[1] := CHR(29);}
    
    RLF := '1';          {RLF is a reverse line feed}
    RLF[1] := CHR(11);
    {The following is for the H19
    RLF := '12';
    RLF[1] := CHR(27);
    RLF[2] := 'I';}
    {The following was used by the Grundlers
    RLF := '1';
    RLF[1] := CHR(31);}
    
    CEOP := '12';      {CEOP clears from cursor to end of page (screen)}
    CEOP[1] := CHR(27);
    CEOP[2] := 'J';
    {The following was used by the Grundlers
    CEOP := '1';
    CEOP[1] := CHR(11);}
    
    CLEAR_LINE := '1';
    CLEAR_LINE[1] := CHR(13);  {carriage return}
    CLEAR_LINE := CONCAT(CEOL,CLEAR_LINE);
  END;
  
END.

========================================================================================
DOCUMENT :usus Folder:VOL22:sines.text
========================================================================================

{$L- SINES.LIST}

{
                                 program by:  EDWARD J GRUNDLER
     Changes made by reviewer:
       Reversed ranges in SCREENTYPE.
       Provided PROCEDURE CLEARSCREEN (for Terak in Terak emulator
         mode or for H19---Edit for your terminal or emulator).
       Replaced PAGE(OUTPUT) by CLEARSCREEN.
                    ---Henry E. Baumgarten
}

PROGRAM SINES;
TYPE SCREENTYPE = PACKED ARRAY [0..239,0..319] OF BOOLEAN;
VAR S:SCREENTYPE;
    DEG,PRAD:BOOLEAN;
    CH:CHAR;
    X1,Y1,YINC,YMAX,YMIN,A,B,C,D,X,Y:REAL;
    R,RW,XSTART,YSTART,DX,DY,INK,I:INTEGER;

PROCEDURE DRAWLINE(VAR R:INTEGER;
                       S:SCREENTYPE; RW,XSTART,YSTART,DX,DY,INK:INTEGER);
EXTERNAL;

PROCEDURE CLEARSCREEN;
  BEGIN
    WRITE(CHR(27),'E')
  END;

FUNCTION INPUT_VALUE:REAL;
VAR I:INTEGER;
    INP:STRING;
    DEC,NEX,EX,NEG,OK:BOOLEAN;
    EXPO,J,X:REAL;

BEGIN
  REPEAT
    DEC:=FALSE;
    EX:=FALSE;
    READLN(INP);
    IF LENGTH(INP)=0 THEN INP:='0';
    OK:=NOT(INP[1]='E');
    IF LENGTH(INP)>1 THEN
                     OK:=OK AND NOT((INP[1] IN ['+','-','.']) AND (INP[2]='E'));
    FOR I:=1 TO LENGTH(INP) DO
      BEGIN
        OK:=OK AND (INP[I] IN ['.','-','+','E','0'..'9']);
        IF (I>1) AND NOT EX THEN OK:=OK AND (INP[I] IN ['.','E','0'..'9']);
        OK:=OK AND NOT(DEC AND(INP[I]='.'));
        IF NOT DEC THEN DEC:=(INP[I]='.');
        OK:=OK AND NOT(EX AND (INP[I]='E'));
        IF NOT EX THEN EX:=(INP[I]='E');
        IF I>1 THEN
             OK:=OK AND NOT(EX AND (INP[I] IN ['+','-']) AND NOT(INP[I-1]='E'));
        OK:=OK AND NOT(EX AND (INP[I]='.'))
      END;
    OK:=OK AND (INP[LENGTH(INP)] IN ['0'..'9','.']);
    OK:=OK AND NOT(EX AND NOT(INP[LENGTH(INP)] IN ['0'..'9']));
    IF NOT OK THEN WRITE(CHR(31),'READ ERROR, TRY AGAIN ',CHR(29))
  UNTIL OK;
  X:=0;
  DEC:=FALSE;
  EXPO:=0;
  NEG:=FALSE;
  EX:=FALSE;
  J:=1;
  FOR I:=1 TO LENGTH(INP) DO
    BEGIN
      IF NOT DEC THEN DEC:=(INP[I]='.');
      IF NOT NEG THEN NEG:=NOT EX AND (INP[I]='-');
      IF NOT NEX THEN NEX:=EX AND (INP[I]='-');
      IF NOT EX THEN EX:=(INP[I]='E');
      IF EX AND NOT(INP[I] IN ['+','-','E']) THEN
                                             EXPO:=EXPO*10+ORD(INP[I])-ORD('0');
      IF NOT EX THEN
        BEGIN
          IF DEC AND NOT(INP[I] IN ['.','+','-']) THEN
            BEGIN
              J:=J/10;
              X:=X+(ORD(INP[I])-ORD('0'))*J
            END
          ELSE
            IF NOT(INP[I] IN ['.','+','-']) THEN X:=X*10+ORD(INP[I])-ORD('0')
        END
    END;
  IF EX AND NEX THEN EXPO:=-EXPO;X:=X*EXP(LN(10)*EXPO);
  IF NEG THEN INPUT_VALUE:=-X ELSE INPUT_VALUE:=X
END;

PROCEDURE HELP;
BEGIN
  CLEARSCREEN;
  WRITELN('This program plots the functions Y=SIN(X) and Y=A(SIN(BX+C)+D');
  WRITELN;
  WRITELN('The range of "X" is -90 to 720 degrees');
  WRITELN('The range of "Y" is determined by the values of "A" and "D"');
  WRITELN;
  WRITELN('The value of "C" can be input as degrees, radians or pi-radians ');
  WRITELN('as selected by "D", "R" or "P"');
  WRITELN;
  WRITELN;
  WRITELN('press RETURN to continue');
  READLN;
  CLEARSCREEN
END;

PROCEDURE PROMPT;
BEGIN
  REPEAT
    GOTOXY(0,0);
    WRITELN('SINES:  H(elp, D(egrees, R(adians, P(i-radians, Q(uit');
    READ(KEYBOARD,CH);
    CASE CH OF
    'H','h','/','?': HELP;
    'D','d'        : DEG:=TRUE;
    'R','r'        : ;
    'P','p'        : PRAD:=TRUE;
    'Q','q'        : EXIT(PROGRAM);
    END;{OF CASE}
    IF CH IN ['D','d','R','r','P','p'] THEN
      BEGIN
        GOTOXY(15,3);
        WRITE('Y=A(SIN(BX+C))+D');
        GOTOXY(0,6);
        WRITE('ENTER A ');
        A:=INPUT_VALUE;
        GOTOXY(0,7);
        WRITE('ENTER B ');
        B:=INPUT_VALUE;
        GOTOXY(0,8);
        WRITE('ENTER C ');
        C:=INPUT_VALUE;
        IF DEG THEN C:=C/57.29577951;
        IF PRAD THEN C:=C*3.141592654;
        GOTOXY(0,9);
        WRITE('ENTER D ');
        D:=INPUT_VALUE
      END
  UNTIL CH IN ['D','d','R','r','P','p']
END;

PROCEDURE INITIALIZE;
BEGIN
  CLEARSCREEN;
  FILLCHAR(S,9600,CHR(0));
  UNITWRITE(3,S,63);
  DEG:=FALSE;
  PRAD:=FALSE;
  CH:=' '
END;

BEGIN{MAIN PROGRAM}
  REPEAT
    INITIALIZE;
    PROMPT;
    YMAX:=(ABS(A)+D);
    IF YMAX<1 THEN YMAX:=1;
    YMIN:=(D-ABS(A));
    IF YMIN>-1 THEN YMIN:=-1;
    YINC:=(YMAX-YMIN)/80;
    YSTART:=ROUND(239+YMIN/YINC);
    DRAWLINE(R,S,20,0,YSTART,314,0,1);
    GOTOXY(79,YSTART DIV 10);
    WRITE('X');
    DRAWLINE(R,S,20,35,239,0,-80,1);
    GOTOXY(8,15);
    WRITE('Y');
    YSTART:=YSTART+1;
    FOR I:=0 TO 9 DO
      BEGIN
        XSTART:=35*I;
        DRAWLINE(R,S,20,XSTART,YSTART,0,-5,1)
      END;
    FOR I:=0 TO 4 DO
      BEGIN
        YSTART:=239-20*I;
        DRAWLINE(R,S,20,34,YSTART,5,0,1);
      END;
    GOTOXY(0,11);
    WRITE('"X" SCALE GRADUATIONS ARE IN UNITS OF ');
    IF DEG THEN WRITELN('90 DEGREES')
           ELSE WRITELN('0.5 PI-RADIANS');
    WRITE('"Y" SCALE GRADUATIONS ARE IN UNITS OF ',(YMAX-YMIN)/4:5:2,
          ' FROM ',YMIN:4:2,' TO ',YMAX:4:2);
    GOTOXY(80,0);
    FOR I:=0 TO 313 DO
      BEGIN
        X:=-1.570796327+I/314*14.13716694;
        Y:=A*SIN(B*X+C)+D;
        X1:=-1.570796327+(I+1)/314*14.13716694;
        Y1:=A*SIN(B*X1+C)+D;
        YSTART:=ROUND(239-(SIN(X)-YMIN)/YINC);
        DY:=ROUND(239-(SIN(X1)-YMIN)/YINC-YSTART);
        IF ODD((I+1) DIV 4) THEN INK:=1 ELSE INK:=0;
        DRAWLINE(R,S,20,I,YSTART,1,DY,INK);
        YSTART:=ROUND(239-(Y-YMIN)/YINC);
        DY:=ROUND(239-(Y1-YMIN)/YINC-YSTART);
        DRAWLINE(R,S,20,I,YSTART,1,DY,1)
      END;
  GOTOXY(0,2);
  WRITELN('DOTTED CURVE IS Y=SIN(X)');
  WRITELN('SOLID CURVE IS');
  GOTOXY(20,5);
  WRITE('press RETURN to continue');
  READLN;
  UNTIL FALSE
END.

========================================================================================
DOCUMENT :usus Folder:VOL22:traverse.text
========================================================================================

{$L- TRAVERSE.LIST}

{
                                                  program by:  EDWARD J GRUNDLER

     Changes made and comments by reviewer:
        This program used REMOTE and was written to be used with
          a DECWRITER (presumably an older model than the reviewer's
          DECWRITER IV).  An attempt was made to substitute REMIN
          and REMOUT for REMOTE, but this change was not tested.
          The present program uses a rather crude, but presumably
          effective, way of preventing the computer from outrunning
          the printer. The hard copy output could be greatly simplified
          by using PRINTER: or by providing assembly language drivers.
        Reversed ranges on type SCREEN.
        Replaced PAGE(OUTPUT) by CLEARSCREEN.
        Removed definitions of CEOL,EOP,RLF.
        Added line DEFINESTRINGS to main program.
        Changed EOP to CEOP.
        Provided missing unit PLOTTER.
        Changed TTY to TTYIN AND TTYOUT (hopefully correctly).
        Defined UP and DOWN (for use with PLOTTER).
                 ---Henry E. Baumgarten
}

PROGRAM TRAVERSE;
USES {$U GRAPH.LIBRARY} SCREEN_STUFF, PLOTTER;
CONST MAX_NO_OF_SIDES = 50;
      F_TO_M = 0.3048;
      R_TO_D = 57.29577951;
      SQ_FT_TO_ACRES = 43560.0;
      UP = 0;
      DOWN = 1;
TYPE SCREEN = PACKED ARRAY[0..239,0..319] OF BOOLEAN;
     REAL_ARRAY = ARRAY[1..MAX_NO_OF_SIDES] OF REAL;
     CHAR_ARRAY = ARRAY[1..MAX_NO_OF_SIDES] OF CHAR;
VAR CLOSE_D,CLOSE_M,SIDES,I:INTEGER;
    CLOSE_S,DX,DY,FT_SQ,M_SQ,ACRES,N_MIN,N_MAX,RNG,E_MIN,E_MAX:REAL;
    REF_D,REF_M,REF_S,REF,PRECISION,PERIMETER,CLOSURE:REAL;
    FEET:BOOLEAN;
    L,LA,LB,CLOSE_L1,CLOSE_L2,ANSWER:CHAR;
    TITLE:STRING;
    SIDE,DIR,NORTH,EAST,X,Y,XC,YC,DEG,MIN,SEC,SLOPE:REAL_ARRAY;
    L1,L2,L3:CHAR_ARRAY;

PROCEDURE DRAWLINE(VAR R:INTEGER;
                   VAR S:SCREEN; RW,XSTRT,YSTRT,DX,DY,INK:INTEGER);
EXTERNAL;

PROCEDURE DIS_TO_BEAR(X,Y:REAL; VAR D,M:INTEGER; VAR S:REAL; VAR L1,L2:CHAR);
VAR DIST:REAL;
BEGIN
  DIST:=SQRT(SQR(Y)+SQR(X));
  IF Y=0 THEN S:=90 ELSE S:=ABS(ATAN(X/Y))*R_TO_D;
  D:=TRUNC(S);
  S:=(S-D)*60;
  M:=TRUNC(S);
  S:=(S-M)*60;
  IF Y<0 THEN L1:='S' ELSE L1:='N';
  IF X<0 THEN L2:='W' ELSE L2:='E'
END;

PROCEDURE PLOT_PAPER;
CONST SIZE = 1400;
VAR INC:REAL;
    J,XEND,YEND:INTEGER;
BEGIN
  INITPLOT;
  INC:=RNG/SIZE;
  XEND:=ROUND((EAST[1]-E_MIN)/INC);
  YEND:=ROUND((NORTH[1]-N_MIN)/INC);
  WRITELN('put PAPER in the PLOTTER and press RETURN to continue');
  READLN;
  WRITELN('the LOWER LEFT corner of the plot is location X = 0, Y = 0');
  PLOT(UP,XEND,YEND);
  XEND:=XEND+20;
  PLOT(DOWN,XEND,YEND);
  XEND:=XEND-40;
  PLOT(DOWN,XEND,YEND);
  XEND:=XEND+20;
  PLOT(DOWN,XEND,YEND);
  YEND:=YEND+20;
  PLOT(DOWN,XEND,YEND);
  YEND:=YEND-40;
  PLOT(DOWN,XEND,YEND);
  YEND:=YEND+20;
  PLOT(DOWN,XEND,YEND);
  FOR I:=1 TO SIDES DO
    BEGIN
      J:=I MOD SIDES+1;
      XEND:=ROUND((EAST[J]-E_MIN)/INC);
      YEND:=ROUND((NORTH[J]-N_MIN)/INC);
      PLOT(DOWN,XEND,YEND);
      XEND:=XEND+20;
      YEND:=YEND+20;
      PLOT(DOWN,XEND,YEND);
      XEND:=XEND-40;
      YEND:=YEND-40;
      PLOT(DOWN,XEND,YEND);
      XEND:=XEND+20;
      YEND:=YEND+20;
      PLOT(DOWN,XEND,YEND);
      XEND:=XEND+20;
      YEND:=YEND-20;
      PLOT(DOWN,XEND,YEND);
      XEND:=XEND-40;
      YEND:=YEND+40;
      PLOT(DOWN,XEND,YEND);
      XEND:=XEND+20;
      YEND:=YEND-20;
      PLOT(DOWN,XEND,YEND)
    END;
  PLOT(UP,1700,1000);
  PLOT(DOWN,1700,1200);
  PLOT(DOWN,1660,1160);
  PLOT(UP,1680,1220);
  PLOT(DOWN,1680,1260);
  PLOT(DOWN,1720,1220);
  PLOT(DOWN,1720,1260);
  PLOT(UP,0,0)
END;

PROCEDURE PLOT_SCREEN;
CONST SIZE = 240;
VAR MIN,MID,MAX,INC:REAL;
    R,J,XSTRT,XSTP,YSTRT,YSTP:INTEGER;
    S:SCREEN;
BEGIN
  CLEARSCREEN;
  FILLCHAR(S,SIZEOF(S),CHR(0));
  UNITWRITE(3,S,63);
  N_MAX:=NORTH[1];
  N_MIN:=NORTH[1];
  E_MAX:=EAST[1];
  E_MIN:=EAST[1];
  FOR I:=2 TO SIDES DO
    BEGIN
      IF NORTH[I]>N_MAX THEN N_MAX:=NORTH[I]
      ELSE IF NORTH[I]<N_MIN THEN N_MIN:=NORTH[I];
      IF EAST[I]>E_MAX THEN E_MAX:=EAST[I]
      ELSE IF EAST[I]<E_MIN THEN E_MIN:=EAST[I];
    END;
  IF (N_MAX-N_MIN)>(E_MAX-E_MIN) THEN
    BEGIN
      MAX:=N_MAX+(N_MAX-N_MIN)/18;
      MIN:=N_MIN-(N_MAX-N_MIN)/18
    END
  ELSE
    BEGIN
      MAX:=E_MAX+(E_MAX-E_MIN)/18;
      MIN:=E_MIN-(E_MAX-E_MIN)/18
    END;
  RNG:=MAX-MIN;
  INC:=RNG/SIZE;
  MID:=(N_MAX+N_MIN)/2;
  N_MAX:=MID+INC*120;
  N_MIN:=MID-INC*120;
  MID:=(E_MAX+E_MIN)/2;
  E_MAX:=MID+INC*120;
  E_MIN:=MID-INC*120;
  YSTRT:=ROUND((N_MAX-NORTH[1])/INC);
  XSTRT:=279-ROUND((E_MAX-EAST[1])/INC);
  FOR I:=1 TO SIDES DO
    BEGIN
      J:=I MOD SIDES + 1;
      YSTP:=ROUND((N_MAX-NORTH[J])/INC);
      XSTP:=279-ROUND((E_MAX-EAST[J])/INC);
      DRAWLINE(R,S,20,XSTRT,YSTRT,XSTP-XSTRT,YSTP-YSTRT,1);
      XSTRT:=XSTP;
      YSTRT:=YSTP
    END;
  WRITELN('press');
  WRITELN('RETURN');
  WRITELN('to');
  WRITELN('continue');
  READLN;
  CLEARSCREEN;
  UNITWRITE(3,S,7)
END;

FUNCTION INPUT_VALUE:REAL;

{
                                                 function by:  EDWARD J GRUNDLER
}

VAR I:INTEGER;
    INP:STRING;
    DEC,NEX,EX,NEG,OK:BOOLEAN;
    EXPO,J,X:REAL;
BEGIN
  REPEAT
    DEC:=FALSE;
    EX:=FALSE;
    READLN(INP);
    IF LENGTH(INP)=0 THEN INP:='0';
    OK:=NOT(INP[1]='E');
    IF LENGTH(INP)>1 THEN
      OK:=OK AND NOT((INP[1] IN ['+','-','.']) AND (INP[2]='E'));
    FOR I:=1 TO LENGTH(INP) DO
      BEGIN
        OK:=OK AND (INP[I] IN ['.','-','+','E','0'..'9']);
        IF (I>1) AND NOT EX THEN OK:=OK AND (INP[I] IN ['.','E','0'..'9']);
        OK:=OK AND NOT(DEC AND(INP[I]='.'));
        IF NOT DEC THEN DEC:=(INP[I]='.');
        OK:=OK AND NOT(EX AND (INP[I]='E'));
        IF NOT EX THEN EX:=(INP[I]='E');
        IF I>1 THEN
          OK:=OK AND NOT(EX AND (INP[I] IN ['+','-']) AND NOT(INP[I-1]='E'));
        OK:=OK AND NOT(EX AND (INP[I]='.'))
      END;
    OK:=OK AND (INP[LENGTH(INP)] IN ['0'..'9','.']);
    OK:=OK AND NOT(EX AND NOT(INP[LENGTH(INP)] IN ['0'..'9']));
    IF NOT OK THEN WRITE(RLF,'READ ERROR, TRY AGAIN ',CEOL)
  UNTIL OK;
  X:=0;
  DEC:=FALSE;
  EXPO:=0;
  NEG:=FALSE;
  EX:=FALSE;
  J:=1;
  FOR I:=1 TO LENGTH(INP) DO
    BEGIN
      IF NOT DEC THEN DEC:=(INP[I]='.');
      IF NOT NEG THEN NEG:=NOT EX AND (INP[I]='-');
      IF NOT NEX THEN NEX:=EX AND (INP[I]='-');
      IF NOT EX THEN EX:=(INP[I]='E');
      IF EX AND NOT(INP[I] IN ['+','-','E']) THEN
        EXPO:=EXPO*10+ORD(INP[I])-ORD('0');
      IF NOT EX THEN
        BEGIN
          IF DEC AND NOT(INP[I] IN ['.','+','-']) THEN
            BEGIN
              J:=J/10;
              X:=X+(ORD(INP[I])-ORD('0'))*J
            END
          ELSE
            IF NOT(INP[I] IN ['.','+','-']) THEN X:=X*10+ORD(INP[I])-ORD('0')
        END
    END;
  IF EX AND NEX THEN EXPO:=-EXPO;X:=X*EXP(LN(10)*EXPO);
  IF NEG THEN INPUT_VALUE:=-X ELSE INPUT_VALUE:=X
END;

PROCEDURE PRINTOUT;
VAR TTYOUT,TTYIN:INTERACTIVE;
    BEAR_D,BEAR_M,J:INTEGER;
    BEAR_S,DIST:REAL;
    CR,LF,L1,L2:CHAR;
  PROCEDURE DECWAIT; {TO PREVENT DATA OVERRUN AT 9600 BAUD}

  {
                                                procedure by:  EDWARD J GRUNDLER
  }
  
  VAR HOLD:CHAR;
      TTYIN:INTERACTIVE;
  BEGIN {DECWAIT}
    HOLD:=' ';
    RESET(TTYIN,'REMIN:');
    UNITREAD(7,HOLD,1,,1);
    IF UNITBUSY(7) THEN UNITCLEAR(7)  (*???*)
    ELSE
      BEGIN
        IF HOLD = CHR(19) THEN  {CTRL S}
          REPEAT
            READ(TTYIN,HOLD)
          UNTIL HOLD = CHR(17)  {CTRL Q}
      END;
  END; {DECWAIT}
  PROCEDURE PRIN_2;
  BEGIN {PRIN_2}
    WRITE(TTYOUT,PERIMETER:17:3,'                     ',DY:10:3,DX:10:3,CR);
    DECWAIT;
    FOR I:=1 TO 4 DO WRITE(TTYOUT,LF);
    WRITE(TTYOUT,'ABOVE DATA ARE IN ');
    IF FEET THEN WRITE(TTYOUT,'FEET',CR,LF,LF) ELSE WRITE(TTYOUT,'METERS',CR,LF,LF);
    WRITE(TTYOUT,'TRAVERSE COMPUTATION AND ADJUSTMENT BY THE COMPASS RULE',CR);
    FOR I:=1 TO 4 DO WRITE(TTYOUT,LF);
    DECWAIT;
    WRITE(TTYOUT,'CLOSURE = ');
    IF FEET THEN
      WRITE(TTYOUT,CLOSURE:6:4,' FT   = ',CLOSURE*F_TO_M:6:4,' M      ')
    ELSE
      WRITE(TTYOUT,CLOSURE/F_TO_M:6:4,' FT   = ',CLOSURE:6:4,' M      ');
    WRITE(TTYOUT,'CLOSURE BEARING IS ',CLOSE_L1,CLOSE_D:2,CLOSE_M:3,CLOSE_S:5:1,
          CLOSE_L2,CR,LF);
    DECWAIT;
    WRITE(TTYOUT,LF,'PRECISION = 1 IN ',PRECISION:8:3,CR,LF,LF);
    DECWAIT;
    WRITE(TTYOUT,'AREA = ',FT_SQ:8:3,' SQ. FT.   = ',M_SQ:8:3,' SQ. M.   = ',
          ACRES:6:3,' ACRES',CR,LF);
    PAGE(TTYOUT)
  END; {PRIN_2}
BEGIN {PRINTOUT}
  CR:=CHR(13);
  LF:=CHR(10);
  REWRITE(TTYOUT,'REMOUT:');
  RESET(TTYIN,'REMIN:');
  CLEARSCREEN;
  WRITELN('position PAPER to top of page and press RETURN on DECWRITER');
  READLN(TTYIN);
  {The following line contains commands to the printer, presumably to
   set character widths on the dot matrix DECWRITER. One would guess that
   TITLE is set in wide char and the text in smaller char.---heb}
  WRITE(TTYOUT,CHR(27),CHR(91),CHR(53),CHR(119),TITLE,CR,LF,LF,CHR(27),CHR(91),
        CHR(49),CHR(119));
  FOR I:=1 TO 44 DO WRITE(TTYOUT,' ');
  WRITE(TTYOUT,'UNBALANCED           BALANCED              ',
        'CORRECTED                  COORDINATES',CR,LF,'COURSE    LENGTH     ',
        'AZIMUTH     SLOPE     LAT       DEP       LAT       DEP     ',
        'DISTANCE     BEARING     STA    NORTH     EAST',CR,LF,LF);
  FOR I:=1 TO SIDES DO
    BEGIN
      J:=I MOD SIDES+1;
      DIS_TO_BEAR(XC[I],YC[I],BEAR_D,BEAR_M,BEAR_S,L1,L2);
      DIST:=SQRT(SQR(XC[I])+SQR(YC[I]));
      WRITE(TTYOUT,I:2,' -',J:2,SIDE[I]:11:3,ROUND(DEG[I]):5,ROUND(MIN[I]):3,
            SEC[I]:5:1,SLOPE[I]:8:3,Y[I]:10:3,X[I]:10:3,YC[I]:10:3,XC[I]:10:3,
            DIST:10:3,'   ',L1,BEAR_D:2,BEAR_M:3,BEAR_S:5:1,L2,' |',I:3,
            NORTH[I]:13:3,EAST[I]:10:3,CR,LF);
      DECWAIT
    END;
  PRIN_2
END;

PROCEDURE D_TO_DMS(I:INTEGER);
BEGIN
  SEC[I]:=DIR[I];
  DEG[I]:=TRUNC(SEC[I]);
  SEC[I]:=(SEC[I]-DEG[I])*60;
  MIN[I]:=TRUNC(SEC[I]+0.00833333);
  SEC[I]:=ABS((SEC[I]-MIN[I])*60)
END;

PROCEDURE QUERY(STR:STRING);
BEGIN
  WRITE(STR);
  REPEAT READ(KEYBOARD,ANSWER) UNTIL ANSWER IN ['Y','y','N','n'];
  WRITELN
END;

PROCEDURE DISPLAY;
VAR J:INTEGER;
  PROCEDURE DISP_2;
  BEGIN {DISP_2}
    WRITE('CLOSURE = ');
    IF FEET THEN WRITE(CLOSURE:6:4,' FT   = ',CLOSURE*F_TO_M:6:4,' M      ')
    ELSE WRITE(CLOSURE/F_TO_M:6:4,' FT   = ',CLOSURE:6:4,' M      ');
    WRITELN('CLOSURE BEARING IS ',CLOSE_L1,CLOSE_D:2,CLOSE_M:3,CLOSE_S:5:1,
            CLOSE_L2);
    WRITELN;
    WRITELN('PRECISION = 1 IN ',PRECISION:8:3);
    WRITELN;
    WRITELN('AREA = ',FT_SQ:6:1,' SQ. FT.   = ',M_SQ:6:1,' SQ. M.   = ',ACRES:6:3,
            ' ACRES');
    WRITELN;
    WRITELN('press RETURN to continue');
    READLN;
    CLEARSCREEN
  END; {DISP_2}
BEGIN
  FOR I:=1 TO SIDES DO
    BEGIN
      IF (I MOD 18)=1 THEN
        BEGIN
          CLEARSCREEN;
          WRITELN(TITLE);
          WRITELN;
          WRITELN('COURSE LENGTH  AZIMUTH     UNBALANCED         BALANCED',
                  '           COORDINATES');
          GOTOXY(27,3);
          WRITELN('LAT      DEP      LAT      DEP   STA NORTH    EAST');
          WRITELN
        END;
      J:=I MOD SIDES+1;
      WRITELN(I:2,'-',J:2,SIDE[I]:8:3,TRUNC(DEG[I]):4,TRUNC(MIN[I]):3,
              ROUND(SEC[I]):3,Y[I]:9:3,X[I]:9:3,YC[I]:9:3,XC[I]:9:3,I:3,
              NORTH[I]:9:2,EAST[I]:9:2);
      IF I=SIDES THEN WRITE('   ',PERIMETER:10:3,'          ',DY:9:3,DX:9:3);
      IF ((I MOD 18)=0) OR (I=SIDES) THEN
        BEGIN
          GOTOXY(50,23);
          WRITE('press RETURN to continue');
          READLN;
          CLEARSCREEN
        END
    END;
  DISP_2
END;

PROCEDURE CALCULATE;
VAR J:INTEGER;
    TRUE,AREA:REAL;
  PROCEDURE CALC_2;
  BEGIN {CALC_2}
    FOR I:=1 TO SIDES DO
      BEGIN
        TRUE:=SIDE[I]*COS(SLOPE[I]/R_TO_D);
        X[I]:=TRUE*SIN(DIR[I]);
        Y[I]:=TRUE*COS(DIR[I]);
        DX:=DX+X[I];
        DY:=DY+Y[I];
        PERIMETER:=PERIMETER+TRUE
      END;
    CLOSURE:=SQRT(SQR(DX)+SQR(DY));
    DIS_TO_BEAR(-DX,-DY,CLOSE_D,CLOSE_M,CLOSE_S,CLOSE_L1,CLOSE_L2);
    IF CLOSURE=0 THEN PRECISION:=999999.0
    ELSE PRECISION:=PERIMETER/CLOSURE;
    FOR I:=1 TO SIDES DO
      BEGIN
        XC[I]:=X[I]-(SIDE[I]*DX)/PERIMETER;
        YC[I]:=Y[I]-(SIDE[I]*DY)/PERIMETER;
        IF NOT (I = SIDES) THEN
          BEGIN
            NORTH[I+1]:=NORTH[I]+YC[I];
            EAST[I+1]:=EAST[I]+XC[I]
          END
      END;
    FOR I:=1 TO SIDES DO
      BEGIN
        J:=I MOD SIDES+1;
        AREA:=AREA+EAST[I]*NORTH[J]-EAST[J]*NORTH[I]
      END;
    AREA:=ABS(AREA)/2;
    IF FEET THEN
      BEGIN
        FT_SQ:=AREA;
        M_SQ:=FT_SQ*SQR(F_TO_M)
      END
    ELSE
      BEGIN
        M_SQ:=AREA;
        FT_SQ:=M_SQ/SQR(F_TO_M)
      END;
    ACRES:=FT_SQ/SQ_FT_TO_ACRES
  END; {CALC_2}
BEGIN {CALCULATE}
  IF L1[1] IN ['R','r','L','l','I','i','E','e'] THEN
    BEGIN
      REF:=180+REF_D+REF_M/60+REF_S/3600;
      IF L IN ['B','b'] THEN
        BEGIN
          IF LA IN ['S','s'] THEN REF:=180-REF;
          IF LB IN ['W','w'] THEN REF:=360-REF
        END
    END;
  FOR I:=1 TO SIDES DO
    BEGIN
      IF NOT(L1[I] IN ['A','a']) THEN DIR[I]:=DEG[I]+MIN[I]/60+SEC[I]/3600;
      CASE L1[I] OF
      'A','a','D','d':;
      'B','b':
        BEGIN
          IF L2[I] IN ['S','s'] THEN DIR[I]:=180-DIR[I];
          IF L3[I] IN ['W','w'] THEN DIR[I]:=360-DIR[I];
        END;
      'R','r':IF I=1 THEN DIR[1]:=REF+180+DIR[1]
                     ELSE DIR[I]:=DIR[I-1]+180+DIR[I];
      'L','l':IF I=1 THEN DIR[1]:=REF+180-DIR[1]
                     ELSE DIR[I]:=DIR[I-1]+180-DIR[I];
      'E','e':IF I=1 THEN DIR[1]:=REF-DIR[1] ELSE DIR[I]:=DIR[I-1]-DIR[1];
      'I','i':IF I=1 THEN DIR[1]:=REF+DIR[1] ELSE DIR[I]:=DIR[I-1]+DIR[I];
      END; {OF CASE}
      REPEAT
        IF DIR[I]>=360 THEN DIR[I]:=DIR[I]-360
        ELSE IF DIR[I]<0 THEN DIR[I]:=DIR[I]+360
      UNTIL (DIR[I]>=0) AND (DIR[I]<360)
    END;
  FOR I:=1 TO SIDES DO
    BEGIN
      D_TO_DMS(I);
      DIR[I]:=DIR[I]/R_TO_D
    END;
  DX:=0;
  DY:=0;
  PERIMETER:=0;
  AREA:=0;
  CALC_2
END;

PROCEDURE INITIALIZE;
  PROCEDURE GET_REF;
  BEGIN
    WRITELN('IS REFERENCE A BEARING OR AN AZIMUTH? ');
    REPEAT READ(KEYBOARD,L) UNTIL L IN ['B','b','A','a'];
    IF L IN ['B','b'] THEN
      BEGIN
        WRITELN('ENTER QUADRANT');
        REPEAT
          READ(KEYBOARD,LA,LB)
        UNTIL (LA IN ['N','n','S','s']) AND (LB IN ['E','e','W','w'])
      END;
    WRITE('ENTER DEGREES ');
    REF_D:=INPUT_VALUE;
    WRITE('ENTER MINUTES ');
    REF_M:=INPUT_VALUE;
    WRITE('ENTER SECONDS ');
    REF_S:=INPUT_VALUE
  END; {GET_REF}
  PROCEDURE GET_ANGLE(J:INTEGER);
  BEGIN
    UNITWRITE(3,I,7);
    WRITELN('WHICH OPTION FOR ANGLE ',J,'? ');
    REPEAT
      READ(KEYBOARD,L1[J])
    UNTIL L1[J] IN ['B','b','R','r','L','l','I','i','E','e','D','d','A','a'];
    IF (J=1) AND (L1[J] IN ['R','r','L','l','I','i','E','e']) THEN
      BEGIN
        WRITELN('CURRENT REFERENCE AZIMUTH IS:  ',TRUNC(REF_D):4,
                TRUNC(REF_M):3,REF_S:5:1);
        QUERY('IS THAT CORRECT? ');
        IF ANSWER IN ['N','n'] THEN GET_REF
      END;
    IF L1[J] IN ['B','b'] THEN
      BEGIN
        WRITELN('ENTER QUADRANT');
        REPEAT
          READ(KEYBOARD,L2[J],L3[J])
        UNTIL (L2[J] IN ['N','n','S','s']) AND (L3[J] IN ['E','e','W','w'])
      END;
    IF L1[J] IN ['A','a'] THEN
      BEGIN
        WRITE('ENTER DECIMAL DEGREES ');
        DIR[J]:=INPUT_VALUE
      END
    ELSE
      BEGIN
        WRITE('ENTER DEGREES FOR ANGLE ',J,' ');
        DEG[J]:=INPUT_VALUE;
        WRITE('ENTER MINUTES ');
        MIN[J]:=INPUT_VALUE;
        WRITE('ENTER SECONDS ');
        SEC[J]:=INPUT_VALUE
      END;
    UNITWRITE(3,I,3)
  END; {GET_ANGLE}
  PROCEDURE INIT_2;
  VAR J:INTEGER;
    PROCEDURE FIX_IT;
    VAR J:INTEGER;
        X:REAL;
    BEGIN {FIX_IT}
      QUERY('ARE ANY LENGTHS INCORRECT? ');
      IF ANSWER IN ['Y','y'] THEN
        BEGIN
          REPEAT
            REPEAT
              WRITE(RLF,'WHICH SIDE IS IN ERROR? ',CEOL);
              J:=ROUND(INPUT_VALUE)
            UNTIL (J>((I-1) DIV 12*12)) AND (J<=I);
            WRITE(RLF,'ENTER NEW VALUE ',CEOL);
            SIDE[J]:=INPUT_VALUE;
            GOTOXY(4,(J-1) MOD 12+10);
            WRITE(SIDE[J]:10:3);
            GOTOXY(0,I+10);
            QUERY('ARE THERE ANY MORE LENGTHS THAT ARE INCORRECT? ');
          UNTIL ANSWER IN ['N','n'];
        END;
      WRITE(RLF,CEOL);
      QUERY('ARE ANY DIRECTIONS IN ERROR? ');
      IF ANSWER IN ['Y','y'] THEN
        BEGIN
          REPEAT
            REPEAT
              WRITE(RLF,'WHICH SIDE IS IN ERROR? ',CEOL);
              J:=ROUND(INPUT_VALUE)
            UNTIL (J>((I-1) DIV 12*12)) AND (J<=I);
            GET_ANGLE(J);
            UNITWRITE(3,I,7);
            GOTOXY(16,(J-1) MOD 12+10);
            IF L1[J] IN ['A','a'] THEN WRITE('A   ',DIR[J]:10:4)
            ELSE
              BEGIN
                IF L1[J] IN ['B','b'] THEN WRITE(L1[J],' ',L2[J],L3[J])
                ELSE WRITE(L1[J],'   ');
                WRITE(TRUNC(DEG[J]):4,TRUNC(MIN[J]):3,SEC[J]:5:1)
              END;
            GOTOXY(0,I+10);
            QUERY('ARE THERE ANY MORE DIRECTIONS IN ERROR? ');
            WRITE(CEOP)
          UNTIL ANSWER IN ['N','n'];
        WRITE(RLF,CEOL)
      END
    END; {FIX_IT}
    PROCEDURE GET_SLOPES;
    VAR J:INTEGER;
        INP:REAL;
    BEGIN {GET_SLOPES}
      GOTOXY(34,8);
      WRITE('SLOPE ANGLE');
      GOTOXY(0,I+10);
      REPEAT
        REPEAT
          WRITE('WHICH SIDE IS A SLOPE DISTANCE ',CEOL);
          J:=ROUND(INPUT_VALUE);
          WRITE(RLF);
        UNTIL (J>((I-1) DIV 12*12)) AND (J<=I);
        WRITE('ENTER SLOPE DEGREES ',CEOL);
        SLOPE[J]:=INPUT_VALUE;
        GOTOXY(34,(J-1) MOD 12+10);
        WRITE(ROUND(SLOPE[J]):3);
        GOTOXY(0,I+10);
        WRITE('ENTER SLOPE MINUTES ',CEOL);
        INP:=INPUT_VALUE;
        GOTOXY(37,(J-1) MOD 12+10);
        WRITE(ROUND(INP):3);
        GOTOXY(0,I+10);
        SLOPE[J]:=SLOPE[J]+INP/60;
        WRITE('ENTER SLOPE SECONDS ',CEOL);
        INP:=INPUT_VALUE;
        GOTOXY(40,(J-1) MOD 12+10);
        WRITE(INP:5:1);
        GOTOXY(0,I+10);
        SLOPE[J]:=(SLOPE[J]+INP/3600);
        WRITE(CEOL);
        QUERY('ARE ANY MORE LENGTHS ENTERED AS SLOPE DISTANCES? ')
      UNTIL ANSWER IN ['N','n']
    END;
    PROCEDURE INIT_3;
    BEGIN {INIT_3}
      CLEARSCREEN;
      REPEAT
        WRITE('ENTER THE NORTH CO-ORDINATE OF STATION "1" ');
        NORTH[1]:=INPUT_VALUE;
        WRITE('NORTH CO-ORDINATE IS ',NORTH[1]:8:3);
        QUERY(' IS THAT CORRECT? ')
      UNTIL ANSWER IN ['Y','y'];
      REPEAT
        WRITE('ENTER THE EAST CO-ORDINATE OF STATION "1" ');
        EAST[1]:=INPUT_VALUE;
        WRITE('EAST CO-ORDINATE IS ',EAST[1]:8:3);
        QUERY(' IS THAT CORRECT? ')
      UNTIL ANSWER IN ['Y','y'];
    END; {INIT_3}
  BEGIN {INIT_2}
    IF L1[1] IN ['R','r','L','l','I','i','E','e'] THEN
      REPEAT
        GOTOXY(0,8);
        IF L IN ['A','a'] THEN
          WRITELN('REFERENCE AZIMUTH IS',
                  TRUNC(REF_D):4,TRUNC(REF_M):4,REF_S:5:1,CEOP)
        ELSE WRITELN('REFERENCE BEARING IS ',
                    LA,TRUNC(REF_D):2,TRUNC(REF_M):3,REF_S:5:1,LB,CEOP);
        QUERY('IS THAT CORRECT? ');
        IF ANSWER IN ['N','n'] THEN GET_REF
      UNTIL ANSWER IN ['Y','y'];
    FOR I:=1 TO SIDES DO
      BEGIN
        IF ((I MOD 12) = 1) THEN
          BEGIN
            UNITWRITE(3,I,7);
            GOTOXY(0,8);
            WRITELN(CEOP,'SIDE   LENGTH   CODE  DIRECTION');
            WRITELN
          END;
        WRITE(I:4,SIDE[I]:10:3,'  ');
        IF L1[I] IN ['A','a'] THEN WRITELN('A   ',DIR[I]:10:4)
        ELSE
          BEGIN
            IF L1[I] IN ['B','b'] THEN WRITE(L1[I],' ',L2[I],L3[I])
            ELSE WRITE(L1[I],'   ');
            WRITELN(TRUNC(DEG[I]):4,TRUNC(MIN[I]):3,SEC[I]:5:1)
          END;
        IF ((I MOD 12)=0) OR (I=SIDES) THEN
          BEGIN
            QUERY('ARE ALL OF THE ABOVE DATA CORRECT? ');
            WRITE(RLF,CEOL);
            IF ANSWER IN ['N','n'] THEN FIX_IT;
            FOR J:=1 TO SIDES DO SLOPE[J]:=0;
            QUERY('WERE ANY LENGTHS ENTERED AS SLOPE DISTANCES? ');
            IF ANSWER IN ['Y','y'] THEN GET_SLOPES;
            WRITE(RLF,CEOL)
          END
      END;
    INIT_3
  END; {INIT_2}
BEGIN {INITIALIZE}
  DEFINESTRINGS;
  CLEARSCREEN;
  REF_D:=0;
  REF_M:=0;
  REF_S:=0;
  REPEAT
    WRITELN('ENTER THE TITLE OF THE TRAVERSE');
    READLN(TITLE);
    WRITELN(TITLE);
    QUERY('--IS THAT CORRECT? ');
  UNTIL ANSWER IN ['Y','y'];
  REPEAT
    REPEAT
      WRITE('ENTER NUMBER OF SIDES ');
      SIDES:=ROUND(INPUT_VALUE);
      IF SIDES>MAX_NO_OF_SIDES THEN WRITE('MAXIMUM IS ',MAX_NO_OF_SIDES,' --');
    UNTIL SIDES IN [3..MAX_NO_OF_SIDES];
    WRITE('TRAVERSE HAS ',SIDES,' SIDES. ');
    QUERY('IS THAT CORRECT? ')
  UNTIL ANSWER IN ['Y','y'];
  REPEAT
    WRITELN('WILL LENGTHS BE ENTERED IN M(eters OR F(eet? ');
    READ(KEYBOARD,ANSWER)
  UNTIL ANSWER IN ['M','m','F','f'];
  FEET:=ANSWER IN ['F','f'];
  CLEARSCREEN;
  UNITWRITE(3,I,3);
  WRITELN('ENTRY OPTIONS ARE:');
  WRITELN;
  WRITELN('B(earing');
  WRITELN('interior angles to the R(ight or L(eft');
  WRITELN('deflection angles to the rI(ght or lE(ft');
  WRITELN('azimuth in D(egrees, minutes and seconds');
  WRITELN('A(zimuth in decimal degrees');
  FOR I:=1 TO SIDES DO
    BEGIN
      GOTOXY(0,8);
      WRITE(CEOP,'ENTER HORIZONTAL OR SLOPE LENGTH OF SIDE ',I,' ');
      SIDE[I]:=INPUT_VALUE;
      GET_ANGLE(I)
    END;
  INIT_2
END;

BEGIN {TRAVERSE}
  REPEAT
    INITIALIZE;
    CALCULATE;
    DISPLAY;
    QUERY('DO YOU WANT A HARD COPY? ');
    IF ANSWER IN ['Y','y'] THEN PRINTOUT;
    PLOT_SCREEN;
    QUERY('DO YOU WANT A HARD COPY? ');
    IF ANSWER IN ['Y','y'] THEN PLOT_PAPER;
    QUERY('IS THAT THE LAST TRAVERSE? ')
  UNTIL ANSWER IN ['Y','y'];
  CLEARSCREEN
END {TRAVERSE}.

========================================================================================
DOCUMENT :usus Folder:VOL22:triangle.text
========================================================================================

{$L-TRIANGLE.LIST}
{
                                 TRIANGLE program by:  KEN GAAL
                                          15-AUG-79
                                          
      Changes made by reviewer:
        Reversed ranges in type SCREENTYPE.
        Replaced PAGE(OUTPUT) with CLEARSCREEN.
        Replaced CHR(31) with RLF.
        Replaced CHR(29) with CEOL.
              ___Henry E. Baumgarten
}

PROGRAM TRIANGLE;
  USES {$U GRAPH.LIBRARY} SCREEN_STUFF;
CONST DTR=0.01745329;
      RTD=57.29578;
TYPE SCREENTYPE = PACKED ARRAY [0..239,0..319] OF BOOLEAN;
VAR S:  SCREENTYPE;
    VALID,AMBIG,LABEL2,USES_SSAAA:  BOOLEAN;
    AA,AB,AC,AA2,AB2,AC2,   { ANGLES }
    SA,SB,SC,SA2,SB2,SC2,   { SIDES  }
    SINA,COSA,SINB,COSB:  REAL;
    KTYP,R             :  INTEGER;

PROCEDURE DRAWLINE(VAR R:INTEGER;
                       S:SCREENTYPE; RW,XSTART,YSTART,DX,DY,INK:INTEGER);
EXTERNAL;

FUNCTION INPUT_VALUE:REAL;
VAR I:INTEGER;
    INP:STRING;
    DEC,NEX,EX,NEG,OK:BOOLEAN;
    EXPO,J,X:REAL;

BEGIN
  REPEAT
    DEC:=FALSE;
    EX:=FALSE;
    READLN(INP);
    IF LENGTH(INP)=0 THEN INP:='0';
    OK:=NOT(INP[1] IN ['E','-'] );
    IF LENGTH(INP)>1 THEN
                     OK:=OK AND NOT((INP[1] IN ['+','-','.']) AND (INP[2]='E'));
    FOR I:=1 TO LENGTH(INP) DO
      BEGIN
        OK:=OK AND (INP[I] IN ['.','-','+','E','0'..'9']);
        IF (I>1) AND NOT EX THEN OK:=OK AND (INP[I] IN ['.','E','0'..'9']);
        OK:=OK AND NOT(DEC AND(INP[I]='.'));
        IF NOT DEC THEN DEC:=(INP[I]='.');
        OK:=OK AND NOT(EX AND (INP[I]='E'));
        IF NOT EX THEN EX:=(INP[I]='E');
        IF I>1 THEN
             OK:=OK AND NOT(EX AND (INP[I] IN ['+','-']) AND NOT(INP[I-1]='E'));
        OK:=OK AND NOT(EX AND (INP[I]='.'))
      END;
    OK:=OK AND (INP[LENGTH(INP)] IN ['0'..'9','.']);
    OK:=OK AND NOT(EX AND NOT(INP[LENGTH(INP)] IN ['0'..'9']));
    IF NOT OK THEN WRITE(RLF,'READ ERROR, TRY AGAIN ',CEOL)
  UNTIL OK;
  X:=0;
  DEC:=FALSE;
  EXPO:=0;
  NEG:=FALSE;
  EX:=FALSE;
  J:=1;
  FOR I:=1 TO LENGTH(INP) DO
    BEGIN
      IF NOT DEC THEN DEC:=(INP[I]='.');
      IF NOT NEG THEN NEG:=NOT EX AND (INP[I]='-');
      IF NOT NEX THEN NEX:=EX AND (INP[I]='-');
      IF NOT EX THEN EX:=(INP[I]='E');
      IF EX AND NOT(INP[I] IN ['+','-','E']) THEN
                                             EXPO:=EXPO*10+ORD(INP[I])-ORD('0');
      IF NOT EX THEN
        BEGIN
          IF DEC AND NOT(INP[I] IN ['.','+','-']) THEN
            BEGIN
              J:=J/10;
              X:=X+(ORD(INP[I])-ORD('0'))*J
            END
          ELSE
            IF NOT(INP[I] IN ['.','+','-']) THEN X:=X*10+ORD(INP[I])-ORD('0')
        END
    END;
  IF EX AND NEX THEN EXPO:=-EXPO;X:=X*EXP(LN(10)*EXPO);
  IF NEG THEN INPUT_VALUE:=-X ELSE INPUT_VALUE:=X
END;

PROCEDURE DATA_IN;
VAR CH: CHAR;
BEGIN
  GOTOXY(0,23);
  WRITE('enter Q to quit or RETURN to continue'); READ(KEYBOARD,CH);
  IF CH IN ['q','Q'] THEN EXIT(PROGRAM);
  CLEARSCREEN;
  FILLCHAR(S,9600,CHR(0));
  UNITWRITE(3,S,63);  { CLEAR SCREEN }
  GOTOXY(0,1);
  WRITELN('ENTER, AS REQUESTED, VALUES OF SIDES AND ANGLES (DECIMAL DEG.)');
  WRITELN('  press RETURN if side or angle is not input');
  WRITELN;
  WRITELN('SIDE a  '); SA:=INPUT_VALUE;
  WRITELN('SIDE b  '); SB:=INPUT_VALUE;
  WRITELN('SIDE c  '); SC:=INPUT_VALUE;
  WRITELN('ANGLE A '); AA:=INPUT_VALUE;
  WRITELN('ANGLE B '); AB:=INPUT_VALUE;
  WRITELN('ANGLE C '); AC:=INPUT_VALUE;
  CLEARSCREEN;
  UNITWRITE(3,S,63);
  GOTOXY(0,1); WRITELN('INPUT VALUES');
  WRITELN('  SIDES:   a = ',SA:8:3,'  b = ',SB:8:3,'  c = ',SC:8:3);
  WRITELN('  ANGLES:  A = ',AA:8:3,'  B = ',AB:8:3,'  C = ',AC:8:3);
END; { procedure DATA_IN }

PROCEDURE PERMUTE;
VAR TEMP: REAL;
BEGIN
  TEMP:=AB; AB:=AA; AA:=AC; AC:=TEMP;
  TEMP:=SB; SB:=SA; SA:=SC; SC:=TEMP;
END; { procedure PERMUTE }

PROCEDURE XCHG_BC;
VAR TEMP: REAL;
BEGIN
  TEMP:=SB; SB:=SC; SC:=TEMP;
  TEMP:=AB; AB:=AC; AC:=TEMP;
END; { procedure XCHG_BC }

FUNCTION APPROX(X,Y:real): boolean;
var ERR,AX,AXMY: real;
begin
  ERR:=0.001;
  AX:=ABS(X); AXMY:=ABS(X-Y);
  APPROX:=(AXMY=0);
  if (AXMY=0) then EXIT(APPROX);
  if AX>0 then APPROX:=(AXMY/AX < ERR)
          else APPROX:=(AXMY/ABS(Y) < ERR);
end; { of function APPROX }


PROCEDURE SSS;
BEGIN
  WRITE('   SSS');
  IF SA >= SB+SC THEN BEGIN VALID:=FALSE; WRITE('   a >= b+c') END;
  IF SB >= SA+SC THEN BEGIN VALID:=FALSE; WRITE('   b >= a+c') END;
  IF SC >= SA+SB THEN BEGIN VALID:=FALSE; WRITE('   c >= a+b') END;
  IF NOT VALID THEN WRITE('    sides do NOT make a triangle');
  IF VALID THEN
    BEGIN
      COSA:=(SQR(SC)+SQR(SB)-SQR(SA))/(2*SC*SB);   SINA:=SQRT(1-COSA*COSA);
      IF COSA = 0 THEN AA:=90
                  ELSE AA:=ATAN(SINA/COSA)*RTD;
      IF AA<0 THEN AA:=AA+180;
      COSB:=(SQR(SA)+SQR(SC)-SQR(SB))/(2*SA*SC);  SINB:=SQRT(1-COSB*COSB);
      IF COSB = 0 THEN AB:=90
                  ELSE AB:=ATAN(SINB/COSB)*RTD;
      IF AB<0 THEN AB:=AB+180;
      AC := 180-AA-AB
    END; { if VALID }
END;   { procedure SSS }

PROCEDURE SAS;
begin
  WRITE('   SAS');
  CASE KTYP OF { permute SAS so that A = angle a (AA) }
     28: ;                            { A=AA }
     42: begin PERMUTE; PERMUTE end;  { A=AB }
     49: PERMUTE;                     { A=AC }
     END; { case KTYP }
  IF AA >= 180 THEN
                begin
                  VALID:=FALSE;
                  CASE KTYP OF
                     28: WRITE('   Angle A >= 180 DEG');
                     42: WRITE('   Angle B >= 180 DEG');
                     49: WRITE('   Angle C >= 180 DEG');
                     END; { case KTYP }
                end; { if AA >= 180 }
  IF VALID THEN
            begin
              SA:=SQRT(SB*SB+SC*SC-2*SB*SC*COS(AA*DTR)); { law of cosines }
              COSB:=(SQR(SA)+SQR(SC)-SQR(SB))/(2*SA*SC);
              SINB:=SQRT(1-COSB*COSB);
              IF COSB = 0 THEN AB:=90
                          ELSE AB:=ATAN(SINB/COSB)*RTD;
              IF AB < 0 THEN AB:=AB+180;
              AC:=180-AA-AB
            end; { if VALID }
  CASE KTYP OF { PERMUTE back to original labels }
     28: ;
     42: PERMUTE;
     49: begin PERMUTE; PERMUTE end;
     END; { of case KTYP }
end; { of procedure SAS }
     
PROCEDURE ASA;
begin
  WRITE('   ASA');
  CASE KTYP OF { permute ASA so that S = side c (SC) }
     14:  ;                          { S = SC }
     21: PERMUTE;                    { S = SB }
     35: begin PERMUTE; PERMUTE end; { S = SA }
     END; { case KTYP }
  IF AA+AB >= 180 THEN
        begin
          VALID:=FALSE;
          WRITE('Angles ');
          CASE KTYP OF
             14: WRITE('A + B ');
             21: WRITE('A + C ');
             35: WRITE('B + C ');
             END; { of case KTYP }
          WRITE(' >= 180 DEGREES')
        end; { of IF AA+BB >= 180 }
    IF VALID THEN { solve for parts of triangle }
        begin
          AC:=180-AA-AB;
          SA:=SC*SIN(AA*DTR)/SIN(AC*DTR);
          SB:=SC*SIN(AB*DTR)/SIN(AC*DTR)
        end; { of IF VALID }
    CASE KTYP OF { permute triangle back to original labels }
       14: ;
       21: begin PERMUTE; PERMUTE end;
       35: PERMUTE;
       END; { of case KTYP }
end; { of procedure ASA }

PROCEDURE SAA;
begin
  WRITE('   SAA');
  CASE KTYP OF { validity check and 3rd angle computation }
     11,19: IF AB+AC >= 180
                THEN begin
                       VALID:=FALSE;
                       WRITE('    Angles B + C >= 180')
                     end
                ELSE AA:=180-AB-AC;
     13,37: IF AA+AC >= 180
                THEN begin
                       VALID:=FALSE;
                       WRITE('    Angles A + C >= 180')
                     end
                ELSE AB:=180-AA-AC;
     22,38: IF AA+AB >= 180
                THEN begin
                       VALID:=FALSE;
                       WRITE('    Angles A + B >= 180')
                     end
                ELSE AC:=180-AA-AB;
     END; { case KTYP }
  IF VALID THEN
      begin
        CASE KTYP OF { permute labels so that S = side c (SC) }
           11,13: ;                           { S = SC }
           19,22: PERMUTE;                    { S = SB }
           37,38: begin PERMUTE; PERMUTE end; { S = SA }
           END; { of case KTYP }
        SA:=SC*SIN(AA*DTR)/SIN(AC*DTR);
        SB:=SC*SIN(AB*DTR)/SIN(AC*DTR);
        CASE KTYP OF { permute lables back to original positions }
           11,13: ;
           19,22: begin PERMUTE; PERMUTE end; 
           37,38: PERMUTE;
           END; { of case KTYP }
      end; { if VALID then }
end; { of procedure SAA }

PROCEDURE ASS;
VAR TEST: real;
  
  PROCEDURE CONVERT_BACK;
  begin
    CASE KTYP OF { convert back to original labels }
       52: ;
       44: XCHG_BC;
       50: begin XCHG_BC; PERMUTE end;
       26: PERMUTE;
       41: begin PERMUTE; PERMUTE end;
       25: begin XCHG_BC; PERMUTE; PERMUTE end;
       END; { of case KTYP }
  end; { procedure CONVERT_BACK }
  
  PROCEDURE AMBIG_PERMUTE;
  VAR TEMP: REAL;
  BEGIN
    TEMP:=AB2; AB2:=AA2; AA2:=AC2; AC2:=TEMP;
    TEMP:=SB2; SB2:=SA2; SA2:=SC2; SC2:=TEMP;
  END; { procedure AMBIG_PERMUTE }
  
  PROCEDURE AMBIG_XCHG_BC;
  VAR TEMP: REAL;
  BEGIN
    TEMP:=SB2; SB2:=SC2; SC2:=TEMP;
    TEMP:=AB2; AB2:=AC2; AC2:=TEMP;
  END; { procedure AMBIG_XCHG_BC }
  
  PROCEDURE AMBIG_CONVERT_BACK;
  begin
    CASE KTYP OF { convert back to original labels }
       52: ;
       44: AMBIG_XCHG_BC;
       50: begin AMBIG_XCHG_BC; AMBIG_PERMUTE end;
       26: AMBIG_PERMUTE;
       41: begin AMBIG_PERMUTE; AMBIG_PERMUTE end;
       25: begin AMBIG_XCHG_BC; AMBIG_PERMUTE; AMBIG_PERMUTE end;
       END; { of case KTYP }
  end; { procedure AMBIG_CONVERT_BACK }
  

begin { procedure ASS }
  WRITE('   ASS');
  IF AA+AB+AC >= 180 THEN
      begin VALID:=FALSE;
            WRITE('    input angle >= 180 ');
            EXIT(ASS)
      end;
  CASE KTYP OF { convert to ASS type: AA,SB,SA }
     52: ;                                    { AA,SB,SA }
     44: XCHG_BC;                             { AA,SC,SA }
     50: begin PERMUTE; PERMUTE; XCHG_BC end; { AB,SA,SB }
     26: begin PERMUTE; PERMUTE end;          { AB,SC,SB }
     41: PERMUTE;                             { AC,SA,SC }
     25: begin PERMUTE; XCHG_BC end;          { AC,SB,SC }
     END; { of case KTYP }
  TEST:=SB*SIN(AA*DTR);
  IF SA < TEST THEN
      begin
        VALID:=FALSE;
        WRITE(' NO triangle since side ');
        CASE KTYP OF
           44,52: WRITE('a');
           26,50: WRITE('b');
           25,41: WRITE('c');
           END; {of case KTYP }
        WRITE(' WILL NOT reach the opposite side');
        EXIT(ASS)
      end; { of if SA < TEST }
  IF (SA=TEST) THEN
      begin
        WRITE('    a RIGHT triangle');
        AB:=90;
        AC:=90-AA;
        SC:=SB*COS(AA*DTR)
      end;
  IF (SA >= SB) THEN
      begin
        WRITE('    one triangle');
        SINB:=SIN(AA*DTR)*SB/SA;
        COSB:=SQRT(1-SINB*SINB);
        AB:=ATAN(SINB/COSB)*RTD;
        AC:=180-AA-AB;
        SC:=SA*SIN(AC*DTR)/SIN(AA*DTR)
      end;
  IF (SA > TEST) and (SA < SB) THEN
      begin
        WRITE(' AMBIGUOUS CASE 1st solution');
        AMBIG:=TRUE;
        SINB:=SIN(AA*DTR)*SB/SA;
        COSB:=SQRT(1-SINB*SINB);
        AB:=ATAN(SINB/COSB)*RTD;
        AC:=180-AA-AB;
        SC:=SA*SIN(AC*DTR)/SIN(AA*DTR);
        AA2:=AA;
        SB2:=SB;
        SA2:=SA;
        AB2:=180-AB;
        AC2:=180-AA2-AB2;
        SC2:=SA2*SIN(AC2*DTR)/SIN(AA2*DTR)
      end;
  CONVERT_BACK;
  IF AMBIG THEN AMBIG_CONVERT_BACK;
end; { of procedure ASS }

PROCEDURE AAA;
begin
  WRITE('   AAA');
  IF AA+AB+AC <> 180 THEN
      begin
        VALID:=FALSE;
        WRITE('    NO triangle since then angle sum <> 180');
        EXIT(AAA)
      end;
  IF NOT USES_SSAAA THEN
    WRITE('    all solutions are SIMILAR to the following triangle');
  SA:=1;
  SB:=SA*SIN(AB*DTR)/SIN(AA*DTR);
  SC:=SA*SIN(AC*DTR)/SIN(AA*DTR)
end; { of procedure AAA }

PROCEDURE SAAA;
begin
  WRITE('   SAAA');
  IF AA+AB+AC <> 180 THEN
     begin
       VALID:=FALSE;
       WRITE('    angle sum <> 180');
       EXIT(SAAA)
     end;
  CASE KTYP OF { convert side S so that S = SA }
     15: PERMUTE;                    { S=SC }
     23: begin PERMUTE; PERMUTE end; { S=SB }
     39: ;                           { S=SA }
     END; { of case KTYP }
  SB:=SA*SIN(AB*DTR)/SIN(AA*DTR);
  SC:=SA*SIN(AC*DTR)/SIN(AA*DTR);
  CASE KTYP OF { restore labels }
     15: begin PERMUTE; PERMUTE end;
     23: PERMUTE;
     39: ;
     END; { of case KTYP }
end; { of procedure SAAA }
     
PROCEDURE SSAA;
begin
  WRITE('   SSAA');
  IF AA+AB+AC >= 180 THEN
    begin VALID:=FALSE;
          WRITE('   NO TRIANGLE since sum of the two input angles >= 180');
          EXIT(SSAA)
    end;
  CASE KTYP OF { compute 3rd angle }
    27,43,51: AA:=180-AB-AC;
    29,45,53: AB:=180-AA-AC;
    30,46,54: AC:=180-AA-AB;
    END; { of case KTYP }
  CASE KTYP OF { test for consistency; if so, compute 3rd side }
    27,29,30: IF APPROX(SIN(AB*DTR)/SB, SIN(AC*DTR)/SC)
                 then SA:=SB*SIN(AA*DTR)/SIN(AB*DTR)
                 else VALID:=FALSE;
    43,45,46: IF APPROX(SIN(AA*DTR)/SA, SIN(AC*DTR)/SC)
                 then SB:=SA*SIN(AB*DTR)/SIN(AA*DTR)
                 else VALID:=FALSE;
    51,53,54: IF APPROX(SIN(AA*DTR)/SA, SIN(AB*DTR)/SB)
                 then SC:=SA*SIN(AC*DTR)/SIN(AA*DTR)
                 else VALID:=FALSE;
    END; { of case KTYP }
  IF NOT VALID THEN WRITE('   NO TRIANGLE since input values inconsistent');
end; { of procedure SSAA }

PROCEDURE SSSA;
VAR ASAVE: real;
begin
  WRITE('   SSSA');
  ASAVE:=AA+AB+AC;
  SSS;
  IF VALID 
     then CASE KTYP OF { check for consistent input angle }
        57: VALID:=APPROX(AC,ASAVE);
        58: VALID:=APPROX(AB,ASAVE);
        60: VALID:=APPROX(AA,ASAVE);
        END; { of case KTYP }
  IF NOT VALID THEN WRITE('   NO TRIANGLE - inconsistent data');
end; { of procedure SSSA }

PROCEDURE SSAAA;
VAR SAX,SBX,SCX,RATIO: real;
begin
  WRITE('   SSAAA');
  USES_SSAAA:=TRUE;
  CASE KTYP OF { save sides for consistency comparison tests }
    31: begin SBX:=SB; SCX:=SC end;
    47: begin SAX:=SA; SCX:=SC end;
    55: begin SAX:=SA; SBX:=SB end;
    END; { of case KTYP }
  AAA;
  IF VALID
    then CASE KTYP OF
           31: VALID:=APPROX(SBX*SC,SCX*SB);
           47: VALID:=APPROX(SAX*SC,SCX*SA);
           55: VALID:=APPROX(SAX*SB,SBX*SA);
           END; { of case KTYP }
  IF VALID
    THEN begin CASE KTYP OF
                 31:    RATIO:=SBX/SB;
                 47,55: RATIO:=SAX/SA;
                 END;
               SA:=SA*RATIO; SB:=SB*RATIO; SC:=SC*RATIO
         end
    ELSE WRITE('   NO TRIANGLE - inconsistent data')
end; { of procedure SSAAA }

PROCEDURE SSSAA;
VAR AAX,ABX,ACX: REAL;
begin
  WRITE('   SSSAA');
  IF AA+AB+AC >= 180 THEN
    begin VALID:=FALSE;
          WRITE('   NO TRIANGLE - INPUT ANGLES >= 180');
          EXIT(SSSAA)
    end;
  CASE KTYP OF { save angles for consistency comparison test }
    59: begin ABX:=AB; ACX:=AC end;
    61: begin AAX:=AA; ACX:=AC end;
    62: begin AAX:=AA; ABX:=AB end;
    END; 
  SSS;
  IF VALID 
    then CASE KTYP OF
           59: VALID:=APPROX(ABX,AB) and APPROX(ACX,AC);
           61: VALID:=APPROX(AAX,AA) and APPROX(ACX,AC);
           62: VALID:=APPROX(AAX,AA) and APPROX(ABX,AB);
           END;
  IF NOT VALID THEN WRITE('   NO TRIANGLE - inconsistent data');
end; { of procedure SSSAA }

PROCEDURE SSSAAA;
VAR AAX,ABX,ACX: real;
begin
  WRITE('   SSSAAA');
  IF AA+AB+AC <> 180 THEN
     begin VALID:=FALSE;
           WRITE('   NO TRIANGLE since angle sum <> 180');
           EXIT(SSSAAA)
     end;
  AAX:=AA; ABX:=AB; ACX:=AC;
  SSS;
  VALID := APPROX(AA,AAX) and APPROX(AB,ABX) and APPROX(AC,ACX);
  IF NOT VALID THEN WRITE('   NO TRIANGLE - inconsistent data')
  end; { of procedure SSSAAA }

PROCEDURE ANALYZE;
BEGIN
  KTYP:=0;
  IF AC > 0 THEN KTYP:=KTYP + 1 ;
  IF AB > 0 THEN KTYP:=KTYP + 2 ;
  IF AA > 0 THEN KTYP:=KTYP + 4 ;
  IF SC > 0 THEN KTYP:=KTYP + 8 ;
  IF SB > 0 THEN KTYP:=KTYP +16 ;
  IF SA > 0 THEN KTYP:=KTYP +32 ;
  VALID := TRUE;
  AMBIG := FALSE;
  LABEL2:=FALSE;
  USES_SSAAA:=FALSE;
  CASE KTYP OF
    56:                 SSS;
    28,42,49:           SAS;
    14,21,35:           ASA;
    11,13,19,22,37,38:  SAA;
    25,26,41,44,50,52:  ASS;
    7:                  AAA;
    0,1,2,3,4,5,6,8,9,
    10,12,16,17,18,20,
    24,32,33,34,36,40,
    48: BEGIN
          VALID:=FALSE;
          WRITE('   INSUFFICIENT DATA TO MAKE A TRIANGLE')
        END;
    15,23,39:          SAAA;
    27,29,30,43,45,46,
    51,53,54:          SSAA;
    57,58,60:          SSSA;
    31,47,55:         SSAAA;
    59,61,62:         SSSAA;
    63:              SSSAAA;
    END; { case KTYP }
END; { procedure ANALYZE }
    
PROCEDURE LABEL_TRIANGLE(XA,YA,XB,YB,XC,YC:INTEGER);
VAR X,Y:         INTEGER;
    ANG,SIDE,A,PER: REAL;
BEGIN
  X:=XA DIV 4 - 5;
  Y:=YA DIV 10;
  IF LABEL2 THEN Y:=Y+1;
  IF LABEL2 THEN ANG:=AA2 ELSE ANG:=AA;
  GOTOXY(X,Y); WRITE('A= ',ANG:5:1);
  X:=((XA+XB) DIV 2) DIV 4 -5;
  Y:=Y-1;
  IF LABEL2 THEN SIDE:=SC2 ELSE SIDE:=SC;
  GOTOXY(X,Y); WRITE('c= ',SIDE:5:1);
  X:=XB DIV 4 -2;
  Y:=Y+1;
  IF LABEL2 THEN ANG:=AB2 ELSE ANG:=AB;
  GOTOXY(X,Y); WRITE('B= ',ANG:5:1);
  X:=((XB+XC) DIV 2) DIV 4 -1;
  Y:=((YB+YC) DIV 2) DIV 10;
  IF LABEL2 THEN Y:=Y+1;
  IF LABEL2 THEN SIDE:=SA2 ELSE SIDE:=SA;
  GOTOXY(X,Y); WRITE('a= ',SIDE:5:1);
  X:=XC DIV 4 -5;
  Y:=YC DIV 10;
  IF LABEL2 THEN Y:=Y+1;
  IF LABEL2 THEN ANG:=AC2 ELSE ANG:=AC;
  GOTOXY(X,Y); WRITE('C= ',ANG:5:1);
  X:=((XA+XC) DIV 2) DIV 4 -5;
  Y:=((YA+YC) DIV 2) DIV 10 -1;
  IF LABEL2 THEN Y:=Y+1;
  IF LABEL2 THEN SIDE:=SB2 ELSE SIDE:=SB;
  GOTOXY(X,Y); WRITE('b= ',SIDE:5:1);
  IF LABEL2 THEN X:=42 ELSE X:=3;
  IF LABEL2 THEN A:=SC2*SB2*SIN(AA2*DTR)/2 ELSE A:=SC*SB*SIN(AA*DTR)/2;
  IF LABEL2 THEN PER:=SA2+SB2+SC2  ELSE PER:=SA+SB+SC;
  GOTOXY(X,7);
  WRITE('AREA=',A:8:3,'  PERIMETER=',PER:8:3)
END; { procedure LABEL_TRIANGLE }
  
PROCEDURE DISPLAY;
var WIDE: boolean;
    AX,AY,BX,BY,CX,CY,   { (x,y) coordinates }
    AX2,AY2,BX2,BY2,CX2,CY2, { 2nd triangle }
    XLEFT,YBOT,YDIF:  integer;
    H,H2,W,W2,
    XC,XC2,XL,XL2,XR,XR2,
    WMAX,HMAX,SCALE:     real;
begin
  GOTOXY(0,5);
  WRITELN('  a=',SA:8:3,'  b=',SB:8:3,'  c=',SC:8:3);
  WRITELN('  A=',AA:8:3,'  B=',AB:8:3,'  C=',AC:8:3);
  XLEFT:=41; YBOT:=200; { SW corner of rect for triangle display }
  YDIF:=1;     { downward vertical (dot) displacement for 2nd triangle }
  WMAX:=240; HMAX:=120; { max width and height of triangle (units=dots) }
  H:=SB*SIN(AA*DTR);    { H is triangle height }
  XC:=SB*COS(AA*DTR);
  IF XC < 0 THEN XL:=XC ELSE XL:=0;
  IF XC > SC THEN XR:=XC ELSE XR:=SC;
  W:=XR-XL;
  IF AMBIG THEN  { adjust H and W so rect contains both triangles }
       begin
         H2:=SB2*SIN(AA2*DTR);
         IF H2>H THEN H:=H2;
         XC2:=SB2*COS(AA2*DTR);
         IF XC2 < XL THEN XL:=XC2;
         IF XC2 > XR THEN XR:=XC2;
         IF SC2 > XR THEN XR:=SC2;
         W:=XR-XL;
       end; { if AMBIG }
  IF W/H >= WMAX/HMAX THEN WIDE:=true ELSE WIDE:=false;
  IF WIDE THEN SCALE:=WMAX/W ELSE SCALE:=HMAX/H;
  { the following code assigns x,y dot values to the triangle vertices }
  AY:=YBOT;
  BY:=YBOT;
  IF XC >= 0 THEN AX:=XLEFT
             ELSE AX:=XLEFT-ROUND(XC*SCALE);
  if AMBIG and (XC2 < XC) and (XC2 < 0) then AX:=XLEFT-ROUND(XC2*SCALE);
  BX:=AX+ROUND(SC*SCALE);
  CX:=AX+ROUND(XC*SCALE);
  CY:=YBOT-ROUND(H*SCALE);
  DRAWLINE(R,S,20,AX,AY,BX-AX,BY-AY,1);
  DRAWLINE(R,S,20,BX,BY,CX-BX,CY-BY,1);
  DRAWLINE(R,S,20,CX,CY,AX-CX,AY-CY,1);
  LABEL_TRIANGLE(AX,AY,BX,BY,CX,CY);
  IF AMBIG THEN
      begin
        LABEL2:=TRUE;
        AY2:=YBOT+YDIF;
        BY2:=YBOT+YDIF;
        AX2:=AX;
        BX2:=AX2+ROUND(SC2*SCALE);
        CY2:=YBOT+YDIF-ROUND(H2*SCALE);
        CX2:=AX2+ROUND(XC2*SCALE);
        GOTOXY(50,4); WRITE('2nd solution');
        GOTOXY(41,5); WRITE('a=',SA2:8:3,'  b=',SB2:8:3,'  c=',SC2:8:3);
        GOTOXY(41,6); WRITE('A=',AA2:8:3,'  B=',AB2:8:3,'  C=',AC2:8:3);
        DRAWLINE(R,S,20,AX2,AY2,BX2-AX2,BY2-AY2,1);
        DRAWLINE(R,S,20,BX2,BY2,CX2-BX2,CY2-BY2,1);
        DRAWLINE(R,S,20,CX2,CY2,AX2-CX2,AY2-CY2,1);
        LABEL_TRIANGLE(AX2,AY2,BX2,BY2,CX2,CY2);
      end { of if AMBIG }
end; { of procedure DISPLAY }
    
begin { main program TRIANGLE }
  REPEAT
    DATA_IN;
    ANALYZE;
    IF VALID THEN DISPLAY
  UNTIL FALSE;
end. { of main program TRIANGLE}

========================================================================================
DOCUMENT :usus Folder:VOL22:vol22.doc.text
========================================================================================

                             USUS Library Volume 22

               Graphics Programs for the Terak (LSI-11) Computer

GRAPH.DOC.TEXT    40  Documentation for units and programs on this disk
POST.DOC.TEXT     24  Documentation for POST_ENTRY.TEXT
REAL_INPUT.TEXT    8  Unit to input real numbers from the console
REVIEW.TEXT       14  Unit to facilitate running these programs with
                        a "dumb" Hiplot plotter instead of the Terak
POST_ENTRY.TEXT   28  Unit to input functions from the console or a file
                        and to evaluate these functions
SCRN_STUFF.TEXT    8  Screen control unit for these programs
PLOTTER.TEXT      16  Unit to drive "dumb" Hiplot plotter
GRAPHICS.TEXT     28  Fundamental graphics unit for both Terak screen
                        and "dumb" Hiplot plotter
FACT_STUFF.TEXT   14  Math unit for factorial, log factorial, and
                        related calculations
FUNC.TEXT         24  Plot functions entered from console
POLAR.TEXT        22  Plot polar functions entered from console
DISTRIB.TEXT      24  Calculate and plot normal, Poisson, and binomial
                        distributions
SINES.TEXT        14  Plot sine functions of various types
HISTOGRAM.TEXT    20  Plot histograms using data from file or console
HISTOGRAM.DATA     2  Sample data file for the above
CURVE_FIT.TEXT    28  Polynomial curve fitting and plotting
CONTOUR.TEXT      28  Plot contours of 3-dimensional surfaces
TRIANGLE.TEXT     40  Constructs triangle with minimum input and plots result
TRAVERSE.TEXT     42  A calculating and plotting program for surveyors
IVP.TEXT          42  "Solves" differential equations by Euler and 4th order
                        Runge-Kutta techniques and plots solution
VOL22.DOC.TEXT     8  You're reading it
__________________________________________________________________________

Please transfer the text below to a disk label if you copy this volume.

    USUS Volume 22 -***- USUS Software Library
                         
   For not-for-profit use by USUS members only.
  May be used and distributed only according to 
      stated policy and the author's wishes.



This volume was assembled by Henry Baumgarten from material collected by
the Library committee.

__________________________________________________________________________





========================================================================================
DOCUMENT :usus Folder:VOL23:df.docum.text
========================================================================================

                DF   Directory-File utility

          The Directory-File utility displays a volume
directory on a crt screen.  The operator can select a file
with the cursor and perform functions from a menu with the
selected file name.  Menu selected options include
modification or removal of a file name, moving a file to
another volume, entering the SYSTEM.EDITOR, and execution
of a code file or initiation of a script file. 

Operation of the Directory-File utility

          DF is called into operation by executing the file /DF. 
The utility will clear the screen and request
identification of the volume whose directory is to be
displayed.

Example:
          
   Enter volume id of disk(<ESC>,<RETURN> to end) [prefix]=>

Possible entries in responce to this prompt are:

1)        Press the keys labeled <ESC> and <RETURN>.  The utility
          will relenquish control to the operating system.
          
2)        Press the key labeled <RETURN>.  The utility will use
          the volume identification displayed inside the square
          brackets.
          
3)        Input a number followed by the <RETURN> key.  The number
          must identify a device which contains a blocked volume.  
          (note: this volume identification will become the default
          volume in square brackets.)
          
4)        Input a volume identification as defined by the PASCAL
          operating system.  The volume identification may be a
          volume name, a device name or a device number (prefixed
          with a # character).  (note: this volume identification
          will become the default volume in square brackets.)
          
With the entry of a volume identification, the utility will
display the file names from the directory in order of
occurrence.  The screen will contain a menu line, the
volume name, up to twenty rows in four columns of file
names, the number of files defined, and the number of
blocks available in the largest contiguous area.  Sharing
the line with the volume name is the extended directory
information for the file pointed to by the cursor.  This
includes the file name, block length, last modification
date, starting block address, number of bytes in the last
block of the file, and the file type.

          The first line of the screen display is a menu list of
the functions available.  Additional functions are
displayed on entry of a ?.  The cursor will be on the
first character of the first file.  Selection of the file
to be affected by a function is made with the cursor.




          Every option is selectable by entering the first
character of the option name or the special key indicated
in angular brackets. ( i.e. <ENTER> means the key with
the word ENTER engraved on it.)

1 <arrows>

          The arrow keys move the cursor one file name in the
          direction indicated by the arrow on the key pressed.  The
          cursor will be positioned on the first character of the
          file name except when a Change operation is in progress.
          
          The left arrow key will move the cursor one column of
          file names to the left. When in the leftmost column, the
          cursor will be moved to the rightmost column.
          
          The right arrow key or the tab key will move the cursor
          one column of file names to the right.  When in the
          rightmost column, the cursor will be moved to the leftmost
          column.
          
          The up arrow key will move the cursor up one row in the
          same column.  When on the top row, the cursor will be moved
          to the bottom row in the same column.
          
          The down arrow key will move the cursor down one row in
          the same column.  When on the bottom row, the cursor will
          be moved to the top row in the same column.
          
          The home key will position the cursor on the upper left
          file name. (i.e. column one, row one)
          
          The <RETURN> key will move the cursor down one row in
          the same column.  When on the bottom row, the cursor will
          be moved to the top row in the next column to the right. 
          When on the last row of the rightmost column, the cursor
          will be moved to the first row of the leftmost column.
          
2  Remove

          Entering the R key marks the file name at the cursor
          position for removal from the directory.  The file will not
          be removed until the user exits using the <ENTER>,
          <ESC> or Quit commands.  Directory statistics for the
          number of files and blocks available are updated as if the
          file had been removed.  This allows the user to perform
          trial removes without disturbing the volume directory until
          satisfied with the results of the removal.
          
3  Change

          Entering a C key initiates a file name change.  Change
          allows the user to modify the file name at the cursor
          position.  Left and right arrow keys move the cursor across
          the file name field without disturbing the file name,
          character keys will replace the character at the cursor
          position, <ENTER> or <RETURN> accepts the modified
          name, and the <ESC> key aborts the change and restores
          the original file name.  Spaces internal to the file name
          are ignored and may be used to remove unwanted characters.
          
4  Undo

          Entering a U key restores the file name at the cursor
          position to the original name from the volume directory if
          changed, removed, or moved.  If the file has been moved,
          then only the displayed name is changed and the file on the
          destination volume is not disturbed.
          
5  Move

          Entering the M key moves the file at the cursor
          position to the destination volume.  If the destination
          volume has not been specified, then a request for the
          destination volume identification will be made.  The
          destination volume directory is searched for the file name
          and the user notified if the file name exists on the
          directory.
          
    THE.FILE is on destination volume, remove the old version?(Y/N)


          If the user enters a <Y>, the existing file on the
          destination will be removed and the file from the source
          will be copied to the destination.  If the entry is an
          <N>, the destination volume directory is not disturbed
          and no move takes place.  Unlike other functions, the move
          command is an immediate operation and the file will be
          moved before continuing.
          
6  Get

          Entering the G key initiates the entry of a new
          destination volume identification.  On entry of the volume
          identification, the new name becomes the destination
          volume.
          
7  Edit

          Entering the E key will call the system editor with
          the file name pointed to by the cursor.  
          
          If any file is marked for removal or a file name has
          been changed, then the utility will request verification of
          the changes with the prompt:
          
               Update the directory? (Yes/No/Return)
          
          The response to this prompt must be a <Y>, <N> or <R>
          - all other keys are ignored.  A <Y> response will cause
          the updated directory to be written to the blocked volume
          replacing the original directory.  An <N> response
          prevents the replacement of the orginal directory, and all
          modifications are ineffective.  An <R> response will
          return to the present directory display. After <Y> or
          <N> is entered, DF will call for the system editor with
          the file name at the cursor.
          
8  eXecute

          Entering the X key will execute a code file or
          redirect input from a script file.  When the cursor points
          to a file of type code and the X key is entered, the
          program in the code file will be executed.  When the cursor
          points to a file which is not of type code and the X key
          is entered, the file will be considered to be a script file
          and input will be redirected from the file.
          
          If any file is marked for removal or a file name has
          been changed, then the utility will request verification of
          the changes with the prompt:
          
               Update the directory? (Yes/No/Return)
               
          The response to this prompt must be a <Y>, <N> or <R>
          - all other keys are ignored.  A <Y> response will cause
          the updated directory to be written to the blocked volume
          replacing the original directory.  An <N> response
          prevents the replacement of the orginal directory, and all
          modifications are ineffective.  An <R> response will
          return to the present directory display. After <Y> or
          <N> is entered, DF will continue with the execute
          option.
          
 9  <ENTER>
10  <ESC>

          The <ENTER> and <ESC> keys exit the directory display,
          prompt for update of the disk directory, and prompt for a
          new volume identification.
          
          If any file is marked for removal or a file name has
          been changed, then the utility will request verification of
          the changes with the prompt:
          
               Update the directory? (Yes/No/Return)
               
          The response to this prompt must be a <Y>, <N> or <R>
          - all other keys are ignored.  A <Y> response will cause
          the updated directory to be written to the blocked volume
          replacing the original directory.  An <N> response
          prevents the replacement of the orginal directory, and all
          modifications are ineffective.  An <R> response will
          return to the present directory display. After <Y> or
          <N> is entered, the prompt for a volume identification
          will be presented.
          
          
11  Quit

          Entering the Q key will prompt for update of the
          directory and return to the PASCAL system.
          
          If any file is marked for removal or a file name has
          been changed, then the utility will request verification of
          the changes with the prompt:
          
               Update the directory? (Yes/No/Return)
          
          The response to this prompt must be a <Y>, <N> or <R>
          - all other keys are ignored.  A <Y> response will cause
          the updated directory to be written to the blocked volume
          replacing the original directory.  An <N> response
          prevents the replacement of the orginal directory, and all
          modifications are ineffective.  An <R> response returns
          to the present directory display. After <Y> or <N> is
          entered, DF will exit to the PASCAL system.
          
12  Help

          Entering the H key initiates a sequence of single line
          descriptions for the options available to the user.  The
          user is prompted to press the <RETURN> key to continue for
          each line displayed.
          
13  Output

          Entering the O key moves the volume directory display
          to a file or device specified by the user in response to
          the prompt:
          
               Enter the output file name :
               
14  Natural order

          Entering the N key for natural order will cause the
          directory file display to be presented in the order of
          occurrence on the disk.
          
15  Sorted order

          Entering the S key for sorted order will cause the
          directory file display to be presented in alphanumeric
          order by file name.
          
16  Logical order

          Entering the L key for logical order will cause the
          directory file display to be presented in alphanumeric
          order by the four character file suffix first and then by
          the file name.
          
17  Verify

          Entering the V key for verify will cause the directory
          file display to be rewritten.
          
18  Advance

          The A key invokes a directory display function which,
          if the cursor is pointing to a subsidirary volume, will
          advance to the subsidirary whether the volume is mounted or
          not.  This allows an unmounted subsidirary volume to be
          displayed and files to be extracted or deleted without
          requiring the user to mount the volume.
          
19  Formfeed

          Entering an F, when the destination is the printer,
          will emit a formfeed character to the printer.  Useful when
          outputing multiple text files to the printer from DF.
          
          
          
          
          
          
          
          
          
            

========================================================================================
DOCUMENT :usus Folder:VOL23:df.iv.0.text
========================================================================================

vid(j);
     end
    ELSE
      BEGIN             { not unit number - try volume names }
        
        LCTOUC ( volstr ); { ensure all upper case alphabetic chars }
        
        j := 0;
        
        REPEAT  { look for the volume name in the unit table }
          j := j + 1;
          if volstr=syscom^.unitable^[j].uvid then  { match to old name }
            IF syscom^.UNITABLE^[J].UISBLKD THEN read_vid(j) ; { blk vol }
        UNTIL (volstr = syscom^.UNITABLE^[j].UVID)OR( j >= MAXUNIT );


        IF volstr = syscom^.UNITABLE^[j].UVID THEN unum := j {name is true }
        ELSE
          BEGIN    { retry all blocked volumes reading volume name }
            J := 0;
            REPEAT
              J := J+1;
              IF syscom^.UNITABLE^[J].UISBLKD THEN read_vid(j);
            UNTIL (J>=MAXUNIT)OR (volstr=syscom^.unitable^[j].uvid);
            IF volstr = syscom^.unitable^[J].UVID THEN unum := J;
          END;
   end;
   get_unit_number := unum ;
   
end;
{$P }
FUNCTION  GOOD_TARGET:BOOLEAN;


VAR
   OK        : BOOLEAN ;
   ABORT     : BOOLEAN ;
   I         : INTEGER ;


BEGIN
OK := TRUE ; ABORT := FALSE ; THE_SAME := FALSE ;
repeat 
IF NOT TARGET_KNOWN THEN
REPEAT
    GOTOXY(0,0); WRITE('Enter volume id of destination disk > ',
                        syscom^.crtctrl.eraseeol );
    NEWPROMPT := TRUE;
    READLN(TNAME);
    IF TNAME = '' THEN ABORT := TRUE
      ELSE IF tname[length(tname)]=syscom^.crtinfo.altmode then ABORT := TRUE ;
    IF NOT ABORT THEN 
      begin
         tar_unit := get_unit_number( tname );
         tname :=concat( syscom^.unitable^[tar_unit].uvid, ':' );
         if not(syscom^.unitable^[tar_unit].uisblkd) 
         THEN 
         begin
           unitclear(tar_unit);
           dest_is_text := TRUE;
         end  
         else
         BEGIN
           DEST_IS_TEXT := FALSE;
           {$I-}
           unitread(tar_unit,targetdir,(maxdir+1)*sizeof(dir_entry),2,0);
           {$I+}
           OK := IORESULT = 0;
           IF NOT OK THEN DISK_ERROR(TNAME)
           else
           BEGIN
              IF TARGETDIR[0].DLASTBLK > 255 THEN 
              BEGIN
                 TARFLIP := TRUE ;
                 FLIPDIR(TARGETDIR);
              END
              ELSE TARFLIP := FALSE ;
           
              with targetdir[0] do
              if ( length(dvid)<=0 ) or
                 ( length(dvid)> 7 ) or
                 ( dnumfiles   < 0 ) or
                 ( dnumfiles   > 77) or
                 ( dfkind <> untypedfile ) then
              begin
                 gotoxy(0,0);
                 write('No directory on volume for ',TNAME,
                       ': < press return >',syscom^.crtctrl.eraseeol);
                 read(ch);
                 ok := false ;
              end
              else
              IF dispdir[0].DVID = TARGETDIR[0].DVID THEN
              BEGIN
                 gotoxy(0,0);
                 write('Destination is not allowed to be the same as source.',
                       '   <press return>',syscom^.crtctrl.eraseeol);
                 read(ch);
                 OK := FALSE;
              end;
           END;
        END;
      END;
  UNTIL OK OR ABORT
  ELSE
  BEGIN
     IF NOT dest_is_text then
     BEGIN
       {$I-}
           unitread(tar_unit,targetdir,(maxdir+1)*sizeof(dir_entry),2,0);
       {$I+}
       OK := IORESULT = 0;
       IF NOT OK THEN DISK_ERROR(TNAME)
       else
           with dispdir[0] do 
           if ( length(dvid)<=0 ) or
              ( length(dvid)> 7 ) or
              ( dnumfiles   < 0 ) or
              ( dnumfiles   > 77) or
              ( dfkind <> untypedfile ) then  ok := false 
           else
           IF copy(TNAME,1,length(tname)-1) <> TARGETDIR[0].DVID THEN
           BEGIN
              repeat
                 GOTOXY(0,0);
                 WRITE('Old destination was ',TNAME,
                       ', new destination is ',targetdir[0].dvid,
                       '  Ok to use new destination? (Y/N) ',
                        syscom^.crtctrl.eraseeol);
                 read(ch);
              until (ch='N') or (ch='n') or (ch='Y') or (ch='y');
              ok := (ch='y') or (ch='Y');
           end;
  
     END;
     target_known := ok;

  END;

  UNTIL OK OR ABORT ;
  
  TARGET_KNOWN := NOT ABORT ;
  GOOD_TARGET := NOT ABORT ;
  gotoxy(50,23);
  IF TARGET_KNOWN THEN write('Destination is ',TNAME );
  
  END;
  
{$P }
FUNCTION UNIQUE_TARG( ST : STRING ) : BOOLEAN ;

VAR
   MATCH      : BOOLEAN ;
   CH         : CHAR;
   I          : INTEGER ;
   NFILES   : INTEGER ;
   

BEGIN
   CH := 'Y'; { INITIALIZE CHARACTER TO CAUSE TRUE RETURN }
   NFILES := TARGETDIR[0].DNUMFILES ;
   I := 0;
   MATCH := FALSE ;
   IF NFILES > 0 THEN 
   REPEAT 
      I := I+1;
      MATCH := ST = TARGETDIR[I].DTID ;
   UNTIL MATCH OR ( I>= NFILES );
   IF MATCH THEN
   BEGIN
      GOTOXY(0,0);
      WRITE(ST, ' is on destination disk, Remove the old version? (Y/N) ',
            syscom^.crtctrl.eraseeol);
      NEWPROMPT := TRUE ; { RESTORE THE PROMPT LINE ON RETURN }

      REPEAT READ(KEYBOARD,CH)
      UNTIL (CH='Y')OR(CH='y')or(CH='N')OR(CH='n')
                    OR(CH=syscom^.crtinfo.altmode);

      IF (CH='Y')OR(CH='y') then
      BEGIN
         targetdir[0].dnumfiles := nfiles - 1 ;
         IF I < NFILES THEN 
         repeat
            targetdir[i] := targetdir[i+1];
            i:= i+1;
         until i >= nfiles ;
      END;
   END;
GOTOXY( (COL-1)*20,Y_BASE+ROW-1); { PLACE THE CURSOR }
UNIQUE_TARG := ((CH='Y')OR(CH='y'));
END;

{$P }
function  room_on_target( VAR DIR      : psysdir  ;
                              REQUEST  : INTEGER; 
                          VAR DIRREC   : INTEGER; 
                          var totalblks: integer;
                          var largest  : integer ):BOOLEAN ;

var 
   nextlow  : integer ;
   last     : integer ;
   size     : integer ;
   
   
begin
{   FIND THE LARGEST SET OF CONTIGUOUS BLOCKS }
   
   LARGEST := 0;
   totalblks := 0;
   NEXTLOW := DIR[0].DNUMFILES + 1;
   LAST    := DIR[0].DEOVBLK ;
   REPEAT 
      NEXTLOW := NEXTLOW -1 ; 
      SIZE := LAST - DIR[ NEXTLOW ].DLASTBLK ;
      totalblks := totalblks + size ;
      IF SIZE > LARGEST THEN 
      BEGIN
         DIRREC := NEXTLOW+1 ; {  ENTRY POSITION FOR LARGEST SPACE }
         LARGEST := SIZE ;
      END;
      LAST := DIR[ NEXTLOW ].DFIRSTBLK ;
   UNTIL NEXTLOW <= 0 ;
   ROOM_ON_TARGET := REQUEST <= LARGEST ;
   
END; 



PROCEDURE MOVE_MESSAGE( WDSIZE: INTEGER ) ;

BEGIN
      {******}
      GOTOXY(50,22);
      WRITE('Move buffer is ', WDSIZE ,' blocks.',
                syscom^.crtctrl.eraseeol );
      {******}
   
      GOTOXY(0,0);
      WRITE('One moment please, move in progress.  ',syscom^.crtctrl.eraseeol);
      
      NEWPROMPT := TRUE;
      
END;

{$P }
PROCEDURE MOVE_FILE( DIRPOS:INTEGER ) ;



VAR
   error    : boolean ;
   totalblks: integer ;
   largest  : integer ;
   SIZE     : INTEGER ;
   SOURCE   : INTEGER ;
   DEST     : INTEGER ;
   TEMP     : INTEGER ;
   I        : INTEGER ;
   DIRREC   : INTEGER ;
   BLOCKS   :^integer ; { pointer to memory }
   movblksiz : integer; { size of the move buffer in blocks  }
   
  { MOVE_FILE }
   
BEGIN
i:= varavail( 'DFILE,SCREENOPS,FILEOPS,CALC' );
movblksiz := ( i div 256 - 1 );
if movblksiz > 63 then movblksiz := 63 ; { limit size to less than 32767 }
i := varnew ( blocks,movblksiz*256 ) ;
if i = 0 then 
begin 
  pressreturn(' No room for move buffer ');
  exit(move_file);
end;


SIZE := dispdir[DIRPOS].DLASTBLK-dispdir[DIRPOS].DFIRSTBLK ;
IF GOOD_TARGET THEN 
IF NOT DEST_IS_TEXT THEN
BEGIN

 IF UNIQUE_TARG( dispdir[DIRPOS].DTID ) THEN
  IF TARGETDIR[0].DNUMFILES < MAXDIR THEN
  BEGIN 
   IF ROOM_ON_TARGET( TARGETDIR, SIZE, DIRREC ,totalblks, largest ) THEN
   BEGIN
      MOVE_MESSAGE( MOVBLKSIZ );
      { OPEN THE DIRECTORY OF THE TARGET VOLUME FOR NEW ENTRY }
      I := TARGETDIR[0].DNUMFILES + 1;
      REPEAT
         TARGETDIR[I] := TARGETDIR[I-1];
         I := I-1;
      UNTIL I <= DIRREC ;
      
      { MOVE THE DIRECTORY ENTRY TO THE TARGET }
      TARGETDIR[DIRREC] := dispdir[DIRPOS];
      
      { SET THE STARTING BLOCK NUMBER FOR THE FILE ON THE TARGET VOLUME }
      TARGETDIR[DIRREC].DFIRSTBLK := TARGETDIR[DIRREC-1].DLASTBLK ;
      
      { SET THE ENDING BLOCK NUMBER FOR THE FILE ON THE TARGET VOLUME }
      TARGETDIR[DIRREC].DLASTBLK := TARGETDIR[DIRREC].DFIRSTBLK + SIZE ;
      
      { INCREASE THE NUMBER OF FILES ON THE TARGET VOLUME }
      TARGETDIR[0].DNUMFILES := TARGETDIR[0].DNUMFILES + 1;
      
      
      { MOVE THE FILE TO THE TARGET VOLUME }
      SOURCE := dispdir[DIRPOS].DFIRSTBLK;
      DEST   := TARGETDIR[DIRREC].DFIRSTBLK;
      REPEAT
         TEMP := dispdir[DIRPOS].DLASTBLK-SOURCE;
         IF TEMP > movblksiz THEN TEMP := movblksiz;
         {$I- }
           unitread(dir_unit,blocks^,temp*512,source+dir_offs,0);
         {#I+ }
         error := ioresult <> 0;
         IF not error THEN
         BEGIN
            IF TARFLIP THEN FLIPDIR(TARGETDIR);
            TARFLIP := FALSE;
            SOURCE := SOURCE + TEMP;
            {$I- }
              unitwrite(tar_unit,blocks^,temp*512,dest,0);
            {$I+ }
            error := ioresult <> 0;
            IF not error THEN  DEST := DEST + TEMP
              ELSE DISK_ERROR(CONCAT( TNAME,':',dispdir[DIRPOS].DTID ) );
         END
         ELSE DISK_ERROR( CONCAT(INAME,':',dispdir[DIRPOS].DTID) );
         WRITE('.');
      UNTIL (SOURCE = dispdir[DIRPOS].DLASTBLK) OR error ;
      IF not error THEN
      begin
         {$I- }
           unitwrite(tar_unit,targetdir,(maxdir+1)*sizeof(dir_entry),2,0);
         {$I+ }
         GOTOXY( (COL-1)*20,Y_BASE+ROW-1); { PLACE THE CURSOR }
         dir_status[dirpos].moved := true;
         with_write( dirpos );
      end;
   END
   ELSE
   BEGIN
      GOTOXY(0,0);
      WRITE( dispdir[dirpos].dtid,
       ' is ',size,' blocks.  ',largest,' contig. ',totalblks,' total avail.',
       ' <press return>',syscom^.crtctrl.eraseeol);
      read(ch);
      newprompt := true;
   end;
 end
 else
 begin
    gotoxy(0,0);
    write( TARGETDIR[0].DVID,
           ' volume directory is full. <press return>',
           syscom^.crtctrl.eraseeol);
    read(ch);
    newprompt := true;
 end;

END
ELSE
BEGIN { OUTPUT DEVICE IS FOR TEXT }
   IF dispdir[DIRPOS].DFKIND = TEXTFILE THEN
   BEGIN
      IF tar_unit = 1
           THEN WRITE(syscom^.crtctrl.clearscreen);
      GOTOXY(0,0);
      WRITE('Output of ',dispdir[dirpos].dtid,
            ' to ',TNAME,' in progress.',syscom^.crtctrl.eraseeol);
      IF tar_unit = 1  THEN WRITELN;
      newprompt := true;
      { MOVE THE FILE TO THE TARGET VOLUME }
      SOURCE := dispdir[DIRPOS].DFIRSTBLK+2;
      REPEAT
         TEMP := dispdir[DIRPOS].DLASTBLK-SOURCE;
         IF TEMP > MOVBLKSIZ THEN TEMP := MOVBLKSIZ;
         {$I- }
            unitread(dir_unit,blocks^,temp*512,source+dir_offs,0);
         {#I+ }
         error := ioresult <> 0;
         IF not error THEN
         BEGIN
            SOURCE := SOURCE + TEMP;
            {$I- }
              unitwrite(tar_unit,blocks^,temp*512,dest,0);
            {$I+ }
            error := ioresult <> 0;
            IF not error THEN  DEST := DEST + TEMP
              ELSE DISK_ERROR(CONCAT( TNAME,dispdir[DIRPOS].DTID ) );
         END
         ELSE DISK_ERROR( CONCAT(INAME,dispdir[DIRPOS].DTID) );
         WRITE('.');
      UNTIL (SOURCE = dispdir[DIRPOS].DLASTBLK) OR error ;
      GOTOXY( (COL-1)*20,Y_BASE+ROW-1); { PLACE THE CURSOR }
      dir_status[dirpos].moved := true;
      if not (tar_unit = 1) then with_write( dirpos );
   END
   else pressreturn('File type is not text');

   IF tar_unit = 1  THEN
   BEGIN
     PRINTENTRIES;
     GOTOXY(50,23);
     WRITE('Destination is CONSOLE:');
   END;


END;
VARDISPOSE( BLOCKS,MOVBLKSIZ*256); { RELEASE MOVE BUFFER }
END;

{$P }
PROCEDURE GET;

BEGIN
   TARGET_KNOWN := FALSE;
   GOTOXY(50,23); WRITE(syscom^.crtctrl.eraseeol);
   IF GOOD_TARGET THEN { DUMMY IF TO CARRY THE FUNCTION CALL TO GOOD_TARGET };

end;

{$P }
PROCEDURE CHANGE_FILE( CU:CHAR ; J:INTEGER );


VAR
   CH        : CHAR ;
   ST        : STRING[15];
   
   
   
FUNCTION UNIQUE_FILE : BOOLEAN ;

VAR
   MATCH      : BOOLEAN ;
   CH         : CHAR;
   NROW,NCOL  : INTEGER ;
   

BEGIN
   CH := 'Y'; { INITIALIZE TO CHARACTER TO CAUSE TRUE RETURN }
   I := dispdir[0].DNUMFILES + 1;
   MATCH := FALSE ;
   IF I > 0 THEN
   REPEAT  
      I := I-1; 
      IF (J <> INDEX[I])AND(not dir_status[INDEX[I]].removed) 
       THEN MATCH := ST = dispdir[INDEX[I]].DTID ;
   UNTIL MATCH OR ( I<=1 );
   IF MATCH THEN
   BEGIN
      NCOL := 5 ;
      REPEAT NCOL := NCOL - 1 UNTIL I > TOTALTOCOL[NCOL];
      NROW := I - TOTALTOCOL[NCOL];
      GOTOXY((NCOL-1)*20,Y_BASE+NROW-1);
      dir_status[index[i]].removed := true ;
      with_write( index[i] );
      dir_status[index[i]].removed := false;
      GOTOXY(0,0);
      WRITE('Remove the old version? (Y/N)',syscom^.crtctrl.eraseeol);
      NEWPROMPT := TRUE ; { RESTORE THE PROMPT LINE ON RETURN }
      GOTOXY((NCOL-1)*20,Y_BASE+NROW-1);

      REPEAT READ(KEYBOARD,CH)
      UNTIL (CH='Y')OR(CH='y')or(CH='N')OR(CH='n')
                    OR(CH=syscom^.crtinfo.altmode);

      IF (CH='Y')OR(CH='y') then
      BEGIN
         NUMFILES := NUMFILES -1;
         dir_status[index[i]].removed := true ;
         CALC;
         PRINTSTATS;
      END
      ELSE
      WITH_WRITE( index[i] );
       
  END;
GOTOXY( (COL-1)*20,Y_BASE+ROW-1); { PLACE THE CURSOR }
UNIQUE_FILE := ((CH='Y')OR(CH='y'));
END;
{$P }
    
    { CHANGE_FILE }
    
 BEGIN
   CASE CU OF 
    
   'C','c':BEGIN
      IF dir_status[j].removed then
      begin
        newprompt := true;
        pressreturn('cannot change a removed file name ');
      end
      else
      begin
   
      ST := dispdir[J].DTID;
      IF (( LENGTH(ST)>5)AND(LENGTH(ST)<15)) THEN
         IF ST[LENGTH(ST)-4] = '.' THEN
           WHILE LENGTH(ST)<15 DO INSERT ( ' ',ST,LENGTH(ST)-4);
      WHILE LENGTH(ST)< 15 DO ST := CONCAT(ST,' ');
      WRITE(ST);
      GOTOXY( (COL-1)*20,Y_BASE+ROW-1); { PLACE THE CURSOR }
      I := 1;
      REPEAT
         READ (KEYBOARD,CH);
         IF (syscom^.crtinfo.left= CH) AND (I>1)  THEN I := I-1;
         IF (syscom^.crtinfo.right=CH) AND (I<15) THEN I := I+1;
         IF (CH>='a') AND (CH<='z') 
            THEN CH := CHR( ORD('A')+ORD(CH)-ORD('a') );
         
          
         IF NOT(  (CH='?') OR(CH='=') OR(CH='*')    OR
                  (CH=',') OR(CH='$') OR(CH=':')    OR
                  (CH=syscom^.crtinfo.etx) OR EOLN(keyboard)  OR 
                  (ORD(CH)> 127)OR
                  (ORD(CH)< ORD(' '))             ) THEN
                  BEGIN
                     ST[I]:= CH;
                     WRITE(OUTPUT,CH);
                     IF I<15 THEN I:=I+1;
                  END;
         GOTOXY( (COL-1)*20+I-1 ,Y_BASE+ROW-1); { PLACE THE CURSOR }
      
      UNTIL EOLN(keyboard)OR(CH=syscom^.crtinfo.altmode)
                          OR(CH=syscom^.crtinfo.etx);
      
      I := POS(' ',ST);
      WHILE I<>0 DO 
      BEGIN
         DELETE(ST,I,1); { REMOVE THE SPACE CHARACTER }
         I := POS(' ',ST)
      END;
      
      IF NOT(CH=syscom^.crtinfo.altmode) THEN 
        IF UNIQUE_FILE THEN
        BEGIN
          DIR_STATUS[J].CHANGED := TRUE ;
          dispdir[J].DTID := ST;
        END;
         
      GOTOXY( (COL-1)*20,Y_BASE+ROW-1); { PLACE THE CURSOR }
      WITH_WRITE( J );
   end;
   END;
   
   {$P }
   'U','u':BEGIN
         ST := ORGDIR[J].DTID; 
         IF UNIQUE_FILE THEN
         BEGIN
            IF dir_status[j].removed THEN NUMFILES := NUMFILES +1;
            dir_status[j].removed := false; { RESTORE FILE TO DIRECTORY }
            dir_status[j].changed := false; 
            dispdir[J].DTID := ORGDIR[J].DTID ; { RESTORE NAME IF C(hanged }
            WITH_WRITE( J );
            CALC;
            PRINTSTATS;
         END;
      END;
   END; { OF CASE CU }
END;
    
{$P }
PROCEDURE DELETEFILES;

VAR
   I,J    : INTEGER ;
   
BEGIN
   J := 0;
   IF NUMFILES <> 0 THEN  FOR I := 1 TO NUMFILES DO
   BEGIN
      REPEAT J := J +1 UNTIL not dir_status[j].removed;
      IF J > I THEN dispdir[I] := dispdir[J];
   END;
   
   dispdir[0].DNUMFILES := NUMFILES ;
   if dirflip then 
   BEGIN
      DIRFLIP := FALSE;
      flipdir(dispdir);
   END;
   {$I-}
       unitwrite(dir_unit,dispdir,(maxdir+1)*sizeof(direntry),2+dir_offs,0);
   {$I+}
   IF IORESULT <>0 THEN DISK_ERROR( INAME );
   
END;
{$P }
PROCEDURE MARKENTRIES;
VAR 
  COMPLETE    : BOOLEAN;
  MATCH       : BOOLEAN;
  new_extend  : boolean ;
  extension   : boolean ;
  CH          : CHAR;
  ST          : STRING ;
  chartostr   : string[1];
  I,J,K       : INTEGER;
  NROW,NCOL   : INTEGER;
  rep_factor  : integer;
  
  
{$P }
BEGIN   { MARKENTRIES }

  COL := 1;
  ROW := 1;
  COMPLETE  := FALSE ;
  NEWPROMPT := TRUE  ;
  extension := false ;
  NEW_EXTEND := TRUE;
  chartostr  := ' ';
  
  
REPEAT { UNTIL COMPLETE 1111111 }
REPEAT { UNTIL COMPLETE 2222222 }
    esc_true := false ;

  
  IF NEWPROMPT THEN 
  if not extension then PROMPT(0,
'<arrows> Remove Change Undo Move Get Edit eXecute ENTER ESC Quit Help Output ?'
               )   else prompt(0,
'Natural Sorted Logical Verify Advance Formfeed                      19 Aug 82'
               );

    NEWPROMPT := FALSE ;
    J :=  INDEX[ TOTALTOCOL[COL]+ROW ];
{*****}
if new_extend then
begin 
  if dispdir[0].dnumfiles > 0 then
  begin
    GOTOXY(25,1);
    WITH dispdir[J] DO WRITE(syscom^.crtctrl.eraseeol,
         DTID,' ':(17-LENGTH(DTID)),
         DLASTBLK-DFIRSTBLK:5,
         DACCESS.DAY:4,'-',MONTHNAME[DACCESS.MONTH],'-',DACCESS.YEAR:2,
         DFIRSTBLK:5,
         DLASTBYTE:5,
         FILETYPENAME[dfkind]:10 );
  end;
  new_extend := false;
end;
{*****}
    GOTOXY( (COL-1)*20,Y_BASE+ROW-1); { PLACE THE CURSOR }
    
    
{***  READ THE NEXT COMMAND CHARACTER }
    rep_factor := 0;
    READ(KEYBOARD,CH);
    while ch in digits do
    begin
      rep_factor := rep_factor*10+(ord(ch)-ord('0'));
      read(keyboard,ch);
    end;
    
repeat
with syscom^.crtctrl, syscom^.crtinfo do 
begin
    
    IF CH = UP THEN IF ROW = 1 THEN ROW := COL_LENGTH[COL]
                               ELSE ROW := ROW-1;
    IF CH = DOWN THEN IF ROW = COL_LENGTH[COL] THEN ROW := 1
                                               ELSE ROW := ROW + 1;
    IF EOLN(KEYBOARD) THEN IF ROW = COL_LENGTH[COL] THEN
                      BEGIN
                        ROW := 1;
                        IF (COL<4)THEN IF (COL_LENGTH[COL+1]>0)THEN
                                            COL := COL + 1
                                       ELSE COL := 1
                        ELSE COL := 1;
                      END
                      ELSE ROW := ROW + 1;
    IF CH = LEFT THEN IF COL = 1 THEN
                      IF ROW <= COL_LENGTH[4] THEN COL := 4 ELSE
                      IF ROW <= COL_LENGTH[3] THEN COL := 3 ELSE
                      IF ROW <= COL_LENGTH[2] THEN COL := 2 ELSE
                      COL := 1
                    ELSE COL := COL - 1;
    IF (CH = RIGHT) OR (CH = TAB)  THEN 
                   IF ROW <= COL4 THEN { ROW IS COMPLETE }
                      IF COL = 4 THEN COL := 1 ELSE COL := COL + 1
                   ELSE { ROW IS A PARTIAL, 1,2 OR 3 COLUMNS ONLY }
                      IF ((COL=1) AND (ROW=COL2)) THEN COL := 2 ELSE
                       IF ((COL=2) AND (ROW=COL3)) THEN COL := 3 ELSE
                        COL := 1; { COLUMN THREE WRAPS TO COLUMN ONE }
    IF CH = in_home THEN BEGIN ROW := 1; COL := 1 END;
    
    new_extend := 
       ( ch = up   ) or ( ch = down  ) or
       ( ch = left ) or ( ch = right ) or
       ( ch = tab  ) or ( ch = home  ) or
       ( eoln(keyboard)   );
    
    IF (CH = etx) or (CH = altmode)
       THEN COMPLETE := TRUE;
end;
rep_factor:=rep_factor-1;
until rep_factor<1;

{*** END OF CURSOR POSITIONING COMMANDS }

{$P }
if not(new_extend or ( ch=syscom^.crtinfo.etx )
                  or ( ch=syscom^.crtinfo.altmode)) then
                  case ch of 
                  
                  
{*** REMOVE FILE PROCESSING }
'R','r':BEGIN
         IF not dir_status[j].removed THEN
         BEGIN
            NUMFILES := NUMFILES - 1;
            dir_status[j].removed := true;
            with_write( j );
         END;
         CALC;
         PRINTSTATS;
       END;
    

{*** SORT AND DISPLAY PRESENT VOLUME ***}
'S','s':begin
         sort := 1;
         sort_dir ;
         printentries;
         new_extend := true;
         row := 1; col := 1;
        end;
        
{*** SORT BY FOUR CHARACTER SUFFIX & FILE NAME ***}
'L','l':begin
         sort := 2;
         suffixsort;
         printentries;
         new_extend := true;
         row := 1; col := 1;
        end;
        
{*** MOVE THE FILE TO A TARGET }
'M','m':
     IF not DIR_STATUS[J].REMOVED THEN MOVE_FILE(J)
      ELSE
      begin
        newprompt := true;
        pressreturn('A REMOVED FILE CAN NOT BE MOVED. ');
      end;

{*** FORMFEED THE PRINTER                         ***}
'F','f':begin
          if target_known then
            if tar_unit = 6 then 
              unitwrite(tar_unit,formfeed,1);
        end;

{*** SET NATURAL ORDER AND DISPLAY PRESENT VOLUME ***}
'N','n':begin
         sort := 0;
         for i:=1 to maxdir do index[i]:= i;
         printentries;
         new_extend := true;
         row := 1; col := 1;
        end;
        
{*** GET A NEW DESTINATION VOLUME }
'G','g':  GET ;
      
   
   
{*** UNDO THE ACTION ( IF ANY ) TAKEN TO DATE ON THIS FILE }
'U','u':CHANGE_FILE( CH, J);
    
{*** refresh the present volume display ***}
'V','v':printentries;

{*** CHANGE THE FILE NAME }
'C','c':CHANGE_FILE( CH, J);
  
  
{*** HELP }
'H','h': help ;
   
   
{*** OUTPUT TO A DEVICE OR FILE }
'O','o':BEGIN 
         DOUTPUT; 
         NEWPROMPT := TRUE 
      END;
   
{*** eXecute the code file, or initiate a monitor input string }
'X','x':begin
   IF dir_status[j].removed then 
   begin
     newprompt := true;
     pressreturn( 'CANNOT EXECUTE A REMOVED FILE.');
   end
   else
   begin
     esc_true := true;
     complete := true;
   end;
   end;

{*** Edit the file specified }
'E','e':begin
   if dir_status[j].removed then
   begin
     newprompt := true;
     pressreturn( 'CANNOT EDIT A REMOVED FILE' );
   end
   else
   begin
                           
     esc_true := true;
     complete := true;
   end;
   end;
          
{*** Quit the directory utility after update of directory prompt }
'Q','q':begin
         esc_true := true;
         complete := true;
        end;
  
{*** Advance to subsiderary volume }
'A','a':begin
          if dispdir[j].dfkind =subsvol then
          begin
            next_offs := dispdir[j].dfirstblk + dir_offs ;
            complete := true;
          end
          else
          begin
            newprompt := true;
            pressreturn('Selection "A" must point to SVOL type file');
          end;
        end; { of type 'A' }
end; { of case }
if ( ch = '?' ) or ( ch = '/' ) then 
        begin
          newprompt := true;
          extension := not extension ;
        end
        else  extension := false ;
          
  
UNTIL COMPLETE; { 11111111 }



  TARGET_KNOWN := FALSE ;
  do_marks := true;
  
  IF  ( dispdir[0].dnumfiles > 0 ) THEN
  BEGIN
     I:=1;
     REPEAT 
      with dir_status[i] do
        DO_MARKS:= removed or changed ;
      I:=I+1 
     UNTIL DO_MARKS OR ( I > dispdir[0].DNUMFILES );
     IF DO_MARKS THEN 
     BEGIN 
      REPEAT
       GOTOXY( 0,0 ); 
       WRITE ('Update directory? (Yes/No/Return)',syscom^.crtctrl.eraseeol);
       READ ( YESNO );
      UNTIL (YESNO = 'Y')OR(YESNO ='y')OR
            (YESNO = 'N')OR(YESNO ='n')or
            (yesno = 'R')or(yesno ='r');
      newprompt := true ;
      complete := not( (yesno='R')or(yesno='r') );
      DO_MARKS :=  (YESNO = 'Y')or(YESNO = 'y') ;
     END;
  END;
until complete; { 222222222 }
  
if do_marks then 
repeat
  {$I-}
      unitread(dir_unit,targetdir,sizeof(dir_entry),2+dir_offs,0);
  {$I+}
  OK := IORESULT = 0;
  IF NOT OK THEN DISK_ERROR(TNAME)
  else
    with targetdir[0] do
    if NOT ( ( length(dvid)<=0 ) or ( length(dvid)> 7 ) )  then
    begin
      ok :=  disp_dir[0].dvid = targetdir[0].dvid ;
      if not ok then
      begin
        ok := false;
        repeat
          gotoxy(0,0); 
          write('Return Volume ',disp_dir[0].dvid,' to #',dir_unit,
                ' Press Space');
          read(ch);
        until ch=' ' ;
      end
    end
    else
    begin
      ok := false;
      repeat
        gotoxy(0,0);
        write('Return Volume ',disp_dir[0].dvid,' to #',dir_unit,
              ' Press Space');
        read(ch);
      until ch=' ' ;
    end
      

until ok = true;
         

CASE CH OF 
{*** eXecute the code file, or initiate a monitor input string }
'X','x':begin
     prompt(0,concat('Execute ',dispdir[0].dvid,':',dispdir[j].dtid));
     if dispdir[j].dfkind = codefile then
         chain( concat('I="x', dispdir[0].dvid,':',dispdir[j].dtid,'."' ))
     else
         chain( concat( 'I=',dispdir[0].dvid,':',dispdir[j].dtid));
     esc_true := true;
     complete := true;
   end;

{*** Edit the file specified }
'E','e':begin
     prompt(0,concat('Edit ',dispdir[0].dvid,':',dispdir[j].dtid));
     chartostr[1] := syscom^.crtinfo.linedel;
     chain( concat( 'I="e',chartostr,
                           dispdir[0].dvid,':',
                           dispdir[j].dtid,'"'));
                           
     esc_true := true;
     complete := true;
   end;
          
END;  { of case ch }
IF DO_MARKS THEN DELETEFILES; 
END; 




{$P }
{
*
**
***
****
*****     PRIMARY BLOCK STARTS HERE 
****
***
**
*
}
BEGIN
MEMLOCK('SCREENOPS');
INITIALIZE;

REPEAT
  tar_offs := 0; { should always be 0 }
  
  {***  ACCEPT A VOLUME ID FROM THE USER   ***}
  
  
  REPEAT 
   write( syscom^.crtctrl.clearscreen );
   TNAME := iname;

if next_offs = 0 then 
begin { 11111111 }
   dir_offs := 0 ; { remove the svol offset if present }
   

   gotoxy(0,2);

   writeln('Volumes presently online:');
   writeln;

   i := 0;
   j := 0;
   l := 0;
     {
          Finds the next blocked volume for output to the screen 
           
     }
     while (j < maxunit) and ( i < 60 )  do
     begin
       j := j+1;
       if syscom^.unitable^[j].uisblkd then
       begin
          read_vid(j);
          IF syscom^.unitable^[j].UVID <> '' THEN
          BEGIN
            gotoxy( ( i div 20 * 27 ), ( i mod 20 + 4 ) );
            WRITE( j:2 );
            
            WRITE( ':' );
            (*
            IF syscom^.unitable^[j].UISBLKD THEN
              if syscom^.unitable^[j].uvid = syvid then write( ': R ' )
              else
                if syscom^.unitable^[j].uvid = dkvid then write(': P ')
                else WRITE(':   ')
            ELSE WRITE(':   ');
            *)
            WRITE(syscom^.unitable^[j].UVID,
                   ' ':8-LENGTH(SYSCOM^.UNITABLE^[J].UVID));
            WRITE('[',syscom^.unitable^[J].ueovblk:5,']');
            if syscom^.unitable^[j].uvid <> syscom^.unitable^[j].upvid then
              write(syscom^.unitable^[j].upvid);
            write(syscom^.crtctrl.eraseeol);
            i := i +1 ;
          END; { syscom^.unitable^ <> '' }
       end; { syscom^.unitable^[j].uisblkd }
     end; { j< maxunit and i < 80  }

    ok := false;
    gotoxy(0,0);
    WRITE('Enter volume id of disk (<ESC>,<RETURN> to end) [',TNAME,'] =>',
           syscom^.crtctrl.eraseeol);
    READLN(INAME);
    if iname = '' then iname:=TNAME ;
    IF INAME[LENGTH(INAME)] = syscom^.crtinfo.altmode  THEN EXIT ( dfile );
    

    ok := false;
    dir_unit := get_unit_number( iname );
end { 111111111 }
else
begin { next_offs <> 0 is request to display subsiderary volume }
  dir_offs := next_offs ; { displacement to svol }
  next_offs:= 0;
end;

    if syscom^.unitable^[dir_unit].uisblkd then
    begin
    
      {$I-}
         unitread(dir_unit,dispdir,(maxdir+1)*sizeof(direntry),2+dir_offs,0);
      {$I+}
      OK := IORESULT = 0;
      IF NOT OK THEN DISK_ERROR(concat(INAME,':'))
      else
        begin
         if dispdir[0].dlastblk > 255 then 
         begin
            dirflip := true;
            flipdir( dispdir )
         end
         else dirflip := false;
         FOR I := 0 TO DISPDIR[0].DNUMFILES DO
             ORGDIR[I] := DISPDIR[I];
        end;
      
    END;
    if not ok then initentry := false ;
  UNTIL OK ;
 
                      
  if ch<>syscom^.crtinfo.altmode then
  begin
     CRT := TRUE ;
     ALLDONE := FALSE;
     NUMFILES := DISPDIR[0].DNUMFILES;
     J := 1;

     FOR I := 1 TO MAXDIR DO INDEX[I] := I ;

     case sort of
       1: sort_dir;       {alphanumeric sort on file name}
       2: suffixsort;     {alphanumeric sort on four char suffix and file name}
     end;

     


     
     IF NUMFILES > 0 THEN 
       FOR I := 1 TO NUMFILES DO
       begin
         dir_status[i].removed := false;
         dir_status[i].changed := false;
         dir_status[i].moved   := false;
       end;
     FOR I := NUMFILES+1 TO MAXDIR DO 
       begin
         dir_status[i].removed := true ;
         dir_status[i].changed := false;
         dir_status[i].moved   := false;
       end;
     CALC;
   
     {*** OUTPUT THE DIRECTORY TO THE CRT SCREEN }
     PRINTENTRIES; { PRINT ALL INFORMATION }
     
     markentries;
  end;
 UNTIL ESC_TRUE ;
 write( syscom^.crtctrl.clearscreen );
          
END.
a9DFILE   INITIALIHELP    DOUTPUT CALC                                                                                            	(
DFILE   DFILE   DFILE   DFILE   &2DFFHF*7F\r\rBl\r\n9L@8INITIALI	
                                                                                                                                                                                                           	
		!	&	+	0	5	:	?	D		IN,ȆOȥ
<P ***JanFebMarAprMayJunJulAugSepOctNovDecUntypedffXdiskfillCodefileeTextfileeInfofileeDatafileeGraffileeFotofileeSecurdirrSubsvol    HELP    #upvwpwpwpwp+wpwpIwpwpbwpwpxwpwpwpwpwpwpwpwpwpwpwpwpwpwpwpwp<wpwpSwpwprwpwpwpwpwpwpqq-<arrows>, <return> and <tab> :move the cursor"Remove  :the file under the cursorr;Change  :the file name under the cursor to <enter new name>0Undo    :restores the file name under the cursorr+Move    :the file to the destination volume!Get     :a new destination volumeEdit    :the file at the cursor7eXecute :the code file or redirect from the script file<<enter> and <esc> :update directory and accept new volume idd3Quit    :update directory and exit to PASCAL system*Help    :displays this page of informationn.Output  :moves the display to a device or filee?Natural :displays files in the order of occurance on the volume-Sorted  :displays files in alphanumeric order<Logical :displays files in alphanumeric order by suffix namee)Verify  :redisplays the present directory:Advance :advance to the subsidiary volume under the cursorr;Formfeed:Slew to top of page, if printer is the destination1Help  :describes the user options                DOUTPUT x
vwp up<Pw
pw
p<Օ<<짚,ɱՁK<
p0[pK
pvwp<wpwpwp"wpw	pqK
pEnter the output file name Can not open file  , error number  <press return>CALC    M
yM
xM
ոM
k#>xMl$"M
yM
xM
hM
i hx M ! M
yj"" M
xi M
M
y`DFILE   )`*P
pvwp`wpiwp`wpOwpwp$wp`wp`wp/wp7wp`wp:wpܚHwp`wpNwpXwp`wp`wpjwp`wppwphxwp`wpOwp`wpwp)wp`wpwpր+vwp upwpM
Mol$'$M$M$l憀M
h ՟M
 jk#l$ i$MxM
!MxM
A$Mxn$M!MxMĆ!M&M$ l$mm%#k#"y hZM
**}`M
P`T`지.HM
++`P+`Ԙ+{M
**(M
M
Ж`!˧!!˧!`˧ȖG#M
i!!!!!!	!
Mih !%# M
j""""" h֖*a+Pah 'a짃aa지ȅ҇-vawp up-[3\Pia3Pa`a	`w	p]5wvwpwpwpwpvM
wpwpwpwpKwpKwpKwpKwpKwpK	wpKwpKM
wpKwpKwpKwpKwpKwp*a,Pawp-.M
lx.Mm%%ɠ%ɠj$ik!$!지.k#5$f!f"K$f!fwp!h  h5 up
K up5$f!f"K$f!fwp=5	$"K$wp!h  h5 up
K up"5j up%Rup
-up%Cup
-up%Mup
-up|up35$y$xwp|upK$y$xwpK up	
5B#upv wpM
wp:up,K(wpKM
wpK:upM
jM
ˏi!""!""!"""ĆĆĆĆĆĆĆĆM
5vKwpKwpk#՘h Mx h x
 Mx h x
 Mx h M

 Mx5vKwp`
2v60wpewp
1"ih !&" 지a" 지z" " 지aA hՖ

h-`ppw _!b	cc	˧	˧Mbɱ-8                                                                                                                          -c-9-:+-i,;,<P,지:,<P,지*,@P<,,,bbP,지#*,,,bbP,<P,h 0,짛Z
,짢0h p i|ˇ,
,|,腀԰,iX|,Ň,i!-,-hi	6v=wp up
ePw
pw
peQiee짚,i!\eekccRcP|p"Mpph eM
y
M
k####M#ɱFvSwpewpawp upw	phVM
M
9vkwpwp upw	ph !A7Mpph eކM
k####M#ɱhededM
ՃvwpewpwpM
wpwp upw	p>N>n>Y>yԇ>y>Yh  !,!!.2v6wpewp-                                                                                                                                                         -d.PYiM
kjh#"jd"M
h "# ՙvdwpwp up
aw	p!Y!y!N!n!,ɰ!Y!y8M
#M"# "M
"M

"j"#v!Y!y0/#$'M
h'M
i h!' M
yj$$x""#x% #"' M
xi &#x	v2vwp wpwp upvwp up
o<
o'*??
*
o'p=M
y=M
xk                                                                                                                                                                                     7=M
M
Mn#	ab*M
o'M
'M

'o'((M
=M

(M
(M
yĆ(M
(M
x#ĆM
M
MĆ=M
xl(M
xm=M
y$n&**n)&$pph a;$&l)&%pph %&m3ePQ=M
`3PQ=M
`.up$=M
y  3Mpvx=Mʇ=v=M
wpwp#wpwp"wp#wp!wp(wp/wp upw	p
BvM
wp7wp upw	p
=M
|                                                                                                                          #upvLwp=M
wpRwpewpUwp upwp
=M
xl=M
y$n&**n)&$pph J$&l)&%pph %&m'eP=M
_'P=M
_.up$=M
y Avx=Mʅ=\2vgwp
*
=2v up                                                                                                                                                                                    ?YiM
h\MxxMxMMxM
h Ԥ j"j"x셀"xk"#vxMxMʆMxxMxMvswp up
"#vaw	p!Y!y!N!n!,ɰ!Y!y(xMxMʔ
Mxv!Y!yllxM

aM
aa$aa지.aaaaa

a
                                                                                                                    
ۚawpv`w	p( (  a zA ah ? = * , $ : -ɰwp   a Ț upvwp ,ɰ -ɰaaa ,ɰ% xMʆM
avvaM
[xMxMʆxMʆM
M

ւDh>ji!"3 hx M !!M
 M

!iȆM
M:Mpp#Eh
kj/9#
		
xMx1"ۆM
v1M
6 up6wp 6up6y6xwp6wp-up6wp-up6	wp6xwp6wpˇ6	
wpjv5dw	p$Z5
$05dw	p6%7$7x$7xwpKx2!x	$7XKx2xx$7ɰ$L.$$7ɰ$7ɰ$7ɰ$7ɰ$$6ɰwpj$7ɰ$7ɰh555"$-ɰ$,ɰՃ$|x1Mx1Mʇ1
Mj8j#x1M1

6p襀M62262M2Mć22j$1$1t	
x1M
.hcx1M
>h@h91M
	1M
xh

Lփb$?$/
#kk M
՛2x2M66ɇ6ɠ2242M
4bvwp up                                                                                       	p?Y?y?N?n?R?rԷ
?R?rh?Y?y \4 pp0eM
666}M
M
0[vwpM
wpwpwpwpdw	p$ Ҩ[vwpM
wpwpwpwpdw	p$ Ҩ0$666M
6                                                                                                                    61M
6	1M
R666M
661M
66rE666M
	6
61M
6rh666M
6
61M
6	/,Ȥ666/6M
6
61M
66rhփ4E'݆Kw

s#upePv$wpwpwp<|1مˏvwp:upwp up[up}wp]upwp upv2wpewpKwp upPw
pw
pNeP짚,p
|՟Mpp0$ƆƆPƂOQƘ]M
y
M
ƥƲ$M
M

0
0D>,ɱM
MƥƲMMąڅքPLƥƲ9xMʆxMʆxMʅMƥƲ9xMʆxMʆxMʅ2/#upK
Parity error while reading Can not find device for  
Error number  while working with   went offline  File  is no longer in directory.
File name   can not be used.  Disk is full,   can not be saved..Volume for  is not online.Can not find the file  File already exists..Volume  is write protected. }$Kr 1One moment please, directory sort is in progress.<press return>   of 77 files used,,
 Blocks used  Blocks available,, in largest of 77 files used,,
 Blocks used  Blocks available,, in largestVolume name is Volume name is Destination is :&Enter volume id of destination disk >  :No directory on volume for : < press return >>4Destination is not allowed to be the same as source..   <press return>Old destination was  , new destination is #  Ok to use new destination? (Y/N) Destination is 7 is on destination disk, Remove the old version? (Y/N) Move buffer is  blocks..&One moment please, move in progress.   DFILE,SCREENOPS,FILEOPS,CALCC No room for move buffer :: is  
 blocks.   	 contig. 
 total avail. <press return>) volume directory is full. <press return>
Output of   to  
 in progress.File type is not textDestination is CONSOLE:Remove the old version? (Y/N)"cannot change a removed file name      Cu N<arrows> Remove Change Undo Move Get Edit eXecute ENTER ESC Quit Help Output ??MNatural Sorted Logical Verify Advance Formfee
========================================================================================
DOCUMENT :usus Folder:VOL23:df.iv.1.text
========================================================================================

{ DF - Directory/File utility                       }
PROGRAM DFILE  ;
{

  UPDATE LOG:
  12 Mar 83 RES modified read_vid for byte swapped TIPC 
  23 Mar 83 : RES - Restore cursor on return from A cmd.
  12 Mar 83 RES - Corrected volume changed warning message
  12 Jan 83 : RES - Established log entry and release date 
  
}
USES {$U KERNEL.CODE} KERNEL,
     {$P }{ COMMANDIO }
     {$U COMMANDIO.CODE} COMMANDIO ,
     {$P }{ SCREENOPS }
     {$U SCREENOPS.CODE } SCREENOPS ;

    
  {$P }
  CONST
       vs         = 124;   { vertical separator between columns }
       MAX_SVOL_DEPTH = 9;
       
  TYPE
       word   = packed array[0..1] of 0..255 ;
  
       dentry = PACKED RECORD
        case integer of 
        0:(
     
                  DFIRSTBLK: INTEGER;   { FIRST PHYSICAL DISK ADDR }
                  DLASTBLK: INTEGER;    { POINTS AT BLOCK FOLLOWING }
                  CASE DFKIND: FILEKIND OF
                    SECUREDIR,
                    UNTYPEDFILE: { ONLY IN DIR[0]...VOLUME INFO }
                       (filler_1 : 0..2048;     {13 bits}
                        DVID: VID;              { NAME OF DISK VOLUME }
                        DEOVBLK: INTEGER;       { LASTBLK OF VOLUME }
                        DNUMFILES: DIRRANGE;    { NUM FILES IN DIR }
                        DLOADTIME: INTEGER;     { TIME OF LAST ACCESS }
                        DLASTBOOT: DATEREC);    { MOST RECENT DATE SETTING }
                    XDSKFILE,CODEFILE,TEXTFILE,INFOFILE,
                    DATAFILE,GRAFFILE,FOTOFILE,SUBSVOL:
                       (filler_2 : 0..1024;     {12 bits}
                        status : BOOLEAN;       {Filer kludge temporary}
                        DTID: TID;              { TITLE OF FILE }
                        DLASTBYTE: 1..FBLKSIZE; { NUM BYTES IN LAST BLOCK }
                        DACCESS: DATEREC)       { LAST MODIFICATION DATE }
            );
         1:(
         
                    f1first : word ;
                    f1last  : word ;
                    f1kind  : word ;
                      f1dvid: string[7];
                      f1deov: word ;
                      f1dnum: word ;
                      f1load: word ;
                      f1boot: word 
            );
         2:(
         
                    f2first : word ;
                    f2last  : word ;
                    f2kind  : word ;
                      f2dtid: string[15];
                      f2byte: word ;
                      f2aces: word
            );
        end; { of case }
       
       psysdir    = array [dirrange] of dentry ;
       
       INXTYPE = ARRAY [ DIRRANGE ] OF DIRRANGE ;
    
       statustype = ARRAY[DIRRANGE] OF 
                      PACKED RECORD 
                        REMOVED : BOOLEAN ;
                        CHANGED : BOOLEAN ;
                        MOVED   : BOOLEAN ;
                        SWAPED  : BOOLEAN ;
                      END; { DIR_STATUS }
       
       
       
  {$P }
  VAR
    OK            : BOOLEAN ;
    ALLDONE       : BOOLEAN ;
    ESC_TRUE      : BOOLEAN ;
    ENDOFLINE     : BOOLEAN ;
    DO_MARKS      : BOOLEAN ;
    CRT           : BOOLEAN ;
    TARGET_KNOWN  : BOOLEAN ;
    dest_is_text  : boolean ;
    THE_SAME      : BOOLEAN ;
    NEWPROMPT     : BOOLEAN ;
    dirflip       : boolean ;
    tarflip       : boolean ;
    initentry     : boolean ;
    none_printed  : boolean ;
    going_up      : boolean ;


    CH            : CHAR;
    YESNO         : CHAR;
    TAB           : CHAR;
    home_tv       : char; { home char from the televideo 950 crt }
    home_911      : char; { home char from the TI-911 crt }

    INAME         : STRING ; { FILE NAME INPUT STRING }
    FNAME         : STRING ; { FILE NAME ON WHICH TO WRITE THE DIRECTORY LIST }
    TNAME         : STRING ; { FILE NAME FOR TARGET VOLUME }
    buildstring   : string[1];
    
    
    I,J,k,L    : INTEGER;
    SORT       : integer;
    SVOLS_ARY  : ARRAY[0..MAX_SVOL_DEPTH] OF INTEGER ; { SVOL CNTR AND OFFSET }
    XY_ARRAY   : ARRAY[0..MAX_SVOL_DEPTH] OF INTEGER ; { LAST CURSOR POS.}
    dir_unit   : integer; { displayed directory unit number }
    dir_offs   : integer; { offset in blocks to displayed directory }
    tar_unit   : integer; { target unit number }
    tar_offs   : integer; { target offset in blocks to directory }
    ICOUNT     : INTEGER;
    TOTBLKS    : INTEGER; { TOTAL BLOCKS USED ON VOLUME }
    MAXCONTIG  : INTEGER; { LARGEST CONTIGUOUS SERIES OF BLOCKS ON VOLUME }
    NUMFILES   : INTEGER; { NUMBER OF VALID FILES ON VOLUME }
    S_HEIGHT,             { NUMBER OF LINES ON THE SCREEN LESS ONE }
    S_WIDTH    : INTEGER; { NUMBER OF CHARACTERS PER LINE LESS ONE }
    ROW        : INTEGER; { NUMBER OF PRESENT ROW }
    COL        : INTEGER; { NUMBER OF PRESENT COLUMN }
    COL1       : INTEGER; { NUMBER OF ROWS IN COLUMN ONE }
    COL2       : INTEGER; { NUMBER OF ROWS IN COLUMN TWO }
    COL3       : INTEGER; { NUMBER OF ROWS IN COLUMN THREE }
    COL4       : INTEGER; { NUMBER OF ROWS IN COLUMN FOUR }
    Y_BASE     : INTEGER; { Y - ADDRESS OF FIRST ROW IN DISPLAY MATRIX }
    Y_COUNTS   : INTEGER; { Y - ADDRESS OF DISK LOGISTICS }
    formfeed   : packed array[1..2] of char ;
    
    COL_LENGTHS: ARRAY [1..4] OF INTEGER;
    TOTALTOCOL : ARRAY [1..4] OF INTEGER;
    MONTHNAME  : ARRAY [0..12] OF STRING[3];
    FILETYPENAME:ARRAY [ FILEKIND ] OF STRING[8];

    
    DISPDIR    : psysdir   ;
       BUFF1   : ARRAY[0..9] OF INTEGER ; { BRING DIRECTORY BUFFER TO 4 BLKS}
    ORGDIR     : psysdir   ;
       BUFF2   : ARRAY[0..9] OF INTEGER ; { BRING DIRECTORY BUFFER TO 4 BLKS}
    TARGETDIR  : psysdir   ;
       BUFF3   : ARRAY[0..9] OF INTEGER ; { BRING DIRECTORY BUFFER TO 4 BLKS}
    INDEX      : ARRAY[DIRRANGE] OF DIRRANGE;  {INDEX INTO DIRECTORY FOR SORT}
    LIST       : INTERACTIVE;  { OUTPUT FILE THE DIRECTORY LIST FILE ITSELF }


    DIR_STATUS : statustype ;
    key_cmd    : sc_key_command ;
    
{$p }

procedure printentries; forward ;
procedure pressreturn( st : string ); forward;
procedure rdline ( var strng : string ); forward;

    
                 
    

  
(*$P *)
segment PROCEDURE INITIALIZE ;

BEGIN  (* INITIALIZE *)
  
  TAB := CHR( 9 );
  home_tv := chr( 30 ); { home char from the televideo 950 crt }
  home_911:= chr(130 ); { home char from the TI-911 crt }
  

  
  MONTHNAME[ 0] := '***';
  MONTHNAME[ 1] := 'Jan'; MONTHNAME[ 2] := 'Feb'; MONTHNAME[ 3] := 'Mar';
  MONTHNAME[ 4] := 'Apr'; MONTHNAME[ 5] := 'May'; MONTHNAME[ 6] := 'Jun';
  MONTHNAME[ 7] := 'Jul'; MONTHNAME[ 8] := 'Aug'; MONTHNAME[ 9] := 'Sep';
  MONTHNAME[10] := 'Oct'; MONTHNAME[11] := 'Nov'; MONTHNAME[12] := 'Dec';
  
  
  
  FILETYPENAME[ UNTYPEDFILE ] := 'Untypedf';
  FILETYPENAME[ XDSKFILE    ] := 'Xdiskfil';
  FILETYPENAME[ CODEFILE    ] := 'Codefile';
  FILETYPENAME[ TEXTFILE    ] := 'Textfile';
  FILETYPENAME[ INFOFILE    ] := 'Infofile';
  FILETYPENAME[ DATAFILE    ] := 'Datafile';
  FILETYPENAME[ GRAFFILE    ] := 'Graffile';
  FILETYPENAME[ FOTOFILE    ] := 'Fotofile';
  FILETYPENAME[ SECUREDIR   ] := 'Securdir';
  filetypename[ subsvol     ] := 'Subsvol ';

  buildstring := ' '; { set string length to one }
  formfeed[1] := chr(12) ; { ASCII form feed character }
  
  TARGET_KNOWN := FALSE ;
  esc_true := false ;
  initentry := true;
  iname := dkvid ; { prefix volume id }
  svols_ary[0] := 0 ;
  xy_array[1]  := 1 ;
  dir_offs  := 0 ;
  tar_offs  := 0 ;
  sort  := 0 ; 
  ch    := ' '   ; 
  ok    := false ;

  END; { OF INITIALIZE }
  

{$P }
segment procedure help;
begin
  sc_clr_screen;
  sc_goto_xy(0,2);
  writeln('<arrows>, <return> and <tab> :move the cursor');
  writeln('Remove  :the file under the cursor') ;
  writeln('Change  :the file name under the cursor to <enter new name>');
  writeln('Undo    :restores the file name under the cursor');
  writeln('Move    :the file to the destination volume');
  writeln('Get     :a new destination volume');
  writeln('Edit    :the file at the cursor');
  writeln('eXecute :the code file or redirect from the script file');
  writeln('<enter> and <esc> :update directory and accept new volume id');
  writeln('Quit    :update directory and exit to PASCAL system');
  writeln('Help    :displays this page of information');
  writeln('Output  :moves the display to a device or file');
  writeln('Natural :displays files in the order of occurance on the volume');
  writeln('Sorted  :displays files in alphanumeric order');
  writeln('Logical :displays files in alphanumeric order by suffix name');
  writeln('Verify  :redisplays the present directory');
  writeln('Advance :advance to the subsidiary volume under the cursor');
  writeln('Formfeed:Slew to top of page, if printer is the destination');
  
  pressreturn('Help  :describes the user options                ');
  printentries;
  
  
end;
{$P }
segment PROCEDURE DOUTPUT ;


{ OUTPUT THE DIRECTORY TO A FILE OR DEVICE }
BEGIN
  newprompt := true;
  sc_clr_line( 0 );
  sc_goto_xy(0,0);
  WRITE('Enter the output file name ');
  rdline(FNAME);
  IF LENGTH(FNAME)<>0 THEN 
  BEGIN
     {$I-}
     REWRITE( LIST, FNAME);
     {$I+}
     
     OK := IORESULT = 0;
     IF NOT OK THEN
     BEGIN
       I := IORESULT;
       close(list);
       sc_goto_xy(0,0);
       WRITE('Can not open file ',fname,', error number ',I,
             ' <press return>');
       READ(CH);
     END
     ELSE
     BEGIN
       CRT := FALSE ;
       PRINTENTRIES; { PRINT ALL INFORMATION }
       CLOSE( LIST, LOCK );
       crt := true;
    END;
  END;
END;

{$P }
procedure rdline{ var strng: string };
var
  exit_rd : boolean ;
  bell    : char ;

begin
strng := '' ;
exit_rd := false;
bell    := chr(7);
repeat
  read(keyboard,ch);
  IF not eoln(keyboard) THEN
  begin 
    key_cmd := sc_map_crt_command( ch );
    case key_cmd of
      sc_del_key,
      sc_right_key,
      sc_dc1_key,
      sc_eof_key,
      sc_up_key,
      sc_down_key,
      sc_insert_key,
      sc_delete_key :begin
                      write( bell );
                     end;
      
      sc_etx_key  : begin
                      exit_rd := true ;
                    end;
      
      sc_escape_key: begin
                      exit_rd := true ;
                      strng := '' ;
                     end;
      
      
      sc_backspace_key,
      sc_left_key :  begin
                      if length(strng) > 0 then
                      begin
                       sc_left;
                       write( ' ' ); { replace screen character with space}
                       sc_left;
                       {$R- }
                       strng[0] := chr( ord(strng[0]) - 1 );
                       {$R+ }
                      end
                      else
                       write( bell );
                     end;
       sc_not_legal: begin
                        if ch in sc_printable_chars then
                        begin
                           if length(strng) < 80 then
                           begin
                             {$R- }
                             strng[0] := chr( ord(strng[0]) + 1 ) ;
                             {$R+ }
                             strng[ length( strng ) ] := ch ;
                             write(ch);
                           end
                           else
                           begin
                              write( bell );
                           end;
                        end
                        else
                         write( bell );
                     end; { of sc_not_legal }
                       
                       
       end; { of case  key_cmd }
   end {  not eoln }
   else 
   begin
      ch := ' ' ;{ eoln so set char to a space }
      key_cmd := sc_not_legal ;
   end;
   
       
                     
    
until eoln(keyboard)  or exit_rd ;
end; { of rd_line }
 {$P }
PROCEDURE CALC;

VAR
   NEXTLOW     : INTEGER ;
   LAST        : INTEGER ;
   SIZE        : INTEGER ;
   

BEGIN

{   CALCULATE THE TOTAL BLOCKS USED }
   { INITIALIZE USED BLOCK COUNT }
   totblks := dispdir[0].DLASTBLK-dispdir[0].DFIRSTBLK ; 
   
   
   IF dispdir[0].DNUMFILES > 0 THEN
   BEGIN
     FOR I := 1 TO dispdir[0].DNUMFILES DO 
       with dir_status[i] do 
         IF not removed then 
           totblks := totblks + dispdir[I].DLASTBLK - dispdir[I].DFIRSTBLK ;
      
{   FIND THE LARGEST SET OF CONTIGUOUS BLOCKS }
      maxcontig := 0;
      NEXTLOW := dispdir[0].DNUMFILES + 1;
      LAST    := dispdir[0].DEOVBLK ;
      REPEAT 
         REPEAT 
           NEXTLOW := NEXTLOW -1 ;
         UNTIL ( not dir_status[nextlow].removed ) OR ( NEXTLOW < 1 );
         SIZE := LAST - dispdir[ NEXTLOW ].DLASTBLK ;
         IF SIZE > maxcontig THEN maxcontig := SIZE ;
         LAST := dispdir[ NEXTLOW ].DFIRSTBLK ;
      UNTIL NEXTLOW < 1 ;
      
   END
   ELSE maxcontig := dispdir[0].DEOVBLK - dispdir[0].DLASTBLK ;
      
END; { OF CALC }


{$P }
PROCEDURE DISK_ERROR ( STRN : STRING );
VAR
  STRNG : STRING ;
BEGIN
   newprompt := true;
   I := IORESULT;
   sc_goto_xy(0,0);
   CASE I OF 
   
    1:STRNG := CONCAT('Parity error while reading ',STRN);
    2:STRNG := CONCAT('Can not find device for ',STRN);
    3,4,12,13,14,15,17,18:
      BEGIN
        CASE I OF
          3 :STRNG :=  '3' ;
          4 :STRNG :=  '4' ;
         12 :STRNG := '12' ;
         13 :STRNG := '13' ;
         14 :STRNG := '14' ;
         15 :STRNG := '15' ;
         17 :STRNG := '17' ;
         18 :STRNG := '18' ;
        END;
        STRNG := CONCAT('Error number ',STRNG,' while working with ',STRN);
      END;
    5:STRNG := CONCAT(STRN,' went offline ');
    6:STRNG := CONCAT('File ',STRN,' is no longer in directory.');
    7:STRNG := CONCAT('File name ',STRN,' can not be used. ');
    8:STRNG := CONCAT('Disk is full, ',STRN,' can not be saved.');
    9:STRNG := CONCAT('Volume for ',STRN,' is not online.');
   10:STRNG := CONCAT('Can not find the file ',STRN);
   11:STRNG := CONCAT('File ',STRN,' already exists.');
   16:STRNG := CONCAT('Volume ',STRN,' is write protected. ');
  end;
  pressreturn( STRNG ); { append press return message and wait for one }
end;
   
{$P }
PROCEDURE SORT_DIR;
{ SHELL SORT DIRECTORY INDIRECTLY VIA 'INDEX' ARRAY }
VAR
  i,j,k,l,m : integer ;
  swap      : BOOLEAN ;
  temp      : integer ;
  
BEGIN
  sc_goto_xy(0,0);
  WRITELN('One moment please, directory sort is in progress.',
           syscom^.crtctrl.eraseeol);
  IF DISPDIR[0].DNUMFILES > 0 THEN  { NON-EMPTY DIRECTORY }
  BEGIN
    { SET UP INDEX ARRAY FOR SORT }
    FOR I := 1 TO MAXDIR DO INDEX[I]:=I;
    m := dispdir[0].dnumfiles div 2;
    while m > 0 do
    begin
      k := dispdir[0].dnumfiles  - m ;
      j := 1 ;
      repeat
        i := j ;
        repeat
          l := i + m ;
          if dispdir[index[i]].dtid > dispdir[index[l]].dtid
            then
            begin
              temp := index[i];
              index[i] := index[l];
              index[l] := temp;
              i := i - m;
              swap := i > 0 
            end
            else
              swap := false ;
        until not swap ;
        j := j + 1;
      until j>k;
      m := m div 2;
    end; { while m > 0 do }
  end;   
end;


{$P } { Sort file names giving a four character suffix priority }
procedure suffixsort;

var
   newname : string ;
   
begin
   for i := 1 to dispdir[0].dnumfiles do 
   begin
     newname := dispdir[i].dtid;
     l := length(newname);
     if l > 4 then
       if newname[l-4]='.' then begin 
          dispdir[i].dtid := concat(
                                copy(newname,l-4,5),
                                copy(newname,1,l-5)  );
          dir_status[i].swaped := true ;
          end
       else
          dir_status[i].swaped := false 
     else
          dir_status[i].swaped := false;
   end;
   
   sort_dir;
   
   for i:= 1 to dispdir[0].dnumfiles do 
   begin
      if dir_status[i].swaped  then 
         begin
           newname := dispdir[i].dtid;
           l := length( newname );
           dispdir[i].dtid := concat ( copy(newname,6,l-5),
                                       copy(newname,1,5 ) );
         end;
   end;
   
end;
  
                             
{$p }
procedure flipword( var flipme : word );
var temp : word ;
begin
  temp[0]:= flipme[0];
  flipme[0] := flipme[1];
  flipme[1] := temp[0];
end;

                             

procedure flipdir( var dir : psysdir   );

var 
   entrynum : integer;

begin
   with dir[0] do
   begin  
      flipword( f1first  );
      flipword( f1last   );
      flipword( f1kind   );
      flipword( f1deov   );
      flipword( f1dnum   );
      flipword( f1load   );
      flipword( f1boot   );
   end;

   for entrynum := 1 to maxdir do
   with dir[entrynum] do 
   begin
      flipword( f2first  );
      flipword( f2last   );
      flipword( f2kind   );
      flipword( f2byte   );
      flipword( f2aces   );
   end;
end;
      
{$P }
PROCEDURE PROMPT ( L :INTEGER; ST:STRING );
BEGIN
{* *** some terminals accept msb on as low intensity display ***
 * FOR I := 1 TO LENGTH(ST) DO
 *    IF st[i] in [ 'a'..'z'] then ST[I] := CHR( ORD( ST[I])+128);
 *}
sc_clr_line( L );
sc_goto_xy( 0,L ); 
WRITE(ST);
END;


PROCEDURE PRESSRETURN { ST : STRING } ;

VAR CH : CHAR ;
 BEGIN
  PROMPT(0,CONCAT(ST,' <press return> '));
  READ(CH);
END;


PROCEDURE PRINTSTATS;
     
BEGIN
   IF CRT THEN 
   BEGIN
      sc_goto_xy(0, 22);
      WRITE(NUMFILES:4,' of 77 files used,',
                   TOTBLKS:5,' Blocks used '
                   );
      sc_goto_xy(0,23);
      WRITE(DISPDIR[0].DEOVBLK-TOTBLKS:4,' Blocks available,',
                   MAXCONTIG:5,' in largest');
   END
   ELSE
   BEGIN
      WRITELN(LIST); WRITELN(LIST);
      WRITELN(LIST,NUMFILES:4,' of 77 files used,',
                   TOTBLKS:5,' Blocks used ');
      WRITELN(LIST,DISPDIR[0].DEOVBLK-TOTBLKS:4,' Blocks available,',
                   MAXCONTIG:5,' in largest');
      WRITELN(LIST);
   END
END; { PRINTSTATS }
{$P }
procedure writeit( st:string; bool:boolean);
var
   i : integer ;
begin
  { if terminal has a low intensity display the string should be output 
    in that mode when the boolean is true }
  
  {
  if bool then for i:= 1 to length(st) do
    st[i] := chr( ord(st[i])+128 );
  }
    
  write( st );
end;


PROCEDURE WITH_WRITE( K : INTEGER  );

VAR
   i,j  : INTEGER;
   low_intensity : boolean;
   suffix : boolean ;
   
   
   
BEGIN
  with dispdir[k],dir_status[k] do
  begin
    low_intensity := removed or changed or moved;
    i := length(dtid);   { length of file name }
    suffix := false ;
    if i > 4 then if dtid[i-4] = '.' then suffix := true ;
    if suffix then 
    begin
      if crt then writeit( copy(dtid,1,i-5),low_intensity  )
             else write(list, copy(dtid,1,i-5) );
      j:=i;
      while j<15 do
      begin
        j := j + 1 ;
        if crt then write( ' ' ) else write( list, ' ' );
      end;
      if crt then writeit( copy(dtid,i-4,5),low_intensity  )
             else write(list, copy(dtid,i-4,5) );
    end
    else
    begin
      if crt then writeit( dtid,low_intensity ) else write( list, dtid );
      j := i ;
      while j<15 do
      begin
        j := j+1 ;
        if crt then write(' ') else write(list,' ');
      end;
    end;
    if low_intensity and crt then
    begin
      write( ' ' );
      if removed then write('R')
                 else write('-');
      if changed then write('C')
                 else write('-');
      if moved   then write('M')
                 else write('-');
      write( chr(vs) );
    end
    else
    if crt then write(      dlastblk-dfirstblk:4,chr(vs) )
           else write(list, dlastblk-dfirstblk:4,' ' );
  end;
END;

{$P }
PROCEDURE PRINTENTRIES;

VAR
 DISP   : INTEGER;
 REM    : INTEGER;
 ROW    : INTEGER;

BEGIN
 NEWPROMPT := TRUE;
 IF CRT THEN
 BEGIN
    {*** OUTPUT THE DIRECTORY TO THE CRT SCREEN }
    sc_clr_screen ; { BLANK OUT THE CRT SCREEN }
    sc_goto_xy(0,1);
    WRITE('Volume name is ',DISPDIR[0].DVID,':');
 END
 else
 WRITE(list,'Volume name is ',DISPDIR[0].DVID,':');
 
 
 ROW := (DISPDIR[0].DNUMFILES) DIV 4;
 REM := (DISPDIR[0].DNUMFILES) MOD 4;
 IF REM >= 1 THEN COL1 := ROW + 1 ELSE COL1 := ROW ;
 IF REM >= 2 THEN COL2 := ROW + 1 ELSE COL2 := ROW ;
 IF REM >= 3 THEN COL3 := ROW + 1 ELSE COL3 := ROW ;
 COL4 := ROW ;
 TOTALTOCOL[1]:= 0;
 TOTALTOCOL[2]:= COL1;
 TOTALTOCOL[3]:= COL1+COL2;
 TOTALTOCOL[4]:= COL1+COL2+COL3;
 COL_LENGTH[1]:= COL1;
 COL_LENGTH[2]:= COL2;
 COL_LENGTH[3]:= COL3;
 COL_LENGTH[4]:= COL4;
 
 IF DISPDIR[0].DNUMFILES > 0 THEN 
 BEGIN
   IF CRT THEN 
   BEGIN
      Y_BASE := 2;
      IF COL1 < 19 THEN Y_BASE := 3;
      Y_COUNTS := Y_BASE;
      sc_goto_xy(0,Y_BASE);
   END
   ELSE
   BEGIN WRITELN(LIST); WRITELN(LIST) END;
   
   
   FOR I := 1 TO COL1 DO BEGIN  { PRINT ALL ENTRIES IN THE DIRECTORY }
     DISP := I;
     WITH_WRITE(INDEX[DISP]);
     
     DISP := DISP + COL1;
     IF DISP <= ( totaltocol[3] ) THEN WITH_WRITE(INDEX[DISP]);
     
     DISP := DISP + COL2;
     IF DISP <= ( totaltocol[4] ) THEN WITH_WRITE(INDEX[DISP]);
     
     DISP := DISP + COL3;
     IF ( DISP <= DISPDIR[0].DNUMFILES ) THEN WITH_WRITE(INDEX[DISP]);
     IF CRT THEN sc_goto_xy( 0,y_base+i ) 
            ELSE WRITELN(LIST);
   END; { FOR/WITH }
   
 END;
   
 PRINTSTATS;
 sc_goto_xy(50,23);
 if target_known then write('Destination is ',tname,':');
END; { PRINTENTRIES }

    
{$P }
PROCEDURE LCTOUC( VAR STR:STRING );
var i : integer;
BEGIN
   FOR I := 1 TO LENGTH(STR) DO
      IF not((STR[I]< 'a') or (str[i] > 'z')) then 
         str[i] := chr( ord(str[i])-ord('a')+ord('A'));
end;

procedure read_vid(  u: integer);
var 
    dirent: dentry;
    dnum_ok : boolean;
    
begin
   dirent.dfirstblk := -1;  { set an illegal value for read check }
   UNITREAD(u,dirent,sizeof(direntry),2,0);
   IF IORESULT = 0 THEN
   begin
      if dirent.dfirstblk = 0 then
      begin
         if dirent.dlastblk > 255 then
         begin
            flipword( dirent.f1kind );
            flipword( dirent.f1dnum );
         end;
         with dirent do
         begin
           {if f1last[1] = 0 then dnum_ok := ( f1dnum[0] = 0 ) and
            *                               ( f1dnum[1] <= 77 )
            *               else dnum_ok := ( f1dnum[0] <= 77 ) and
            *                               ( f1dnum[1] = 0 );
           }
            if ( length(dvid)<=0 ) or
               ( length(dvid)> 7 ) or
               ( dfkind <> untypedfile ) 
            then syscom^.unitable^[u].UVID := ''
            else syscom^.unitable^[u].uvid := dirent.dvid ;
          end;
      end
      else syscom^.unitable^[u].uvid := '';
   end
   else syscom^.unitable^[u].uvid := '';
end;
{$p }
function get_unit_number( var volstr: string ):integer;
var
   ok_num : boolean ;
   unum   : integer ;
   
   
   
BEGIN
  get_unit_number := 0;
  unum := 0;
  if volstr='' then volstr := dkvid;
  IF volstr[1] = ':' THEN volstr := DKVID; {DEFAULT VOLUME ID}
  IF volstr[1] = '*' THEN volstr := SYVID; {SYSTEM VOLUME ID}
  
  
  I := POS(':',volstr);
  IF I >0 THEN volstr := COPY(volstr,1,I-1);{ strip all chars following a : }
  
  IF volstr[1]='#' THEN 
     BEGIN  { Standard specification of unit number }
        I := LENGTH(volstr);
        IF I>1 THEN volstr := COPY(volstr,2,I-1)
               ELSE volstr := dkvid ;
     END;
  
  
  I := LENGTH(volstr);
  J := 0;
  K := 1;
  ok_num := true;
  
  WHILE (K<=I)AND ok_num do
    if (volstr[k] in digits) then
    BEGIN
      J := J*10+ORD(volstr[K])-ord('0');
      K := K + 1;
    END
    else ok_num := false ;
  
  IF ok_num and ( j>maxunit ) THEN exit(get_unit_number);
  IF ok_num THEN
     begin
       unum := J;
       if syscom^.unitable^[j].uisblkd then read_vid(j);
     end
    ELSE
      BEGIN             { not unit number - try volume names }
        
        LCTOUC ( volstr ); { ensure all upper case alphabetic chars }
        
        j := 0;
        
        REPEAT  { look for the volume name in the unit table }
          j := j + 1;
          if volstr=syscom^.unitable^[j].uvid then  { match to old name }
            IF syscom^.UNITABLE^[J].UISBLKD THEN read_vid(j) ; { blk vol }
        UNTIL (volstr = syscom^.UNITABLE^[j].UVID)OR( j >= MAXUNIT );


        IF volstr = syscom^.UNITABLE^[j].UVID THEN unum := j {name is true }
        ELSE
          BEGIN    { retry all blocked volumes reading volume name }
            J := 0;
            REPEAT
              J := J+1;
              IF syscom^.UNITABLE^[J].UISBLKD THEN read_vid(j);
            UNTIL (J>=MAXUNIT)OR (volstr=syscom^.unitable^[j].uvid);
            IF volstr = syscom^.unitable^[J].UVID THEN unum := J;
          END;
   end;
   get_unit_number := unum ;
   
end;
{$P }
FUNCTION  GOOD_TARGET:BOOLEAN;


VAR
   OK        : BOOLEAN ;
   ABORT     : BOOLEAN ;
   I         : INTEGER ;


BEGIN
OK := TRUE ; ABORT := FALSE ; THE_SAME := FALSE ;
repeat 
IF NOT TARGET_KNOWN THEN
REPEAT
    sc_clr_line( 0 );
    sc_goto_xy(0,0); 
    WRITE('Enter volume id of destination disk > ' );
    NEWPROMPT := TRUE;
    rdline(TNAME);
    IF TNAME = '' THEN ABORT := TRUE;
    IF NOT ABORT THEN 
      begin
         tar_unit := get_unit_number( tname );
         tname := syscom^.unitable^[tar_unit].uvid;
         if not(syscom^.unitable^[tar_unit].uisblkd) 
         THEN 
         begin
           unitclear(tar_unit);
           dest_is_text := TRUE;
         end  
         else
         BEGIN
           DEST_IS_TEXT := FALSE;
           {$I-}
           unitread(tar_unit,targetdir,(maxdir+1)*sizeof(dir_entry),2,0);
           {$I+}
           OK := IORESULT = 0;
           IF NOT OK THEN DISK_ERROR(CONCAT(TNAME,':'))
           else
           BEGIN
              IF TARGETDIR[0].DLASTBLK > 255 THEN 
              BEGIN
                 TARFLIP := TRUE ;
                 FLIPDIR(TARGETDIR);
              END
              ELSE TARFLIP := FALSE ;
           
              with targetdir[0] do
              if ( length(dvid)<=0 ) or
                 ( length(dvid)> 7 ) or
                 ( dnumfiles   < 0 ) or
                 ( dnumfiles   > 77) or
                 ( dfkind <> untypedfile ) then
              begin
                 sc_clr_line( 0 );
                 sc_goto_xy(0,0);
                 write('No directory on volume for ',TNAME,
                       ': < press return >');
                 read(ch);
                 ok := false ;
              end
              else
              IF dir_unit = tar_unit then
                if dir_offs = tar_offs then
              
              BEGIN
                 sc_clr_line( 0 );
                 sc_goto_xy(0,0);
                 write('Destination is not allowed to be the same as source.',
                       '   <press return>');
                 read(ch);
                 OK := FALSE;
              end;
           END;
        END;
      END;
  UNTIL OK OR ABORT
  ELSE
  BEGIN
     IF NOT dest_is_text then
     BEGIN
       {$I-}
           unitread(tar_unit,targetdir,(maxdir+1)*sizeof(dir_entry),2,0);
       {$I+}
       OK := IORESULT = 0;
       IF NOT OK THEN DISK_ERROR(CONCAT(TNAME,':'))
       else
       BEGIN
          IF TARGETDIR[0].DLASTBLK > 255 THEN 
          BEGIN
             TARFLIP := TRUE ;
             FLIPDIR(TARGETDIR);
          END
          ELSE TARFLIP := FALSE ;
           
           with dispdir[0] do 
           if ( length(dvid)<=0 ) or
              ( length(dvid)> 7 ) or
              ( dnumfiles   < 0 ) or
              ( dnumfiles   > 77) or
              ( dfkind <> untypedfile ) then  ok := false 
           else
           IF TNAME <> TARGETDIR[0].DVID THEN
           BEGIN
              repeat
                 sc_clr_line( 0 );
                 sc_goto_xy(0,0);
                 WRITE('Old dest. was ',TNAME,
                       ':, new dest. is ',targetdir[0].dvid,
                       '  Ok to use new destination? (Y/N) ');
                 read(ch);
              until (ch='N') or (ch='n') or (ch='Y') or (ch='y');
              ok := (ch='y') or (ch='Y');
              if ok then TNAME := TARGETDIR[0].DVID ;
           end;
        END;
  
     END;
     target_known := ok;

  END;

  UNTIL OK OR ABORT ;
  
  TARGET_KNOWN := NOT ABORT ;
  GOOD_TARGET := NOT ABORT ;
  sc_goto_xy(50,23);
  IF TARGET_KNOWN THEN write('Destination is ',TNAME,':      ' );
  
  END;
  
{$P }
FUNCTION UNIQUE_TARG( ST : STRING ) : BOOLEAN ;

VAR
   MATCH      : BOOLEAN ;
   CH         : CHAR;
   I          : INTEGER ;
   NFILES   : INTEGER ;
   

BEGIN
   CH := 'Y'; { INITIALIZE CHARACTER TO CAUSE TRUE RETURN }
   NFILES := TARGETDIR[0].DNUMFILES ;
   I := 0;
   MATCH := FALSE ;
   IF NFILES > 0 THEN 
   REPEAT 
      I := I+1;
      MATCH := ST = TARGETDIR[I].DTID ;
   UNTIL MATCH OR ( I>= NFILES );
   IF MATCH THEN
   BEGIN
      sc_clr_line( 0 );
      sc_goto_xy(0,0);
      WRITE(ST, ' is on destination disk, Remove the old version? (Y/N) ');
      NEWPROMPT := TRUE ; { RESTORE THE PROMPT LINE ON RETURN }

      REPEAT READ(KEYBOARD,CH)
      UNTIL (CH='Y')OR(CH='y')or(CH='N')OR(CH='n')
                    OR (sc_map_crt_command(ch)= sc_escape_key) ;

      IF (CH='Y')OR(CH='y') then
      BEGIN
         targetdir[0].dnumfiles := nfiles - 1 ;
         IF I < NFILES THEN 
         repeat
            targetdir[i] := targetdir[i+1];
            i:= i+1;
         until i >= nfiles ;
      END;
   END;
sc_goto_xy( (COL-1)*20,Y_BASE+ROW-1); { PLACE THE CURSOR }
UNIQUE_TARG := ((CH='Y')OR(CH='y'));
END;

{$P }
function  room_on_target( VAR DIR      : psysdir  ;
                              REQUEST  : INTEGER; 
                          VAR DIRREC   : INTEGER; 
                          var totalblks: integer;
                          var largest  : integer ):BOOLEAN ;

var 
   nextlow  : integer ;
   last     : integer ;
   size     : integer ;
   
   
begin
{   FIND THE LARGEST SET OF CONTIGUOUS BLOCKS }
   
   LARGEST := 0;
   totalblks := 0;
   NEXTLOW := DIR[0].DNUMFILES + 1;
   LAST    := DIR[0].DEOVBLK ;
   REPEAT 
      NEXTLOW := NEXTLOW -1 ; 
      SIZE := LAST - DIR[ NEXTLOW ].DLASTBLK ;
      totalblks := totalblks + size ;
      IF SIZE > LARGEST THEN 
      BEGIN
         DIRREC := NEXTLOW+1 ; {  ENTRY POSITION FOR LARGEST SPACE }
         LARGEST := SIZE ;
      END;
      LAST := DIR[ NEXTLOW ].DFIRSTBLK ;
   UNTIL NEXTLOW <= 0 ;
   ROOM_ON_TARGET := REQUEST <= LARGEST ;
   
END; 



PROCEDURE MOVE_MESSAGE( WDSIZE: INTEGER ) ;

BEGIN
      {******}
      sc_erase_to_eol( 50, 22 );
      sc_goto_xy(50,22);
      WRITE('Move buffer is ', WDSIZE ,' blocks.' );
      {******}
   
      sc_clr_line( 0 );
      sc_goto_xy(0,0);
      WRITE('One moment please, move in progress.  ');
      
      NEWPROMPT := TRUE;
      
END;

{$P }
PROCEDURE MOVE_FILE( DIRPOS:INTEGER ) ;



VAR
   error    : boolean ;
   totalblks: integer ;
   largest  : integer ;
   SIZE     : INTEGER ;
   SOURCE   : INTEGER ;
   DEST     : INTEGER ;
   TEMP     : INTEGER ;
   I        : INTEGER ;
   DIRREC   : INTEGER ;
   BLOCKS   :^integer ; { pointer to memory }
   movblksiz : integer; { size of the move buffer in blocks  }
   
  { MOVE_FILE }
   
BEGIN
i:= varavail( 'DFILE,SCREENOPS,FILEOPS,CALC' );
i:= i - 1024; { leave 2048 bytes of stack }
if i < 0 then i:=0;
movblksiz := ( i div 256 - 1 );
{ if movblksiz > 63 then movblksiz := 63 ;}  { limit size to less than 32767 }
i := varnew ( blocks,movblksiz*256 ) ;
if i = 0 then 
begin 
  pressreturn(' No room for move buffer ');
  exit(move_file);
end;


SIZE := dispdir[DIRPOS].DLASTBLK-dispdir[DIRPOS].DFIRSTBLK ;
IF GOOD_TARGET THEN 
IF NOT DEST_IS_TEXT THEN
BEGIN

 IF UNIQUE_TARG( dispdir[DIRPOS].DTID ) THEN
  IF TARGETDIR[0].DNUMFILES < MAXDIR THEN
  BEGIN 
   IF ROOM_ON_TARGET( TARGETDIR, SIZE, DIRREC ,totalblks, largest ) THEN
   BEGIN
      MOVE_MESSAGE( MOVBLKSIZ );
      { OPEN THE DIRECTORY OF THE TARGET VOLUME FOR NEW ENTRY }
      I := TARGETDIR[0].DNUMFILES + 1;
      REPEAT
         TARGETDIR[I] := TARGETDIR[I-1];
         I := I-1;
      UNTIL I <= DIRREC ;
      
      { MOVE THE DIRECTORY ENTRY TO THE TARGET }
      TARGETDIR[DIRREC] := dispdir[DIRPOS];
      
      { SET THE STARTING BLOCK NUMBER FOR THE FILE ON THE TARGET VOLUME }
      TARGETDIR[DIRREC].DFIRSTBLK := TARGETDIR[DIRREC-1].DLASTBLK ;
      
      { SET THE ENDING BLOCK NUMBER FOR THE FILE ON THE TARGET VOLUME }
      TARGETDIR[DIRREC].DLASTBLK := TARGETDIR[DIRREC].DFIRSTBLK + SIZE ;
      
      { INCREASE THE NUMBER OF FILES ON THE TARGET VOLUME }
      TARGETDIR[0].DNUMFILES := TARGETDIR[0].DNUMFILES + 1;
      
      
      { MOVE THE FILE TO THE TARGET VOLUME }
      SOURCE := dispdir[DIRPOS].DFIRSTBLK;
      DEST   := TARGETDIR[DIRREC].DFIRSTBLK;
      REPEAT
         TEMP := dispdir[DIRPOS].DLASTBLK-SOURCE;
         IF TEMP > movblksiz THEN TEMP := movblksiz;
         {$I- }
           unitread(dir_unit,blocks^,temp*512,source+dir_offs,0);
         {#I+ }
         error := ioresult <> 0;
         IF not error THEN
         BEGIN
            IF TARFLIP THEN FLIPDIR(TARGETDIR);
            TARFLIP := FALSE;
            SOURCE := SOURCE + TEMP;
            {$I- }
              unitwrite(tar_unit,blocks^,temp*512,dest,0);
            {$I+ }
            error := ioresult <> 0;
            IF not error THEN  DEST := DEST + TEMP
              ELSE DISK_ERROR(CONCAT( TNAME,':',dispdir[DIRPOS].DTID ) );
         END
         ELSE DISK_ERROR( CONCAT(INAME,':',dispdir[DIRPOS].DTID) );
         WRITE('.');
      UNTIL (SOURCE = dispdir[DIRPOS].DLASTBLK) OR error ;
      IF not error THEN
      begin
         {$I- }
           unitwrite(tar_unit,targetdir,(maxdir+1)*sizeof(dir_entry),2,0);
         {$I+ }
         sc_goto_xy( (COL-1)*20,Y_BASE+ROW-1); { PLACE THE CURSOR }
         dir_status[dirpos].moved := true;
         with_write( dirpos );
      end;
   END
   ELSE
   BEGIN
      sc_clr_line( 0 );
      sc_goto_xy(0,0);
      WRITE( dispdir[dirpos].dtid,
       ' is ',size,' blocks.  ',largest,' contig. ',totalblks,' total avail.',
       ' <press return>');
      read(ch);
      newprompt := true;
   end;
 end
 else
 begin
    sc_clr_line( 0 );
    sc_goto_xy(0,0);
    write( TARGETDIR[0].DVID,
           ' volume directory is full. <press return>');
    read(ch);
    newprompt := true;
 end;

END
ELSE
BEGIN { OUTPUT DEVICE IS FOR TEXT }
   IF dispdir[DIRPOS].DFKIND = TEXTFILE THEN
   BEGIN
      IF tar_unit = 1
           THEN sc_clr_screen ;
      sc_clr_line( 0 );
      sc_goto_xy(0,0);
      WRITE('Output of ',dispdir[dirpos].dtid,
            ' to ',TNAME,': in progress.');
      IF tar_unit = 1  THEN WRITELN;
      newprompt := true;
      { MOVE THE FILE TO THE TARGET VOLUME }
      SOURCE := dispdir[DIRPOS].DFIRSTBLK+2;
      REPEAT
         TEMP := dispdir[DIRPOS].DLASTBLK-SOURCE;
         IF TEMP > MOVBLKSIZ THEN TEMP := MOVBLKSIZ;
         {$I- }
            unitread(dir_unit,blocks^,temp*512,source+dir_offs,0);
         {#I+ }
         error := ioresult <> 0;
         IF not error THEN
         BEGIN
            SOURCE := SOURCE + TEMP;
            {$I- }
              unitwrite(tar_unit,blocks^,temp*512,dest,0);
            {$I+ }
            error := ioresult <> 0;
            IF not error THEN  DEST := DEST + TEMP
              ELSE DISK_ERROR(CONCAT( TNAME,':',dispdir[DIRPOS].DTID ) );
         END
         ELSE DISK_ERROR( CONCAT(INAME,':',dispdir[DIRPOS].DTID) );
         WRITE('.');
      UNTIL (SOURCE = dispdir[DIRPOS].DLASTBLK) OR error ;
      sc_goto_xy( (COL-1)*20,Y_BASE+ROW-1); { PLACE THE CURSOR }
      dir_status[dirpos].moved := true;
      if not (tar_unit = 1) then with_write( dirpos );
   END
   else pressreturn('File type is not text');

   IF tar_unit = 1  THEN
   BEGIN
     PRINTENTRIES;
     sc_goto_xy(50,23);
     WRITE('Destination is CONSOLE:');
   END;


END;
VARDISPOSE( BLOCKS,MOVBLKSIZ*256); { RELEASE MOVE BUFFER }
END;

{$P }
PROCEDURE GET;

BEGIN
   TARGET_KNOWN := FALSE;
   sc_erase_to_eol( 50, 23 );
   sc_goto_xy(50,23); 
   IF GOOD_TARGET THEN { DUMMY IF TO CARRY THE FUNCTION CALL TO GOOD_TARGET };

end;

{$P }
PROCEDURE CHANGE_FILE( CU:CHAR ; J:INTEGER );


VAR
   CH        : CHAR ;
   ST        : STRING[15];
   
   
   
FUNCTION UNIQUE_FILE : BOOLEAN ;

VAR
   MATCH      : BOOLEAN ;
   CH         : CHAR;
   NROW,NCOL  : INTEGER ;
   

BEGIN
   CH := 'Y'; { INITIALIZE TO CHARACTER TO CAUSE TRUE RETURN }
   I := dispdir[0].DNUMFILES + 1;
   MATCH := FALSE ;
   IF I > 0 THEN
   REPEAT  
      I := I-1; 
      IF (J <> INDEX[I])AND(not dir_status[INDEX[I]].removed) 
       THEN MATCH := ST = dispdir[INDEX[I]].DTID ;
   UNTIL MATCH OR ( I<=1 );
   IF MATCH THEN
   BEGIN
      NCOL := 5 ;
      REPEAT NCOL := NCOL - 1 UNTIL I > TOTALTOCOL[NCOL];
      NROW := I - TOTALTOCOL[NCOL];
      sc_goto_xy((NCOL-1)*20,Y_BASE+NROW-1);
      dir_status[index[i]].removed := true ;
      with_write( index[i] );
      dir_status[index[i]].removed := false;
      sc_clr_line( 0 );
      sc_goto_xy(0,0);
      WRITE('Remove the old version? (Y/N)');
      NEWPROMPT := TRUE ; { RESTORE THE PROMPT LINE ON RETURN }
      sc_goto_xy((NCOL-1)*20,Y_BASE+NROW-1);

      REPEAT READ(KEYBOARD,CH)
      UNTIL (CH='Y')OR(CH='y')or(CH='N')OR(CH='n')
                    OR(sc_map_crt_command(ch) = sc_escape_key   );

      IF (CH='Y')OR(CH='y') then
      BEGIN
         NUMFILES := NUMFILES -1;
         dir_status[index[i]].removed := true ;
         CALC;
         PRINTSTATS;
      END
      ELSE
      WITH_WRITE( index[i] );
       
  END;
sc_goto_xy( (COL-1)*20,Y_BASE+ROW-1); { PLACE THE CURSOR }
UNIQUE_FILE := ((CH='Y')OR(CH='y'));
END;
{$P }
    
    { CHANGE_FILE }
    
 BEGIN
   CASE CU OF 
    
   'C','c':BEGIN
      IF dir_status[j].removed then
      begin
        newprompt := true;
        pressreturn('cannot change a removed file name ');
      end
      else
      begin
   
      ST := dispdir[J].DTID;
      IF (( LENGTH(ST)>5)AND(LENGTH(ST)<15)) THEN
         IF ST[LENGTH(ST)-4] = '.' THEN
           WHILE LENGTH(ST)<15 DO INSERT ( ' ',ST,LENGTH(ST)-4);
      WHILE LENGTH(ST)< 15 DO ST := CONCAT(ST,' ');
      WRITE(ST);
      sc_goto_xy( (COL-1)*20,Y_BASE+ROW-1); { PLACE THE CURSOR }
      I := 1;
      REPEAT
         READ (KEYBOARD,CH);
         key_cmd := sc_map_crt_command( ch );
         IF ((key_cmd = sc_left_key ) or ( key_cmd = sc_backspace_key ))
              AND (I>1)  THEN I := I-1;
         IF (key_cmd = sc_right_key) AND (I<15) THEN I := I+1;
         IF (CH>='a') AND (CH<='z') 
            THEN CH := CHR( ORD('A')+ORD(CH)-ORD('a') );
         
          
         IF NOT(  (CH='?') OR(CH='=') OR(CH='*')    OR
                  (CH=',') OR(CH='$') OR(CH=':')    OR
                  (key_cmd <> SC_Not_legal ) OR EOLN(keyboard)  OR
                  (ORD(CH)> 127)OR
                  (ORD(CH)< ORD(' '))             ) THEN
                  BEGIN
                     ST[I]:= CH;
                     WRITE(OUTPUT,CH);
                     IF I<15 THEN I:=I+1;
                  END;
         sc_goto_xy( (COL-1)*20+I-1 ,Y_BASE+ROW-1); { PLACE THE CURSOR }
      
      UNTIL EOLN(keyboard)OR(key_cmd = sc_escape_key   )
                          OR(key_cmd = sc_etx_key  );
      
      I := POS(' ',ST);
      WHILE I<>0 DO 
      BEGIN
         DELETE(ST,I,1); { REMOVE THE SPACE CHARACTER }
         I := POS(' ',ST)
      END;
      
      IF NOT(CH=syscom^.crtinfo.altmode) THEN 
        IF UNIQUE_FILE THEN
        BEGIN
          DIR_STATUS[J].CHANGED := TRUE ;
          dispdir[J].DTID := ST;
        END;
         
      sc_goto_xy( (COL-1)*20,Y_BASE+ROW-1); { PLACE THE CURSOR }
      WITH_WRITE( J );
   end;
   END;
   
   {$P }
   'U','u':BEGIN
         ST := ORGDIR[J].DTID; 
         IF UNIQUE_FILE THEN
         BEGIN
            IF dir_status[j].removed THEN NUMFILES := NUMFILES +1;
            dir_status[j].removed := false; { RESTORE FILE TO DIRECTORY }
            dir_status[j].changed := false; 
            dispdir[J].DTID := ORGDIR[J].DTID ; { RESTORE NAME IF C(hanged }
            WITH_WRITE( J );
            CALC;
            PRINTSTATS;
         END;
      END;
   END; { OF CASE CU }
END;
    
{$P }
PROCEDURE DELETEFILES;

VAR
   I,J    : INTEGER ;
   
BEGIN
   J := 0;
   IF NUMFILES <> 0 THEN  FOR I := 1 TO NUMFILES DO
   BEGIN
      REPEAT J := J +1 UNTIL not dir_status[j].removed;
      IF J > I THEN dispdir[I] := dispdir[J];
   END;
   
   dispdir[0].DNUMFILES := NUMFILES ;
   if dirflip then 
   BEGIN
      DIRFLIP := FALSE;
      flipdir(dispdir);
   END;
   {$I-}
       unitwrite(dir_unit,dispdir,(maxdir+1)*sizeof(direntry),2+dir_offs,0);
   {$I+}
   IF IORESULT <>0 THEN DISK_ERROR( INAME );
   
END;
{$P }
PROCEDURE MARKENTRIES;
VAR 
  COMPLETE    : BOOLEAN;
  MATCH       : BOOLEAN;
  new_extend  : boolean ;
  extension   : boolean ;
  CH          : CHAR;
  ST          : STRING ;
  chartostr   : string[1];
  I,J,K       : INTEGER;
  NROW,NCOL   : INTEGER;
  rep_factor  : integer;
  
  
{$P }
BEGIN   { MARKENTRIES }

  COMPLETE  := FALSE ;
  NEWPROMPT := TRUE  ;
  extension := false ;
  NEW_EXTEND := TRUE;
  chartostr  := ' ';
  
  
REPEAT { UNTIL COMPLETE 1111111 }
REPEAT { UNTIL COMPLETE 2222222 }
    esc_true := false ;

  
  IF NEWPROMPT THEN 
  if not extension then PROMPT(0,
'<arrows> Remove Change Undo Move Get Edit eXecute ENTER ESC Quit Help Output ?'
               )   else prompt(0,
'Natural Sorted Logical Verify Advance Formfeed                      12 Mar 83'
               );

    NEWPROMPT := FALSE ;
    J :=  INDEX[ TOTALTOCOL[COL]+ROW ];
    XY_ARRAY[ SVOLS_ARY[0] ] := J ;

{*****}
if new_extend then
begin 
  if dispdir[0].dnumfiles > 0 then
  begin
    sc_erase_to_eol(25,1);
    sc_goto_xy(25,1);
    WITH dispdir[J] DO WRITE(DTID,' ':(17-LENGTH(DTID)),
         DLASTBLK-DFIRSTBLK:5,
         DACCESS.DAY:4,'-',MONTHNAME[DACCESS.MONTH],'-',DACCESS.YEAR:2,
         DFIRSTBLK:5,
         DLASTBYTE:5,
         FILETYPENAME[dfkind]:10 );
  end;
  new_extend := false;
end;
{*****}
    sc_goto_xy( (COL-1)*20,Y_BASE+ROW-1); { PLACE THE CURSOR }
    
    
{***  READ THE NEXT COMMAND CHARACTER }
    rep_factor := 0;
    READ(KEYBOARD,CH);
    while ch in digits do
    begin
      rep_factor := rep_factor*10+(ord(ch)-ord('0'));
      read(keyboard,ch);
    end;
    
    key_cmd := sc_map_crt_command( ch );
    
    
repeat
    
    IF key_cmd = sc_up_key THEN IF ROW = 1 THEN ROW := COL_LENGTH[COL]
                                           ELSE ROW := ROW-1;
    IF key_cmd = sc_down_key THEN IF ROW = COL_LENGTH[COL] THEN ROW := 1
                                                           ELSE ROW := ROW + 1;
    IF EOLN(KEYBOARD) THEN IF ROW = COL_LENGTH[COL] THEN
                      BEGIN
                        ROW := 1;
                        IF (COL<4)THEN IF (COL_LENGTH[COL+1]>0)THEN
                                            COL := COL + 1
                                       ELSE COL := 1
                        ELSE COL := 1;
                      END
                      ELSE ROW := ROW + 1;
    IF (key_cmd = sc_backspace_key) or (key_cmd = sc_left_key) 
                    THEN IF COL = 1 THEN
                      IF ROW <= COL_LENGTH[4] THEN COL := 4 ELSE
                      IF ROW <= COL_LENGTH[3] THEN COL := 3 ELSE
                      IF ROW <= COL_LENGTH[2] THEN COL := 2 ELSE
                      COL := 1
                    ELSE COL := COL - 1;
    IF (key_cmd = sc_right_key) OR (CH = TAB)  THEN
                   IF ROW <= COL4 THEN { ROW IS COMPLETE }
                      IF COL = 4 THEN COL := 1 ELSE COL := COL + 1
                   ELSE { ROW IS A PARTIAL, 1,2 OR 3 COLUMNS ONLY }
                      IF ((COL=1) AND (ROW=COL2)) THEN COL := 2 ELSE
                       IF ((COL=2) AND (ROW=COL3)) THEN COL := 3 ELSE
                        COL := 1; { COLUMN THREE WRAPS TO COLUMN ONE }
    IF ( KEY_CMD = SC_NOT_LEGAL ) THEN
                   IF ( CH = HOME_TV ) OR ( CH = HOME_911 ) THEN
                   BEGIN
                      ROW := 1;
                      COL := 1;
                   END;
    
    new_extend := 
       ( key_cmd <> sc_not_legal ) or 
       ( ch = home_tv ) or
       ( ch = home_911 ) or
       ( ch = tab  ) or 
       ( eoln(keyboard)   );
    COMPLETE := ( key_cmd = sc_etx_key ) or ( key_cmd = sc_escape_key);
rep_factor:=rep_factor-1;
until (rep_factor<1) or complete ;

{*** END OF CURSOR POSITIONING COMMANDS }

{$P }
if not(new_extend or ( key_cmd = sc_etx_key   )
                  or ( key_cmd = sc_escape_key   )) then
                  case ch of 
                  
                  
{*** REMOVE FILE PROCESSING }
'R','r':BEGIN
         IF not dir_status[j].removed THEN
         BEGIN
            NUMFILES := NUMFILES - 1;
            dir_status[j].removed := true;
            with_write( j );
         END;
         CALC;
         PRINTSTATS;
       END;
    

{*** SORT AND DISPLAY PRESENT VOLUME ***}
'S','s':begin
         sort := 1;
         sort_dir ;
         printentries;
         new_extend := true;
         row := 1; col := 1;
        end;
        
{*** SORT BY FOUR CHARACTER SUFFIX & FILE NAME ***}
'L','l':begin
         sort := 2;
         suffixsort;
         printentries;
         new_extend := true;
         row := 1; col := 1;
        end;
        
{*** MOVE THE FILE TO A TARGET }
'M','m':
     IF not DIR_STATUS[J].REMOVED THEN MOVE_FILE(J)
      ELSE
      begin
        newprompt := true;
        pressreturn('A REMOVED FILE CAN NOT BE MOVED. ');
      end;

{*** FORMFEED THE PRINTER                         ***}
'F','f':begin
          if target_known then
            if tar_unit = 6 then 
              unitwrite(tar_unit,formfeed,1);
        end;

{*** SET NATURAL ORDER AND DISPLAY PRESENT VOLUME ***}
'N','n':begin
         sort := 0;
         for i:=1 to maxdir do index[i]:= i;
         printentries;
         new_extend := true;
         row := 1; col := 1;
        end;
        
{*** GET A NEW DESTINATION VOLUME }
'G','g':  GET ;
      
   
   
{*** UNDO THE ACTION ( IF ANY ) TAKEN TO DATE ON THIS FILE }
'U','u':CHANGE_FILE( CH, J);
    
{*** refresh the present volume display ***}
'V','v':printentries;

{*** CHANGE THE FILE NAME }
'C','c':CHANGE_FILE( CH, J);
  
  
{*** HELP }
'H','h': help ;
   
   
{*** OUTPUT TO A DEVICE OR FILE }
'O','o':BEGIN 
         DOUTPUT; 
         NEWPROMPT := TRUE 
      END;
   
{*** eXecute the code file, or initiate a monitor input string }
'X','x':begin
   IF dir_status[j].removed then 
   begin
     newprompt := true;
     pressreturn( 'CANNOT EXECUTE A REMOVED FILE.');
   end
   else
   begin
     esc_true := true;
     complete := true;
   end;
   end;

{*** Edit the file specified }
'E','e':begin
   if dir_status[j].removed then
   begin
     newprompt := true;
     pressreturn( 'CANNOT EDIT A REMOVED FILE' );
   end
   else
   begin
                           
     esc_true := true;
     complete := true;
   end;
   end;
          
{*** Quit the directory utility after update of directory prompt }
'Q','q':begin
         esc_true := true;
         complete := true;
        end;
  
{*** Advance to subsiderary volume }
'A','a':begin
          if dispdir[j].dfkind =subsvol then
          begin
            if svols_ary[0] <  max_svol_depth then
            begin
              SVOLS_ARY[0] := SVOLS_ARY[0] +1 ;
              SVOLS_ARY[ svols_ary[0] ] := dispdir[j].dfirstblk + dir_offs ;
              xy_array[ svols_ary[0]] := 1;
              going_up := true ;
              complete := true;
              svols_ary[0] := svols_ary[0] + 1 ; { defeat decrement on exit }
            end
            else
            begin
              pressreturn(' Exceeds SVOL nest depth ' );
              newprompt := true;
            end;
          end
          else
          begin
            newprompt := true;
            pressreturn('Selection "A" must point to SVOL type file');
          end;
        end; { of type 'A' }
end; { of case }
if ( ch = '?' ) or ( ch = '/' ) then 
        begin
          newprompt := true;
          extension := not extension ;
        end
        else  extension := false ;
          
  
UNTIL COMPLETE; { 11111111 }



  TARGET_KNOWN := FALSE ;
  do_marks := dispdir[0].dnumfiles> 0 ; { do marks only if files on original}
  
  IF  ( dispdir[0].dnumfiles > 0 ) THEN
  BEGIN
     I:=1;
     REPEAT 
      with dir_status[i] do
        DO_MARKS:= removed or changed ;
      I:=I+1 
     UNTIL DO_MARKS OR ( I > dispdir[0].DNUMFILES );
     IF DO_MARKS THEN 
     BEGIN 
      REPEAT
       sc_clr_line( 0 );
       sc_goto_xy( 0,0 ); 
       WRITE ('Update directory? (Yes/No/Return)');
       READ ( YESNO );
      UNTIL (YESNO = 'Y')OR(YESNO ='y')OR
            (YESNO = 'N')OR(YESNO ='n')or
            (yesno = 'R')or(yesno ='r');
      newprompt := true ;
      complete := not( (yesno='R')or(yesno='r') );
      DO_MARKS :=  (YESNO = 'Y')or(YESNO = 'y') ;
     END;
  END;
until complete; { 222222222 }
  
if do_marks then 
repeat
  {$I-}
      unitread(dir_unit,targetdir,sizeof(dir_entry),2+dir_offs,0);
  {$I+}
  OK := IORESULT = 0;
  IF NOT OK THEN DISK_ERROR(CONCAT(TNAME,':'))
  else
    with targetdir[0] do
    if NOT ( ( length(dvid)<=0 ) or ( length(dvid)> 7 ) )  then
    begin
      ok :=  disp_dir[0].dvid = targetdir[0].dvid ;
      if not ok then
      begin
        ok := false;
        repeat
          sc_clr_line( 0 );
          sc_goto_xy(0,0); 
          write('Return Volume ',disp_dir[0].dvid,' to #',dir_unit,
                ' Press Space');
          read(ch);
        until ch=' ' ;
      end
    end
    else
    begin
      ok := false;
      repeat
        sc_clr_line( 0 );
        sc_goto_xy(0,0);
        write('Return Volume ',disp_dir[0].dvid,' to #',dir_unit,
              ' Press Space');
        read(ch);
      until ch=' ' ;
    end
      

until ok = true;
         

CASE CH OF 
{*** eXecute the code file, or initiate a monitor input string }
'X','x':begin
     prompt(0,concat('Execute ',dispdir[0].dvid,':',dispdir[j].dtid));
     if dispdir[j].dfkind = codefile then
         chain( concat('I="x', dispdir[0].dvid,':',dispdir[j].dtid,'."' ))
     else
         chain( concat( 'I=',dispdir[0].dvid,':',dispdir[j].dtid));
     esc_true := true;
     complete := true;
   end;

{*** Edit the file specified }
'E','e':begin
     prompt(0,concat('Edit ',dispdir[0].dvid,':',dispdir[j].dtid));
     chartostr[1] := syscom^.crtinfo.linedel;
     chain( concat( 'I="e',chartostr,
                           dispdir[0].dvid,':',
                           dispdir[j].dtid,'"'));
                           
     esc_true := true;
     complete := true;
   end;
          
END;  { of case ch }
IF DO_MARKS THEN DELETEFILES; 
END; 




{$P }
{
*
**
***
****
*****     PRIMARY BLOCK STARTS HERE 
****
***
**
*
}
BEGIN
MEMLOCK('SCREENOPS');
INITIALIZE;

REPEAT
  tar_offs := 0; { should always be 0 }
  
  {***  ACCEPT A VOLUME ID FROM THE USER   ***}
  
  
  REPEAT 
   sc_clr_screen ;
   TNAME := iname;

if SVOLS_ARY[0] = 0 then
begin { 11111111 }
   dir_offs := 0 ; { remove the svol offset if present }
   going_up := true;

   sc_goto_xy(0,2);

   writeln('Volumes presently online:');
   writeln;

   i := 0;
   j := 0;
   l := 0;
     {
          Finds the next blocked volume for output to the screen 
           
     }
     while (j < maxunit) and ( i < 60 )  do
     begin
       j := j+1;
       if syscom^.unitable^[j].uisblkd then
       begin
          read_vid(j);
          IF syscom^.unitable^[j].UVID <> '' THEN
          BEGIN
            sc_erase_to_eol( (i div 20 * 27 ), ( i mod 20 + 4 ) );
            sc_goto_xy( ( i div 20 * 27 ), ( i mod 20 + 4 ) );
            WRITE( j:2 );
            
            WRITE( ':' );
            (*
            IF syscom^.unitable^[j].UISBLKD THEN
              if syscom^.unitable^[j].uvid = syvid then write( ': R ' )
              else
                if syscom^.unitable^[j].uvid = dkvid then write(': P ')
                else WRITE(':   ')
            ELSE WRITE(':   ');
            *)
            WRITE(syscom^.unitable^[j].UVID,
                   ' ':8-LENGTH(SYSCOM^.UNITABLE^[J].UVID));
            WRITE('[',syscom^.unitable^[J].ueovblk:5,']');
            if syscom^.unitable^[j].uvid <> syscom^.unitable^[j].upvid then
              write(syscom^.unitable^[j].upvid);
            i := i +1 ;
          END; { syscom^.unitable^ <> '' }
       end; { syscom^.unitable^[j].uisblkd }
     end; { j< maxunit and i < 80  }

    ok := false;
    sc_clr_line( 0 );
    sc_goto_xy(0,0);
    WRITE('Enter volume id of disk (<ESC>,<RETURN> to end) [',TNAME,'] =>');
    rdline(INAME);
    if iname = '' then iname:=TNAME ;
    IF key_cmd  = sc_escape_key
      THEN EXIT ( dfile );


    ok := false;
    dir_unit := get_unit_number( iname );
end ; { 111111111 }

dir_offs := SVOLS_ARY[ svols_ary[0] ] ; { displacement to svol }


    if ((syscom^.unitable^[dir_unit].uvid <> '' ) and 
         syscom^.unitable^[dir_unit].uisblkd )  then
    begin
    
      {$I-}
         unitread(dir_unit,dispdir,(maxdir+1)*sizeof(direntry),2+dir_offs,0);
      {$I+}
      OK := IORESULT = 0;
      IF NOT OK THEN DISK_ERROR(concat(INAME,':'))
      else
        begin
         if dispdir[0].dlastblk > 255 then 
         begin
            dirflip := true;
            flipdir( dispdir )
         end
         else dirflip := false;
         FOR I := 0 TO DISPDIR[0].DNUMFILES DO
             ORGDIR[I] := DISPDIR[I];
        end;
      
    END;
    if not ok then initentry := false ;
  UNTIL OK ;
    
IF SVOLS_ARY[0] = 0 THEN
BEGIN
    SVOLS_ARY[0] := 1 ; { FIRST ENTRY IS ALWAYS THE PHYSICAL VOL }
    SVOLS_ARY[1] := 0 ; { OFFSET TO PHYSICAL IS ALWAYS ZERO }
END;
 
                      
  if key_cmd <> sc_escape_key     then
  begin
     CRT := TRUE ;
     ALLDONE := FALSE;
     NUMFILES := DISPDIR[0].DNUMFILES;
     J := 1;

     FOR I := 1 TO MAXDIR DO INDEX[I] := I ;

     case sort of
       1: sort_dir;       {alphanumeric sort on file name}
       2: suffixsort;     {alphanumeric sort on four char suffix and file name}
     end;

     


     
     IF NUMFILES > 0 THEN 
       FOR I := 1 TO NUMFILES DO
       begin
         dir_status[i].removed := false;
         dir_status[i].changed := false;
         dir_status[i].moved   := false;
         dir_status[i].swaped  := false;
       end;
     FOR I := NUMFILES+1 TO MAXDIR DO 
       begin
         dir_status[i].removed := true ;
         dir_status[i].changed := false;
         dir_status[i].moved   := false;
         dir_status[i].swaped  := false;
       end;
     CALC;
   
     {*** OUTPUT THE DIRECTORY TO THE CRT SCREEN }
     PRINTENTRIES; { PRINT ALL INFORMATION }
     
     if going_up then
     begin
       going_up := false;
       col := 1;
       row := 1;
     end
     else
     begin
       i := XY_ARRAY[ SVOLS_ARY[0] ] ;
       j:=0;
       repeat j:=j+1 until i = index[j] ;
       COL := 5 ;
       REPEAT
         COL := COL - 1;
       UNTIL J > TOTALTOCOL[COL] ;
       ROW := J - TOTALTOCOL[COL] ;
     end;
     
     
     markentries;
     key_cmd := sc_not_legal ; { insure key not reused }
     IF SVOLS_ARY[0] > 0 THEN SVOLS_ARY[0] := SVOLS_ARY[0] - 1 ;
     
  end;
 UNTIL ESC_TRUE ;
          
END.

========================================================================================
DOCUMENT :usus Folder:VOL23:dict.text
========================================================================================

a
abandoning
abbreviated
abbreviation
abbreviations
abilities
ability
able
abnormally
aboard
about
above
absence
absolute
absurd
accent
accept
acceptable
accepted
accepting
access
accessed
accesses
accessible
accessing
accidental
accomodate
accomplish
accordance
according
accordingly
account
accounted
accounts
accumulate
accumulator
accurate
accurately
accused
achieve
achievements
acid
acknowledged
acquainted
acquires
acronym
across
act
acted
acting
action
actions
activate
activated
activities
acts
actual
actually
ad
adapt
add
added
adding
addition
additional
address
addressed
addresses
addressing
adds
adequate
adequately
adjacent
adjust
adjustable
adjusted
adjusting
adjustment
adjustments
administrative
admiring
admitted
admittedly
adopt
adored
advance
advanced
advantage
advantages
advent
adventure
advertisement
advice
affect
affected
affecting
affects
afflictions
africa
after
afternoon
again
against
age
ages
agitatedly
ago
agreed
agreement
ahead
aid
aided
aids
air
airport
airsick
alarm
alarmed
algebra
algebraic
algorithm
algorithms
alienated
alike
all
allocated
allow
allowed
allowing
allows
almost
alone
along
alphabet
alphabetic
alphabetical
alphanumeric
already
also
alter
alterable
altered
alternate
alternately
alternative
alternatively
alternatives
alters
although
alu
aluminium
always
am
ambiguous
american
among
amortized
amount
amounting
amounts
ample
amplifier
amplitude
amuck
an
analog
analogous
analogy
analysis
analytical
analyze
analyzed
analyzing
anchor
and
and'ed
anding
anger
animations
annihilated
announces
annoyances
annoying
annual
anomalies
anomaly
another
answer
answered
any
anyone
anything
anyway
anywhere
apart
apparent
apparently
appeal
appear
appearance
appeared
appearing
appears
appended
appendix
apple
appliance
appliances
application
applications
applied
applies
apply
applying
appreciable
approach
approaches
appropriate
appropriately
appropriates
april
apt
aqueduct
arbitrarily
arbitrary
arc
archaic
architectural
architecture
architectures
are
area
areas
aren't
arises
arising
arithmetic
arm
armor
around
arrange
arranged
arrangement
array
arrays
arrival
arrive
arrived
arrow
art
article
articles
artifice
as
ascertained
ascribe
ashamed
aside
ask
asked
asks
aspects
assemble
assembled
assembler
assemblers
assembling
assembly
assert
asserted
assertion
assigned
assigning
assignment
assigns
associated
assorted
assume
assumed
assuming
assumption
assumptions
astable
astray
asynchronous
at
ate
atom
atoms
attained
attempt
attempted
attempting
attempts
attention
attributed
auburn
audience
aunt
aunts
author
authoritative
authors
auto
automatic
automatically
automobile
automotive
availability
available
average
averaged
averages
avoid
avoided
avoiding
avoids
await
awaited
awaits
aware
away
axial
baby
bacillus
back
background
backplane
backward
backwards
bacteria
bad
bag
bakery
ball
bane
bar
bare
barely
base
based
bases
basic
basically
basics
basis
batch
batches
bathed
bathroom
bathtub
battery
battle
battles
bc
bcd
be
bear
bears
beautiful
became
because
become
becomes
becoming
bed
bedraggled
bedtime
beef
been
before
began
begin
beginning
begins
begun
behave
behaved
behavior
behind
being
believe
believed
belong
belongs
below
bench
benefit
benevolently
benign
beside
besides
best
better
between
beyond
biased
bibliography
big
billion
billionths
bin
binary
biographies
biography
biological
bipolar
birds
birth
birthday
bishop
bistable
bit
bite
bites
biting
bits
bizarre
black
blamed
blank
blighted
block
blocks
blond
blood
bloodthirsty
blowing
blown
blue
blunders
blurted
board
boards
boats
body
boils
bologna
bolts
bond
bonded
bonding
book
books
boolean
boomed
boots
boring
boron
both
bother
bottom
boule
bounce
bounced
bounces
bouncing
box
boxes
braced
branch
branches
branching
bread
break
breakfast
breaking
breaks
breakwater
breeze
bribes
bridge
brief
briefly
bright
brightness
bring
brings
britain
broad
broke
broken
brother
brought
brown
brushed
bubble
bubonic
buffer
buffers
bugs
build
building
built
bulk
bulky
bureaucratic
buried
burn
burned
burnish
burst
bus
buses
bushes
business
but
button
buy
buying
by
byte
bytes
byzantine
byzantium
c-d
cafe
cafes
calculate
calculated
calculation
calculations
calculator
calculators
call
called
caller
calling
calls
came
can
can't
canal
cannot
canopy
cans
canvas
capabilities
capability
capable
capacitance
capacitor
capacitors
capacity
captured
car
card
cards
care
careful
carefully
careless
carelessness
carriage
carried
carries
carry
carrying
cars
carthage
cascaded
case
cases
cash
cassette
cat
catch
categories
catering
catholic
caught
cause
caused
causes
causing
caution
ccd
cease
ceased
celebrations
center
centers
centimeter
central
century
ceramics
certain
certainly
certainty
chain
chance
change
changed
changes
changing
channel
channels
chapter
chapters
character
characteristic
characterized
characterizes
characters
charge
charged
chariot
charles
chatter
cheap
check
checked
checker
checkers
checking
checkout
checks
cheerfully
chemicals
children
chip
chips
choice
choices
chopped
chore
chores
chose
chosen
christ
christianity
christians
chunk
chunks
church
circle
circles
circuit
circuitry
circuits
circumstances
cities
citizenship
city
civilization
claim
claimed
clamped
class
classed
classes
classification
classified
classify
classroom
clean
cleaned
cleaner
cleanliness
clear
cleared
clearing
clearly
clears
cleaver
clerk
cliffs
climbed
clock
clocked
clocking
clocks
close
closed
closely
closes
closets
closing
closure
cloth
clutter
coast
coat
coated
coats
code
coded
codes
coding
coffee
coil
coincidental
coined
collection
collector
college
color
colors
column
columns
comb
combination
combinations
combine
combined
combining
come
comes
comfort
comfortable
comfortably
coming
command
commands
comment
commented
commenting
comments
commercial
committed
committing
common
commoners
commonly
communication
communications
company
comparator
compare
compared
compares
comparing
comparison
comparisons
compatible
compensated
compiler
compiles
complain
complement
complementary
complemented
complete
completed
completely
completes
completing
completion
complex
complexity
complicate
complicated
comply
component
components
composed
compounds
comprehensive
compression
compromise
computation
computational
computer
computerized
computers
computing
concealing
concentrate
concentration
concept
conceptual
conceptually
concern
concerned
concert
concerts
concise
conclusion
conclusions
concrete
condition
conditional
conditionally
conditions
conduct
conducting
conduction
conductive
conductivity
conductor
conductors
conference
confide
confidence
configuration
configurations
configure
configured
confine
confined
conflict
conflicts
confuses
confusing
confusion
conjunction
connect
connected
connecticut
connecting
connection
connections
connector
connects
consequence
consequential
conservative
consider
considerable
considerably
consideration
considered
consigning
consist
consistent
consisting
consists
console
constant
constantinople
constantly
constants
constraints
construct
constructed
consultant
consumed
consumes
consuming
consumption
contact
contacts
contagion
contain
contained
containing
contains
contamination
contemplated
contended
contention
contents
context
contingent
continual
continually
continue
continued
continues
continuing
continuous
continuously
contradiction
contrast
contributes
control
controlled
controller
controllers
controlling
controls
convenience
convenient
conveniently
convention
conventional
conventions
conversation
conversing
conversion
convert
converted
converting
converts
convey
conveys
convinced
cookbooks
cooked
cookies
cooking
cooks
cope
copied
copies
coping
copious
copy
copying
core
corn
corner
corpses
correct
corrected
correcting
correction
corrections
correctly
correspond
correspondence
corresponding
corresponds
corrupt
cosmopolitan
cost
costs
could
couldn't
count
counter
counterpart
counters
counting
country
counts
coupled
coupling
course
court
cover
coverage
covered
covers
cpu
crane
crash
creased
create
created
creating
creature
credits
crepes
cried
criminal
crimping
critical
crooked
crop
crops
cross
crosses
crowd
crowded
crowds
cruel
cruelly
crusades
crusts
crystal
crystals
cultural
culture
cultures
cumbersome
cup
cure
cured
curiosity
current
currently
currents
curses
curtain
customer
customs
cut
cute
cutting
cycle
cycles
cycling
cylindrical
damage
damaged
dark
darkness
data
date
daughter
day
days
dead
deadly
deal
dealing
deals
dear
death
debounce
debouncing
debris
debugging
december
decide
decided
decimal
decision
decisions
decline
declining
decode
decoded
decoder
decoders
decodes
decrease
decreased
decreasing
decrement
decremented
decrementing
decrements
dedicated
default
defect
defective
defects
deferred
deficiencies
define
defined
defines
defining
definition
definitions
degrades
degree
delay
delayed
delays
delete
deleted
deleting
deletions
deliberate
demeanor
demodulating
demonstrate
demonstrated
demultiplexer
demultiplexers
denotes
denoting
departed
department
departure
depend
dependent
depending
depends
depletion
depositing
depth
derived
describe
described
describing
description
descriptions
descriptive
deserves
design
designate
designated
designates
designation
designations
designed
designer
designer's
designers
designing
designs
desirable
desire
desired
desperation
despite
destination
destinations
destroyed
destroying
destroys
destruction
detail
detailed
details
detect
detected
detecting
detection
determine
determined
determines
determining
devastating
develop
developed
developer
developing
development
device
devices
devised
devoured
devouring
diagnose
diagnosis
diagnostic
diagonal
diagram
diameter
diameters
diamond
dictate
dictates
dictionary
did
didn't
differ
difference
differences
different
differs
difficult
difficulties
difficulty
dig
digit
digital
digits
digression
dim
dime
dimmer
dinner
dip
dip's
direct
direction
directional
directly
directory
directs
dirt
disadvantage
disadvantages
disagree
disagreeable
disagreed
disagreement
disappear
disappeared
disappears
disassembled
disaster
discarded
discernible
discharge
disclosing
disconnected
discontinued
discovered
discrete
discrimination
discuss
discussed
discussing
discussion
discussions
disease
diseases
dishes
disk
disks
disparity
display
displayed
displaying
displays
dispose
disposed
dissent
dissimilar
dissipation
dissolve
distance
distantly
distinct
distinction
distinctions
distinguish
distinguished
distinguishing
distorted
distractedly
distributed
diversion
divide
divided
divides
dividing
division
divisor
dma
dmux
do
documented
does
doesn't
doing
dollar
dollars
don't
done
door
doped
doping
dopings
dormant
dot
dots
double
doubled
doubles
doubling
doubly
doubt
down
downstairs
downtown
downward
dozen
dozens
draft
dragged
dragon
dragons
drain
drained
dramatic
drastic
drastically
draw
drawing
drawn
draws
dread
dress
dressed
dresser
dressers
dried
drilled
drink
drive
driven
driver
drivers
driving
drop
dropped
dropping
drops
droughts
drudgery
drudges
dual
dual-rank
dubious
due
duplicate
duplication
duration
durations
during
duty
dye
dyed
dying
dynamic
dynamics
each
eaprom
eaprom's
earlier
early
ease
easier
easily
east
eastern
easy
eat
eaten
eating
economy
edge
edge-triggered
edges
edit
edited
editing
editor
editor's
editors
effect
effective
effectively
effects
efficient
effort
eight
eight-input
eighteen
either
elapsed
electric
electrical
electrically
electron
electronic
electronics
electrons
element
elements
elevated
elicit
eliminate
eliminated
eliminating
else
elsewhere
embraced
emotional
emperor
emphasize
emphasized
emphasizes
empire
empires
employed
employing
employs
empty
emulate
enable
enabled
enables
enabling
enclosed
encompasses
encountered
encountering
encounters
end
endemic
ending
endlessly
ends
enemies
energies
energy
engine
engineering
english
enhance
enhancement
enough
ensued
ensure
ensures
ensuring
entail
enter
entered
entering
enters
enthusiasm
entire
entirely
entity
entrant
entries
entry
enumerate
enumeration
environment
epidemic
epidemics
eprom
eprom's
equal
equality
equally
equipment
equivalent
equivalents
erasable
erased
erratic
error
errors
escapist
especially
essential
essentially
establish
estimated
etc
etch
etched
europe
evaluating
even
evening
evenly
event
events
eventually
ever
every
everybody
everyone
everything
evil
evolution
evolved
exact
exactly
examine
examined
examines
examining
example
examples
exceed
exceeded
exceeds
except
exception
exceptions
excess
excessive
excessively
exchange
exchanged
excited
excitement
excluding
exclusive
excused
excuses
executable
execute
executed
executes
executing
execution
exempt
exercise
exercised
exerted
exhausted
exhaustedly
exhibit
exhibits
exist
existing
exists
exit
exited
exotic
expand
expect
expected
expend
expensive
expertise
explain
explained
explains
explanation
explanations
explicit
explicitly
exponentially
exponents
exposed
exposition
exposure
expressed
expression
expressions
expunged
extend
extended
extension
extensively
extent
extermination
external
externally
extinction
extra
extraneous
extreme
extremely
extremes
eye
eyes
fabricate
fabricated
fabricating
fabrication
face
faced
fact
factor
factories
factors
fade
faded
fades
fail
failed
failing
fails
failure
failures
fair
fairly
fallen
falling
false
familiar
familiarity
families
family
famines
famished
famous
fans
fantasy
far
farads
farm
farming
farthest
fashion
fast
faster
fastest
father
fault
favorite
favorites
fear
fears
feature
features
february
feed
feedback
feeding
feeds
feel
feelings
feet
fell
fellow
felt
fet's
fetch
fetched
fetches
fetching
feudal
fever
few
fewer
field
fields
fiendishly
fifth
fifty
fight
figure
figures
file
files
fill
filled
filling
film
final
finally
find
finding
finds
fine
fingers
finish
finished
finishes
finite
fire
firmware
first
fish
fit
fits
five
fixed
fixedly
fixture
flag
flagged
flags
flaw
flawless
flea
fleas
fled
flee
flew
flexibility
flexible
flight
flip
flip-flop
flip-flops
flipped
floating
flop
floppy
flops
flotilla
flourished
flow
flowed
flowing
flows
flu
focused
fold
follow
followed
following
follows
food
footnotes
for
force
forced
forcibly
forcing
foreign
forgery
forget
forgetful
forgot
forgotten
forking
form
formal
formalized
format
formats
formatting
former
formerly
forming
forms
forth
fortified
fortunately
forum
forward
found
four
four-bit
four-input
fourteen
fourteenth
fourth
fraction
fragment
fragments
frame
france
free
free-running
freed
freeing
freeway
french
frequency
frequent
frequently
fresh
from
front
fruit
fruitless
frying
fulfilled
full
fully
fun
function
functional
functioning
functions
fundamental
fundamentals
furnish
furnishes
furnishing
further
furthermore
fuse
fuses
future
gains
game
games
garden
gas
gate
gated
gates
gathered
gating
gauge
gave
general
generality
generalized
generally
generate
generated
generates
generating
generation
generations
generator
gently
geometric
geometrically
germanic
get
gets
getting
giggle
giggling
girl
girls
give
given
gives
giving
glad
glanced
glances
glaringly
glass
glitch
glitches
glory
go
goal
goals
god
goes
going
gold
gone
good
goods
got
govern
government
governmental
grabs
gradually
graduating
graduation
grain
granaries
grandchildren
grapes
graphic
graphics
graphs
grating
great
greater
greatest
greatly
greedy
greek
grew
grid
grocery
gross
ground
group
grouping
groups
grow
growing
grows
growth
grudgingly
guarantees
guess
guest
guilford
guilty
guys
habit
habitually
hacked
had
hadn't
hair
half
hall
hallucinations
halt
halting
halve
halves
halving
hamburger
hamburgers
hand
handcrafted
handing
handle
handled
handles
hands
handsome
hang
happen
happens
happy
hard
harden
hardened
hardly
hardware
harm
harmless
harsher
harvard
harvest
has
hash
hastened
hated
have
haven't
having
hazardous
he
head
headache
headaches
headed
heads
heard
heart
heat
heating
heavier
heavily
heavy
heels
height
held
help
helped
helpfully
helping
helpings
helps
hence
her
herd
here
here's
heresy
herself
hertz
hesitate
hesitated
hesitation
hex
hexadecimal
hey
hi
hidden
high
higher
highest
highly
him
himself
hints
his
historical
history
hobbyist
hog
hold
holders
holding
holds
hole
holes
home
homesick
homework
honest
honey
honor
hope
hoped
hopefully
hopeless
horrible
host
hosts
hot
hour
hours
house
household
how
however
huge
hugged
human
humanitarian
humans
humorous
hundred
hundreds
hung
hungry
hunt
hunting
hurried
hurriedly
hurry
hurt
hurtling
husband
hush
hydraulic
hypothesis
hypothesize
hypothetical
hysteresis
i
i'd
i'll
i'm
i've
i/o
ibm
ic
ic's
idea
ideal
ideally
identical
identically
identified
identifies
identify
idiosyncrasies
idolized
if
ignition
ignorance
ignore
ignored
ignores
ignoring
illness
illusion
illustrated
illustrates
illustrating
illustration
image
images
immediate
immediately
immense
immune
immunity
impact
impasse
imperative
imperial
imperiously
implement
implementation
implemented
implementing
implication
implicit
implicitly
implied
implies
import
importance
important
impose
impossible
imprinting
improvement
improvements
impulse
impulsive
impunity
impure
impurities
impurity
in
inaccurate
inadequate
inadequately
inadvertently
inappropriate
inch
inches
incident
incidental
incidentally
incidents
incisively
include
included
includes
including
inclusive
inconvenience
incorporated
incorrect
incorrectly
increase
increased
increases
increasing
increment
incremented
incrementing
increments
incubation
indeed
indefinitely
independent
independently
indeterminate
index
indexed
indexing
india
indicate
indicated
indicates
indicating
indication
indications
indirect
indirectly
individual
individually
inductor
industrial
industry
inequalities
inevitable
inexpensive
infect
infected
inflexible
informal
information
informative
informed
informs
inhabitants
inherent
initial
initialization
initialize
initialized
initially
initiate
initiated
injected
injury
inner
inoperable
input
inputs
insert
inserted
inserting
insertion
insertions
insidious
insight
insignificant
inspection
instability
instant
instantaneous
instantly
instead
institution
instruction
instructions
instruments
insulated
insulating
insulation
intake
integer
integers
integral
integrated
integration
intended
intensifies
intent
intentions
interactions
interactive
interconnect
interconnected
interesting
interface
interfaced
interfacing
interior
intermediate
internal
internally
international
interpretation
interpreted
interpreter
interrelated
interrupt
interrupted
interrupts
intertwined
interval
intervals
intervening
into
introduce
introduced
introduces
introducing
introduction
invasion
invention
inventory
inversion
inverted
inverter
inverters
inverting
involve
involved
involves
involving
ironed
irregular
irrelevant
irretrievably
is
isn't
isolate
isolated
isolates
isolating
isolation
issue
issues
it
it's
italy
item
items
iterations
its
itself
j-k
jeans
jersey
jews
job
jobs
joined
journal
judge
jump
jumping
jumps
junk
jury
just
justice
keep
keeping
kept
key
keyboard
keyboards
keypad
keys
kid
killed
killing
kind
kinds
kingdoms
kitchen
knew
knight
knights
knit
knitted
knitter
knitters
knitting
knob
knock
know
knowing
known
kohm
label
labeled
labels
labor
laboratories
laboratory
lack
lacking
lacks
lacquer
laden
ladies
lady
lag
lame
lamp
lamps
land
landing
lands
language
languages
large
largely
larger
largest
last
lasted
lasting
lasts
latch
latched
latches
latching
late
lately
later
latter
laugh
law
layer
layers
lead
leads
leak
leakage
leaned
leans
least
leave
leaves
leaving
left
legal
legally
legends
legislative
legitimate
length
lengths
lengthy
lesions
less
let
let's
letter
letters
letting
level
levels
lies
life
lifetimes
lifo
lifts
light
lightly
lightning
lights
like
likely
liking
limit
limitation
limitations
limited
limits
line
linear
lines
lingered
linked
list
listed
listen
listening
listing
lists
lit
literal
literally
litters
little
live
lived
lives
living
load
loaded
loader
loading
loads
local
localize
localizing
located
location
locations
lock
locked
locking
locks
logic
logical
logically
long
long-distance
longer
look
looked
looking
looks
loop
looping
loops
loose
loosely
loosing
lord
loses
losing
loss
losses
lost
lot
loud
louder
loved
low
lower
lowest
lsi
luck
luggage
lunch
lymph
machine
machinery
machines
macro
made
magic
magistrate
magistrates
magnetic
magnetically
magnitude
maidens
mailing
mails
main
mainframe
maintain
maintained
maintaining
major
majority
make
makes
making
malfunction
mall
man
manage
managed
mandated
mandates
manifold
manipulate
manipulated
manner
manorial
manorialism
manors
manual
manufacture
manufactured
manufacturer
manufacturing
manuscript
many
map
mapped
maps
mark
marked
market
markets
marks
marshes
mask
masked
masking
mass
master
master-slave
match
matches
material
materials
mathematical
mathematics
matter
matters
mature
maximum
may
maybe
me
meagre
meal
mealtimes
mean
meandering
meaning
meaningful
meaningless
means
meant
meantime
meanwhile
measure
measured
measurement
measurements
measures
measuring
mechanical
mechanism
mediterranean
medium
meet
meeting
meets
member
members
memorable
memories
memory
men
mental
mention
mentioned
mentioning
menu
merchant
mercifully
merged
merits
message
messages
met
metal
metalization
metallic
method
methods
micro
microcode
microcoding
microcomputer
microcomputers
microfarad
microprocessor
microsecond
microseconds
middle
midway
might
miles
military
milk
million
millions
millionths
millisecond
milliseconds
mimic
mind
mindlessly
minds
mine
mineral
minicomputer
minicomputers
minimize
minimized
minimum
minor
minus
minuscule
minute
minutes
mirror
miscellaneous
miserably
miss
missed
missing
misspelled
mistake
mistakes
mitten
mixed
mnemonic
mnemonics
mob
mode
model
models
moderately
modern
modes
modification
modifications
modified
modify
modulating
moment
momentary
moments
monday
money
monitor
monitoring
monitors
monostable
monotonous
monstrosity
months
monuments
more
morning
mortality
mos
most
mostly
mother
motion
motions
motive
motors
mound
mounted
mouth
move
moved
movement
moves
movies
moving
mph
msi
much
mulled
multi
multiple
multiplexed
multiplexer
multiplexers
multiplexing
multiplication
multiplied
multiply
multiplying
murmured
museums
musical
musicians
must
muttering
mux
my
myriad
myself
mythology
name
named
namely
names
nand
nand's
nanosecond
nanoseconds
narrow
nasty
natural
nature
near
nearby
nearest
nearly
nears
neatly
necessarily
necessary
necessitate
neck
need
needed
needles
needs
negative
neighboring
neither
nerve
nerves
nervous
nested
nesting
net
network
networks
neumann
never
nevertheless
new
newer
next
nice
nicely
nicer
night
nightgown
nil
nine
ninth
no
nobles
nod
nodded
nodes
nods
noise
noisy
nominal
nonconducting
nonconductive
none
nonetheless
noninverted
noninverting
nonresistant
nonsense
noodles
nor
normal
normally
north
northern
nose
not
notable
notation
notations
note
noted
nothing
notice
noticing
notified
notify
nouns
novel
novels
novice
now
nowhere
npn
nuclear
number
numbered
numbering
numbers
numeral
numerals
numeric
numerically
numerous
nursery
o'clock
obey
obeyed
object
objectionable
objects
obscures
observed
obsolete
obtain
obtained
obtaining
obtains
obvious
obviously
occasional
occasionally
occupied
occupies
occupy
occur
occurrence
occurrences
occurring
occurs
octal
october
odd
of
off
offended
offending
offered
offers
offices
offset
offshoot
often
oh
ohm
ohms
ok
old
older
omens
omitted
on
once
one
one's
onion
only
onset
onto
opcode
open
opened
opening
opens
operand
operands
operate
operated
operates
operating
operation
operational
operations
operator
opinion
opinions
opportunity
opposed
opposing
opposite
optical
optimized
optimum
option
optional
or
ordained
order
ordered
orderly
orders
ordinary
organization
organized
orientation
oriented
origin
original
originally
originated
originates
oscillating
oscillator
oscillators
oscilloscope
ostensibly
other
others
otherwise
ouch
ought
our
out
outbreak
outbreaks
outcome
outdoor
outer
outlet
outline
outlined
outliving
outlook
output
outputs
outside
outskirts
oven
over
overall
overcome
overflow
overpopulated
overseer
oversimplified
overtook
overview
overwritten
own
owner
owning
oxide
paces
package
packaged
packages
packaging
packet
pad
pads
pagan
pagans
page
paged
pages
painstaking
pair
pairs
palace
palm
pancakes
panel
panels
pantheon
pants
paper
paperwork
paragraph
paragraphs
parallel
parallel-in
parallel-out
parameters
parents
paris
parity
park
parlance
part
partially
participation
particular
particularly
particulars
partition
partitioning
parts
pascal
pass
passed
passes
passing
past
pastries
patently
path
paths
patience
pattern
patterns
pay
pc
peace
peak
peas
peasant
peculiar
peg
pelted
penal
penalty
pencil
pencils
penguin
people
peoples
per
perceived
percent
percentage
perceptible
perfectly
perform
performance
performed
performing
performs
perfume
perhaps
period
periods
peripheral
permanent
permanently
permit
permits
permitted
perpetuate
perpetuation
persia
persistent
person
personal
personalities
personality
perspective
pestilence
phase
philosophies
philosophy
phosphorus
photo
photographic
phrase
physical
physically
physician
physicist
physics
pick
picked
picks
picky
picture
pictures
piece
pieces
piled
pin
pink
pins
pipelining
pitfalls
pizza
pla's
place
placed
places
placing
plague
plagues
plan
plane
planned
planning
plans
plant
play
playing
plays
plaza
please
plot
plotted
plotter
plug
plus
pneumatic
pneumonic
pnp
pocket
pocketbook
point
pointed
pointer
pointers
pointing
points
polarities
pole
polish
political
polled
poor
poorer
poorly
pop
popped
popping
pops
populace
popular
popularity
population
populations
port
portion
portions
portrayed
ports
posing
position
positional
positions
positive
possibilities
possibility
possible
post
pot
potatoes
potential
pour
poured
powder
power
powerful
powers
practical
practically
practice
prairie
praise
preceding
precise
precisely
precision
preclude
precludes
predecessor
predecessors
predetermined
predict
predicted
prediction
predominant
preempted
preferred
prefixed
prefixes
preliminary
prepare
preparing
presence
present
presentation
presented
presents
preserved
preset
presetting
press
pressed
presses
pressure
presumably
pretty
prevailing
prevalent
prevent
preventative
prevented
previous
previously
price
priced
prices
primarily
primary
prime
primitive
princess
princeton
principle
principles
print
printable
printed
printer
printers
printing
prints
prior
priority
private
prizes
probability
probable
probably
probe
probing
problem
problems
procedure
procedures
proceeds
process
processed
processes
processing
processor
processors
procrastinator
produce
produced
produces
product
production
productively
program
programmable
programmed
programmer
programmer's
programmers
programming
programs
progress
progressed
project
prolonged
prom
promising
prompted
prompts
prone
proofreading
propagate
propagation
proper
properly
properties
property
proportion
proportional
propose
protect
protected
protection
protocol
prototype
proud
proved
provide
provided
provides
providing
provision
pseudo
psw
public
published
publishing
pull
pulled
pulling
pulse
pulsed
pulses
punch
punching
punishment
puppet
purchase
pure
purified
purl
purpose
purposes
purse
pursuing
push
pushed
pushes
pushing
pustules
put
puzzled
quad
quadrupled
qualify
quality
quantities
quantity
quarter
quartz
question
questioned
questioningly
questions
quiche
quickly
quiet
quit
quite
quits
quotient
r-s
rabbit
race
races
radio
raging
raised
raises
raising
ram
ran
random
randomly
range
ranged
ranges
ranging
rank
ranking
rapid
rapidly
rare
rarely
rat
rate
rates
rather
ratio
rats
raw
rays
reach
reached
reaching
react
read
read-only
readable
reader
readers
reading
readings
reads
ready
real
reality
realize
realized
really
reaper
reason
reasonable
reasonably
reasoning
reasons
reassembled
rebelling
rebirth
rebuilding
rebuke
recall
recaptured
recapturing
received
receiver
recent
recently
reception
reciprocal
reclaim
recognition
recognizable
recognize
recognizes
reconfiguring
recorders
recording
records
recover
recovered
recreate
recreated
rectangles
rectangular
rectify
recuperated
recursion
recursive
red
redesign
redisplay
redrawn
reduce
reduced
reduces
reduction
redundancy
redundant
reels
refer
reference
referenced
references
referred
referring
reflect
reflected
reflecting
reflects
reformation
refresh
refreshed
refreshment
refute
regaining
regarded
regarding
regardless
region
regions
register
registers
regular
reign
reinforces
related
relation
relationship
relative
relatively
relax
relaxes
relay
relays
relegated
relevant
reliability
reliable
reliably
relies
religion
religions
reloaded
remain
remainder
remained
remaining
remains
remarkably
remarking
remember
remembering
remove
removed
removes
removing
renaissance
repaired
repeat
repeated
repeatedly
repeats
repels
repetitive
replace
replaced
replacement
replaces
replacing
replica
replied
replying
report
reporting
represent
representation
representative
represented
representing
represents
repressed
reproduced
reproduction
reprogram
reprogrammed
reprogramming
request
requested
require
required
requirement
requirements
requires
requiring
requisite
rescues
research
reserve
reserved
reset
resets
resetting
reside
resides
resist
resistance
resisted
resistor
resistors
resolved
resonant
resorting
respectively
respond
responding
response
responses
responsible
rest
restricted
restriction
restrictions
result
resulted
resulting
results
resume
retained
retested
retraced
retrieved
retrieves
return
returned
returning
returns
revenue
reverse
reversed
reviewer's
revising
revitalize
revolution
rewrite
rewriting
rewritten
ridden
right
ring
rinsed
ripple
ripple-carry
rippled
ripples
rise
rising
river
robot
robots
rockwell
rodent
rodents
role
roll
rolls
rom
rom's
roman
romance
romantic
roof
room
roommate
rooms
rooted
roots
roster
rotten
rough
roughly
round
rounds
route
routes
routine
routinely
routines
row
rows
rudimentary
ruffled
rule
ruled
rules
rummages
run
running
runs
rush
safely
safer
safety
said
sailors
sake
sale
salutary
same
sample
sampled
sanctity
sandwich
sandy
sanitation
sat
satellite
save
saved
saves
saving
saw
say
says
scale
scandalous
scanners
scarcity
scarf
scattering
scene
schematic
scheme
schmidt
school
schottky
sciences
scope
score
scores
scraping
scratch
scratched
screamed
screen
scribed
sea
search
searched
searches
searching
season
seated
seats
secluded
second
seconds
secret
secretary
section
sections
security
see
seeing
seem
seemed
seemingly
seems
seen
seesaw
segment
segments
seldom
select
selected
selecting
selection
selector
sell
selling
semblance
semicolon
semiconductor
senator
senatorial
send
sends
senior
sense
sensitive
sensors
sent
sentence
sentences
separate
separated
separation
sequence
sequences
sequential
sequentially
serial
serial-in
serial-out
serially
series
servants
serve
serves
services
serving
set
sets
setting
settle
setup
seven
seventeen
several
severe
sex
shadow
shakes
shaking
shall
shape
share
shared
shares
sharing
sharp
she
she'll
sheer
shelf
shepherding
shift
shifted
shifts
shining
ship
shipment
shipped
shirt
shirts
shock
shocked
shone
shop
shopping
short
shortages
shorted
shorter
shorting
shorts
should
shouldn't
shouted
show
showed
showing
shown
shows
shrinks
shuffled
shut
shyly
sick
side
sighed
sightseeing
sign
signal
signaling
signals
signed
significant
significantly
silence
silicon
silver
similar
similarities
similarly
simple
simplest
simplified
simplify
simply
simultaneous
simultaneously
since
sincerely
singer
single
sipped
sit
sits
sitting
situation
situations
six
sixteen
sixteen-bit
sixteenth
sixth
size
sized
sizes
skew
skewed
skilled
skim
skin
skipped
skirt
skirts
slammed
slash
sleep
sleeping
sleeplessness
slice
sliced
slices
slid
slight
slightest
slightly
slobbering
slop
sloth
slow
slowdown
slowed
slower
slowest
slowing
slowly
slows
small
smaller
smile
smoothly
snack
so
soaked
sobbing
social
sock
socket
soda
softly
software
solder
soldered
soldering
solely
solution
solved
solvent
some
somehow
someone
someplace
something
sometime
sometimes
somewhat
somewhere
son
sons
soon
sorcery
sorry
sort
sorted
sorting
sorts
sound
sounding
soup
source
sources
souvenir
space
spacing
spain
span
spare
sparse
speak
speaker
speaking
speaks
special
specialized
specially
specialties
specific
specifically
specified
specifies
specify
specifying
speech
speed
spell
spelled
speller
spelling
spend
spending
spends
spent
spike
spikes
spite
splash
split
splitting
spoke
spoken
spot
spotlight
spread
spring
spurring
square
squarely
squeeze
ssi
stability
stable
stack
stacks
stadium
stage
stages
stale
stammer
stand
standard
standardized
standards
standing
stands
star
stared
staring
stark
start
started
starting
startling
starts
starved
starving
state
statement
statements
states
static
station
statistical
stature
status
staying
steady
steak
step
stepped
steps
still
stitch
stitches
stop
stopped
storage
store
stored
stores
storing
stove
straight
straightaway
strangle
stray
stream
streets
strengthen
stress
stretches
stricken
strict
strictly
strike
strikes
string
stringent
stripping
strobe
strobes
stroke
strokes
strong
structure
structures
student
study
stuff
stuffed
stupid
style
subject
subjects
submit
subroutine
subroutines
subscript
subsequent
substantially
substitute
substitutes
subsystem
subtle
subtopic
subtract
subtracted
subtracting
subtraction
subtractions
subtracts
succeed
succeeding
success
successful
successfully
succession
successive
successively
succinct
succumbed
such
suede
suffer
suffered
suffers
sufficient
suffixes
suggested
suggestion
suggestions
suitable
suitcase
suitcases
suited
suits
sum
summarized
summarizes
summary
summer
superstitions
supervision
supervisor
supervisors
supplied
supplies
supply
supplying
support
supported
supporting
suppose
supposed
sure
surface
surmised
surplus
surprise
surprisingly
surrounded
surrounding
survive
suspect
suspicion
swallow
swallows
swapped
swapping
sweater
swelling
switch
switched
switches
switching
symbol
symbolic
symbolically
symbolize
symbols
symmetric
symphony
symptoms
synchronize
synchronized
synchronous
synonymous
synthesis
system
systematic
systems
tab
table
tables
tabular
tabulated
tabulation
tail
tailored
take
taken
takes
taking
tale
talk
talked
talkers
tall
taller
tape
target
tarry
task
tasks
tax
taxation
taxes
taxi
tea
teacher
teachers
tears
teased
teasing
technical
technically
technique
techniques
technology
tedious
teenagers
teens
telephone
teletypewriter
television
tell
telling
temperature
temperatures
temporary
ten
ten's
tend
tens
tenth
term
termed
terminal
terminals
terminate
terminated
terminates
terminating
terminology
terms
terrific
terse
test
tested
tester
testers
testing
text
textbook
texts
than
thank
thankless
thanks
that
that's
the
their
them
themselves
then
theorized
theory
therapeutic
therapy
there
there's
therefore
thermally
these
they
they're
thin
thing
things
think
thinks
third
thirds
this
thoroughly
those
though
thought
thoughts
thousand
thousands
threat
three
three-input
threshold
thresholds
threw
through
throughout
throwing
thrown
thumb
tic
tie
tied
ties
tight
time
timed
timeliness
times
timing
tiny
tip
tipped
tirade
tired
title
to
today
together
toggle
toggled
told
tomography
tomorrow
tone
too
took
tool
tools
top
topic
topics
tops
torture
tosses
total
totem
touch
touches
touring
toward
tower
town
towns
toy
trade
trading
trailing
train
traits
transactions
transducer
transfer
transferred
transferring
transfers
transform
transformed
transformer
transforming
transistor
transistors
transition
transitions
translate
translated
translates
translating
translation
translator
transmission
transmits
transmitted
transmitter
transmitting
transparent
transportation
trapped
trash
traumatic
travel
traveled
travels
traversed
traverses
treat
treated
treating
treats
treaty
tree
trees
triangle
tribes
tribute
tricky
tried
tries
trigger
triggered
triggering
triggers
trio
trip
triple
trips
trivial
trot
trouble
troubleshoot
troublesome
true
truncated
truth
try
trying
ttl
tube
tubes
turbulence
turn
turned
turning
turns
twelve
twenty
twice
twitch
two
two-input
tying
type
typed
types
typewriter
typewriters
typewritten
typical
typically
typing
typist
typographical
uart
uart's
ubiquitous
ultimate
ultimately
ultra
unable
unaffected
unaltered
unambiguous
unambiguously
unattractive
unblown
unburied
unchanged
uncivilized
uncluttered
uncommon
uncomplicated
unconditional
uncontrolled
undefined
under
understand
understanding
understood
undertaken
undertaking
undesirable
undetected
undisturbed
uneconomical
unexposed
unfavorable
unfortunately
unicorn
unicorns
unidirectional
unified
unique
uniquely
unit
unite
united
units
universal
universally
universe
unjust
unknown
unless
unlike
unlikely
unpacked
unpredictable
unpredictably
unquestionably
unrelated
unruly
unsigned
unsuccessful
until
untouched
unused
unusual
unwanted
unwary
unwholesome
up
up-down
updated
upon
upper
upraised
upstairs
upward
us
usable
usage
use
used
useful
usefulness
user
user's
users
uses
using
usual
usually
utilized
utilizes
utter
vacuum
vague
vaguely
valid
valuable
value
values
valves
vandals
variable
variables
variance
variation
variations
varied
varieties
variety
various
vary
vast
vegetable
velocity
verbiage
verification
verified
vermin
versa
version
versions
very
vessel
vessels
via
vice
victim
video
view
viewed
viewpoint
vih
vil
villas
vineyard
vintage
violates
violence
violet
virtual
virtually
virulence
virulent
visible
visibly
vital
voh
voice
voices
vol
volatile
volition
voltage
voltages
volume
volumes
wafer
wafers
wait
waited
waiting
walk
walked
walking
walks
walls
want
wanted
wants
warm
was
washed
washstands
wasn't
waste
wasted
watching
water
watt
wave
waveform
waveforms
way
ways
we
we'll
we're
we've
weak
wealth
wealthy
wear
wearing
weather
weekend
weeks
weight
weights
welcome
welded
welfare
well
went
were
western
what
what's
whatever
when
where
whether
which
while
whim
whispered
white
who
whole
whom
whose
why
wide
widely
wider
widespread
widgets
width
wife
wild
will
win
winding
window
winter
wire
wires
wiring
wisdom
wish
with
within
without
withstanding
woman
won't
wonder
wondered
word
wording
words
wore
work
worked
workers
working
works
world
worried
worry
worse
worst
would
wouldn't
wow
writable
write
writes
writing
written
wrong
wrote
xnor
xor
xor's
yarn
yawning
yea
year
yearly
years
yelled
yelling
yes
yesterday
yet
yield
yields
you
you'll
you're
your
yours
yourself
zero
zero's
zoom
zoomed

========================================================================================
DOCUMENT :usus Folder:VOL23:iodoc.text
========================================================================================

                        IOUNIT and IOTEST

        IOUNIT is intended to read and write text files.  It
includes replacements for the standard procedures READ, WRITE,
READLN, and WRITELN which run 5 to 10 times faster than the 
standard procedures. IOTEST illustrates the use of IOUNIT and
allows a direct comparison to be made between the fast
procedures and the standard procedures.

        Before using IOUNIT, use IOTEST to send a text file to
disk using both the fast and standard procedures, then run a
source compare to ensure that the files are identical. Note that
the input and output file lengths may not be equal; WRITECHAR
and WRITELINE minimize file length by packing and by using DLE
expansions only if required.

OPENING FILES
        IOUNIT includes the functions RESETFILE and
REWRITEFILE, which provide a minimal user interface for opening
files.  Both functions expect a string containing a filename and 
assume a text file is to be opened. The default volume is
assumed unless otherwise specified.  A "dot" (".") is assumed
to delimit a file extension.  If the filename does not contain a
dot, and a colon (":") is not the last character in the filename
(as in PRINTER:), then ".TEXT" is appended to the filename.

        I/O checking is turned off while an attempt is made to
open the file.  If the attempt is successful, the functions
return TRUE. If the attempt fails, a new filename is requested
and the process repeats.  If no filename is supplied (just a
return was entered) the functions return FALSE and it is up to 
the calling procedure to take appropriate action.  In any case,
the filename is updated to reflect the latest filename to be
entered.

        PRINTER: and CONSOLE: are both legal. If drive #5
contains volume WRK: with the files TRIER.TEXT and TRIER.BACK
then #5:TRIER.TEXT, and WRK:TRIER.BACK are both legal.  If the
prefix is WRK: then TRIER.TEXT, TRIER.BACK, and TRIER are
also legal, but TRIER will get TRIER.TEXT. SYSTEM.WRK.TEXT
must be entered in its entirety, and a filename with no
extension cannot be accessed.

READING FILES
        The procedure READLINE returns the next string in a 
textfile.  It also sets EOFFLAG to TRUE if the string is the 
last string in the file.  The textfile is read using BLOCKREAD.  
A string is isolated from the blockread buffer, a DLE sequence 
is expanded to the required number of spaces, and the string is 
placed in a buffer.  Subsequent calls to READLINE get the string 
from the buffer and refill the buffer with the next string from 
the file.

        The procedure READCHAR returns the next character from 
the string buffer.  It also sets EOLNFLAG to true if the 
character is the last character in the line.  READLINE must be 
called in order to refill the buffer with the next string from 
the file.

WRITING FILES
        The procedure WRITECHAR simply places the character to 
be written in a buffer and returns.  The procedure WRITELINE 
converts any leading spaces to a DLE sequence and places the 
resulting string in a blockwrite buffer.  If the string will 
overflow the blockwrite buffer then the blockwrite buffer is 
padded with nulls and written to the destination before the new 
string is added.

        The procedure CLOSEOUTFILE pads the blockwrite buffer 
with nulls, writes it to the destination, then closes and locks 
the destination file.

        Because the output file is written a block at a time, 
output to the CONSOLE: or PRINTER: comes in block-sized chunks.  
This could be avoided by using a UNITWRITE on each string that is 
going to these destinations, at the expense of slowing output to
a disk file because of the additional overhead involved in 
testing for the destination type.

                                CR


========================================================================================
DOCUMENT :usus Folder:VOL23:iotest.text
========================================================================================


PROGRAM IOTEST;

{ Author:  Charles Rockwell, Microlog, Box 116, Guilford CT, 06437. }

USES IOUNIT;
(* This construct assumes IOUNIT.CODE resides in SYSTEM.LIBRARY *)

VAR 
    SOURCE: STRING[20];                   (* INPUT TEXT FILE NAME *)
    INTEXT: TEXT;                         (* INPUT TEXT FILE *)
    DEST: STRING[20];                     (* OUTPUT TEXT FILE NAME *)
    OUTTEXT: TEXT;                        (* OUTPUT TEXT FILE *)
    CH: CHAR;
    S: STRING;
    OKFILE: BOOLEAN;

BEGIN (* IOTEST *)
  WRITELN;
  WRITELN;
  WRITELN('IOUNIT benchmark');
  WRITELN;
  WRITELN;
  WRITE('Input file name ? ');
  READLN(SOURCE);
  WRITELN;
  OKFILE := RESETFILE(SOURCE);
  IF NOT OKFILE
    THEN
      EXIT(PROGRAM);
  WRITELN('Test of fast character I/O');
  WRITE('Output file name ? ');
  READLN(DEST);
  WRITELN;
  OKFILE := REWRITEFILE(DEST);
  IF OKFILE
    THEN
      BEGIN
        WRITE('Using READCHAR');
        WRITE(CHR(7));
        WHILE NOT EOFFLAG DO
          BEGIN
            WHILE NOT EOLNFLAG DO
              BEGIN
                READCHAR(CH);
                WRITECHAR(CH)
              END;
            READLINE(S);
            WRITELINE(S)
          END;
        WRITE(CHR(7));
        CLOSEOUTFILE;
        WRITELN;
        WRITELN
      END
    ELSE
      CLOSEINFILE;
  WRITELN('Test of standard character I/O');
  WRITE('Output file name ? ');
  READLN(DEST);
  WRITELN;
  IF DEST<>''
    THEN
      BEGIN
        RESET(INTEXT,SOURCE);
        REWRITE(OUTTEXT,DEST);
        WRITE('Using READ');
        WRITE(CHR(7));
        WHILE NOT EOF(INTEXT) DO
          BEGIN
            WHILE NOT EOLN(INTEXT) DO
              BEGIN
                READ(INTEXT,CH);
                WRITE(OUTTEXT,CH)
              END;
            READLN(INTEXT);
            WRITELN(OUTTEXT)
          END;
        WRITE(CHR(7));
        CLOSE(INTEXT,LOCK);
        CLOSE(OUTTEXT,LOCK);
        WRITELN;
        WRITELN
      END;
  WRITELN('Test of fast line I/O');
  WRITE('Output file name ? ');
  READLN(DEST);
  WRITELN;
  OKFILE := RESETFILE(SOURCE);
  IF NOT OKFILE
    THEN
      BEGIN
        WRITELN('Fatal error -- lost input file');
        EXIT(PROGRAM)
      END;
  OKFILE := REWRITEFILE(DEST);
  IF OKFILE
    THEN
      BEGIN
        WRITE('Using READLINE');
        WRITE(CHR(7));
        WHILE NOT EOFFLAG DO
          BEGIN
            READLINE(S);
            WRITELINE(S)
          END;
        WRITE(CHR(7));
        CLOSEOUTFILE;
        WRITELN;
        WRITELN
      END
    ELSE
      CLOSEINFILE;
  WRITELN('Test of standard line I/O');
  WRITE('Output file name ? ');
  READLN(DEST);
  WRITELN;
  IF DEST <>''
    THEN
      BEGIN
        RESET(INTEXT,SOURCE);
        REWRITE(OUTTEXT,DEST);
        WRITE('Using READLN');
        WRITE(CHR(7));
        WHILE NOT EOF(INTEXT) DO
          BEGIN
            READLN(INTEXT,S);
            WRITELN(OUTTEXT,S)
          END;
        WRITE(CHR(7));
        CLOSE(INTEXT,LOCK);
        CLOSE(OUTTEXT,LOCK);
        WRITELN;
        WRITELN
      END;
  CLOSEINFILE
END. (* IOTEST *)

========================================================================================
DOCUMENT :usus Folder:VOL23:iounit.text
========================================================================================

UNIT IOUNIT;

{     (c) Copyright 1983 by Charles Rockwell.  All rights reserved. }
{ Permission is granted only for not-for-profit use by USUS members.}
{ Author:  Charles Rockwell, Microlog, Box 116, Guilford CT, 06437. }

INTERFACE

TYPE 
     LONGSTR = STRING[255];
     FILNAME = STRING[20];

VAR 
     EOLNFLAG,
     EOFFLAG: BOOLEAN;

  PROCEDURE READLINE(VAR ST:LONGSTR);
  
  PROCEDURE READCHAR(VAR C:CHAR);
  
  FUNCTION RESETFILE(VAR FNAME:FILNAME): BOOLEAN;
  
  PROCEDURE CLOSEINFILE;
  
  PROCEDURE WRITELINE(ST:LONGSTR);
  
  PROCEDURE WRITECHAR(C:CHAR);
  
  FUNCTION REWRITEFILE(VAR GNAME:FILNAME): BOOLEAN;
  
  PROCEDURE CLOSEOUTFILE;
  
IMPLEMENTATION

CONST 
      NULL = 0;
      CR = 13;
      DLE = 16;
      SP = 32;

VAR 

(* VARIABLES FOR READCHAR *)
    INFILE: FILE;                             (* BLOCKREAD FILE *)
    INDISKBUF: PACKED ARRAY[0..1025] OF CHAR; (* BLOCKREAD BUFFER +2 *)
    INDISKPTR: INTEGER;                       (* BUFFER POINTER *)
    INLINEBUF: LONGSTR;                       (* INPUT STRING BUFFER *)
    INLINEPTR: INTEGER;                       (* INPUT STRING POINTER *)
    INLINELEN: INTEGER;                       (* INPUT STRING LENGTH *)

(* VARIABLES FOR WRITECHAR *)
    OUTFILE: FILE;                            (* BLOCKWRITE FILE *)
    OUTDISKBUF: PACKED ARRAY[0..1025] OF CHAR;(* BLOCKWRITE BUFFER +2 *)
    OUTDISKPTR: INTEGER;                      (* BUFFER POINTER *)
    OUTLINEBUF: LONGSTR;                      (* OUTPUT STRING BUFFER *)
    OUTLINEPTR: INTEGER;                      (* OUTPUT STRING POINTER *)


(*---------------------------------------------------------------------*)

PROCEDURE READBUF; (* BLOCKREAD THE DISK FILE *)

VAR 
    R: INTEGER;
BEGIN (* READBUF *)
  IF EOF(INFILE)
    THEN
      BEGIN
        EOFFLAG := TRUE;
        CLOSE(INFILE,LOCK);
        EXIT(READBUF)
      END
    ELSE
      EOFFLAG := FALSE;
  R := BLOCKREAD(INFILE, INDISKBUF, 2);
  IF R<>2
    THEN
      BEGIN
        WRITELN;
        WRITELN('Error reading file');
        CLOSE(INFILE,LOCK);
        EXIT(PROGRAM)
      END;
  INDISKPTR := 0
END; (* READBUF *)

PROCEDURE READLINE(* VAR ST:LONGSTR *);
(* ST := INLINEBUF; INLINEBUF := NEXT LINE FROM DISKBUF *)

VAR 
    J,K,L: INTEGER;
BEGIN (* READLINE *)
  IF EOLNFLAG
    THEN (* INLINEBUF IS PRESUMED EMPTY *)
      ST := ''
    ELSE (* ST:=INLINEBUF *)
      BEGIN
        L := INLINELEN-INLINEPTR+1;
      (*$R- *)
        MOVELEFT(INLINEBUF[INLINEPTR],ST[1],L);
        ST[0] := CHR(L)
      (*$R+ *)
      END;
  IF ((INDISKPTR > 1023) OR (INDISKBUF[INDISKPTR] = CHR(NULL)))
    THEN (* INDISKBUF IS PRESUMED EMPTY *)
      BEGIN
        READBUF;
        IF EOFFLAG
          THEN
            EXIT(READLINE)
      END;
  IF INDISKBUF[INDISKPTR]=CHR(DLE)
    THEN (* GET BLANK COUNT *)
      BEGIN
        J := ORD(INDISKBUF[INDISKPTR+1])-32;
        INDISKPTR := INDISKPTR+2;
        IF (J>0) AND (J<127) THEN
            begin
               FILLCHAR(INLINEBUF,J+1,CHR(32)) ;
               fillchar ( inlinebuf, 1, chr ( j ) );
            end
       ELSE J:=0
     END
    ELSE (* BLANK COUNT IS ZERO *)
      J := 0;
  (* FIND LENTH OF NEXT LINE IN INDISKBUF *)
  K := SCAN(1024-INDISKPTR, =CHR(CR), INDISKBUF[INDISKPTR]);
(* INSERT NEXT LINE INTO INLINEBUF STARTING AT BLANK COUNT SPACES *)
  (*$R-  range checking off to allow moveleft into arbitrary length string-gws*)
  MOVELEFT(INDISKBUF[INDISKPTR],INLINEBUF[J+1],K);
  (*$R+*)
  FILLCHAR ( INLINEBUF, 1, CHR ( J + K ) );  {set length byte - gws}
  INLINELEN := J+K;
  INLINEPTR := 1;
  INDISKPTR := INDISKPTR+K+1;
  EOLNFLAG := (INLINEPTR>INLINELEN)
END; (* READLINE *)

PROCEDURE READCHAR(* VAR C:CHAR *);
(* GET NEXT CHARACTER FROM INPUT STRING *)
BEGIN (* READCHAR *)
  (*$R- *)
  C := INLINEBUF[INLINEPTR];
  (*$R+ *)
  INLINEPTR := INLINEPTR+1;
  EOLNFLAG := (INLINEPTR>INLINELEN)
END; (* READCHAR *)

FUNCTION RESETFILE(* VAR FNAME:FILNAME ) :BOOLEAN *);

VAR 
    R: INTEGER;
    TRASH: LONGSTR;

BEGIN (* RESETFILE *)
(*$I- *)
  REPEAT
    IF FNAME=''
      THEN
        BEGIN
          RESETFILE := FALSE;
          EXIT(RESETFILE)
        END
      ELSE
        RESETFILE := TRUE;
    IF ((POS('.',FNAME)=0)
       AND (POS(':',FNAME) <> LENGTH(FNAME)))
      THEN
        FNAME := CONCAT(FNAME,'.TEXT');
    RESET(INFILE,FNAME);
    R := IORESULT;
    IF R<>0
      THEN
        BEGIN
          WRITELN  ('Cannot open      ',FNAME);
          WRITELN;
          WRITE    ('Filename:        ');
          READLN(FNAME)
        END
  UNTIL R=0;
(*$I+ *)
  READBUF;  (* READ TEXT FILE HEADER *)
  INDISKPTR := 1024; (* FORCE NEXT READBUF *)
  EOLNFLAG := TRUE;
  READLINE(TRASH)
END; (* RESETFILE *)

PROCEDURE CLOSEINFILE;
  BEGIN
    CLOSE(INFILE,LOCK)
  END;

(*---------------------------------------------------------------------*)

PROCEDURE WRITEBUF; (* BLOCKWRITE THE DISK FILE *)

VAR 
    E: INTEGER;
BEGIN (* WRITEBUF *)
  E := BLOCKWRITE(OUTFILE,OUTDISKBUF,2);
  IF E<>2
    THEN
      BEGIN
        WRITELN('Error writing file');
        CLOSE(OUTFILE,LOCK);
        EXIT(PROGRAM)
      END;
  OUTDISKPTR:=0
END; (* WRITEBUF *)

PROCEDURE WRITELINE(* ST:LONGSTR *);
(* OUTLINEBUF := CONCAT OUTLINEBUF,ST; OUTDISKBUF := OUTLINEBUF *)
VAR 
    BLANKS,CHARS,STLEN: INTEGER;
BEGIN (* WRITELINE *)
  CHARS := LENGTH(ST);
  (*$R-*)
  IF CHARS>0
    THEN (* CONCAT OUTLINEBUF,ST *)
      MOVELEFT(ST[1],OUTLINEBUF[OUTLINEPTR+1],CHARS);
  (* CONCAT OUTLINEBUF,CHR(CR) *)
  CHARS := CHARS+OUTLINEPTR+1;
  OUTLINEBUF[CHARS] := CHR(CR);
  BLANKS := SCAN(CHARS,<>CHR(SP),OUTLINEBUF[1]);
  (*$R+*)
  STLEN:=CHARS-BLANKS;
  IF (OUTDISKPTR + STLEN) >1020
    THEN (* WRITE BLOCK *)
      BEGIN
        FILLCHAR(OUTDISKBUF[OUTDISKPTR],1024-OUTDISKPTR,CHR(NULL));
        WRITEBUF
      END;
  IF BLANKS>0
    THEN (* INSERT DLE COUNT *)
      BEGIN
        OUTDISKBUF[OUTDISKPTR] := CHR(DLE);
        OUTDISKBUF[OUTDISKPTR+1] := CHR(BLANKS+32);
        OUTDISKPTR := OUTDISKPTR+2
      END;
(*$R-*)
  (* COPY OUTLINEBUF TO OUTDISKBUF *)
  MOVELEFT(OUTLINEBUF[BLANKS+1],OUTDISKBUF[OUTDISKPTR],STLEN);
  OUTLINEPTR := 0;
(*$R+*)
  OUTDISKPTR := OUTDISKPTR+STLEN
END; (* WRITELINE *)

PROCEDURE WRITECHAR(* C:CHAR *);
(* OUTLINEBUF := CONCAT OUTLINEBUF,CH *)
BEGIN (* WRITECHAR *)
  OUTLINEPTR := OUTLINEPTR+1;
  (*$R- *)
  OUTLINEBUF[OUTLINEPTR] := C
  (*$R+ *)
END; (* WRITECHAR *)

FUNCTION REWRITEFILE(* VAR GNAME:FILNAME *) (* :BOOLEAN *);

VAR 
    E,R: INTEGER;
BEGIN (* REWRITEFILE *)
(*$I- *)
  REPEAT
    IF GNAME=''
      THEN
        BEGIN
          REWRITEFILE := FALSE;
          EXIT(REWRITEFILE)
        END
      ELSE
        REWRITEFILE := TRUE;
    IF ((POS('.',GNAME)=0)
       AND (POS(':',GNAME) <> LENGTH(GNAME)))
      THEN
          GNAME := CONCAT(GNAME,'.TEXT');
    REWRITE(OUTFILE,GNAME);
    R := IORESULT;
    IF R<>0
      THEN
        BEGIN
          WRITELN  ('Cannot open      ',GNAME);
          WRITELN;
          WRITE    ('Filename:        ');
          READLN(GNAME)
        END
  UNTIL R=0;
(*$I+ *)
  IF (POS(':',GNAME)<>LENGTH(GNAME))
    THEN (* DESTINATION IS PRESUMED TO BE A DISK FILE *)
      BEGIN
        FILLCHAR(OUTDISKBUF,SIZEOF(OUTDISKBUF),CHR(NULL));
        WRITEBUF
      END;
  OUTDISKPTR:=0;
  OUTLINEPTR := 0
END; (* REWRITEFILE *)

PROCEDURE CLOSEOUTFILE;

BEGIN (* CLOSEOUTFILE *)
  IF OUTDISKPTR>0
    THEN (* WRITE OUT LAST BLOCK *)
      BEGIN
        FILLCHAR(OUTDISKBUF[OUTDISKPTR],1024-OUTDISKPTR,CHR(NULL));
        WRITEBUF
      END;
  CLOSE(OUTFILE,LOCK)
END (* CLOSEOUTFILE *)

END. (* IOUNIT *)

========================================================================================
DOCUMENT :usus Folder:VOL23:rnddoc.text
========================================================================================


                             RNDTEST
        
        RND is a random number generator that gives reasonably
random results without crashing my LSI-11 system.  RNDTEST
includes four versions of RND, along with a few simple tests for
randomness.  The first three versions of RND are included for
those who are interested in the detailed operation of the basic
algorithm.  The final version should run on any UCSD (TM)
system, and is a clear candidate for inclusion in
SYSTEM.LIBRARY.

        The basic algorithm for RND is Meekings' Algorithm A-1
in Pascal News #12, which is a Pascal version of Kendall's
algorithm for a Tausworthe (or shift register) random sequence
generator.  Each call to a Tausworthe generator gets the next
integer in a fixed pseudorandom sequence of integers. In RND,
the sequence includes one and only one copy of each of the
integers between 1 and 32767 inclusive, arranged in an order
that many statistical tests cannot distinguish from a true
random order.  Starting with the 32768th call to the generator
(or multiples thereof) the original sequence will repeat itself
exactly.

        The random number generators in RNDTEST are written as:

               FUNCTION RND(LO,HI:INTEGER):INTEGER;

        Each uses a different version of a Tausworthe generator
to maintain an integer "seed", and uses the real fraction 
(seed-1)/32767 to return an integer that is between LO and HI
inclusive.  The initial seed can be any positive nonzero
integer.  Changing seeds changes the starting point in the
sequence, but does not change the sequence itself. 

        The first version of RND uses a brute force Pascal bit
manipulation version of the LSI-11 assembly language Tausworthe
generator that appeared in Camp and Lewis, "Implementing a
Pseudorandom Number Generator on a Minicomputer", IEEE
Transactions on Software Engineering, May 1977, Page 259.
Pascal does not flip bits with a great deal of alacrity, and
this version is lethargic, if not moribund.  However, it does
show exactly what should be happening, bit by bit, and it will
probably run on any UCSD (TM) system.

        The second and third versions of RND use what is
essentially Meekings' algorithm from Pascal News #12.  The
second version uses arithmetic to generate a logical complement,
while the third version uses NOT.  Although these versions do
run on my LSI-11 system, they do so only because AND, OR, and
NOT are implemented as 16-bit operations, and booleans are
treated as 16-bit words. These versions may or may not work on
other systems.

        The fourth version of RND is similar to the second
version, but reflects Miner's comments in PN #12, and Meekings'
comments in PN #13.  The changes prevent an integer multiply
overflow, clear the sign bit of the seed (Note: this is not
necessarily the same thing as taking the absolute value of the 
seed!), and implement the logical XOR function with set
operations.  This version is reasonably fast, and should work on
any UCSD (TM) system.
        
        RNDTEST also includes three simple tests for random
number generators.  The first test is to generate 10,000 random
integers between 1 and 10 inclusive and count the number of
times that each of the integers between 0 and 11 appear. Neither
0 nor 11 should appear at all, and each of the other integers
should appear roughly 1000 +/- 70 times.
        
        The second test is to generate 1000 random positions on
the system (79 x 23) screen, GOTOXY there, and display an
asterisk.  The resulting display should not show a pronounced
pattern, and should be roughly half full of asterisks by the 
time the test terminates.

        The third test is to generate random integers until the
initial seed reappears.  A count is kept of the number of times
that each integer (positive, negative, or zero) crops up, as
well as the total number of integers that have been generated.
The count of each integer is then checked to ensure that no
negative integers have been generated, that zero has not been
generated, and that each positive integer has been generated
once and only once.

RANDOMIZE
        Each time a program using RND is executed, the seed must 
be initialized.  In programs such as sorting benchmarks it is 
useful to use the same initial seed so that each sorting routine 
uses the same sequence of integers.  In programs such as 
arithmetic drills it is useful to use a different seed each time 
the program is executed in order to avoid an identical sequence 
of problems.

        It is conventional to initialize a random number seed to 
a single, fixed value.  If desired, a subsequent call to
RANDOMIZE replaces the initial seed with a randomized seed.
Obvious candidates for a randomized seed include using
ABS(LOTIME) for those systems with a real time clock, or ORD(CH)
where CH is the response to "Type any character".  Other
alternatives include using ABS(PEEK(loc)) where "loc" is a fixed
memory location known to have a highly variable content, or
ABS(DATE) where DATE is the system date that is maintained on
the system disk.  A final alternative that is practical under
the IV UCSD (TM) system is to use the termination code of the
UNIT construct to write the last value of seed out to disk.
RANDOMIZE then reads this value back and uses it for the new
value of seed.  
 
        RANDOMIZE is not included in RNDTEST because of the 
system specific nature of the beast.

                                CR


========================================================================================
DOCUMENT :usus Folder:VOL23:rndtest.text
========================================================================================

program randomtest;
  
{ Author:  Charles Rockwell, Microlog, Box 116, Guilford CT, 06437. }

(* Variations on Meekings' Algorithm A1, PN #12, and *)
(* a few simple tests for random number generators *)

var seed:integer;
    num:integer;
    test:char;

procedure blankscr; (* clear the screen *)
  begin
    write(chr(26));
  end;
  
function rnd0(lo,hi:integer):integer;
  (* A Tausworthe generator, using Kendall's algorithm, done bit by bit *)
  (* Runtime is 30 min for 10000 randoms *)
    
    var a,b:record case boolean of
      true:(int:integer);
      false:(bol:packed array[0..15] of boolean);
    end;
    
    i,j,range:integer;
    q:real;
  
  begin
    a.int:=seed;
    for i:=0 to 15 do (* b:=a shifted right by 4 *)
      begin
        j:=(i+4)mod 16;
        if i<12 then b.bol[i]:=a.bol[j] else b.bol[i]:=false;
      end;
    for i:=0 to 15 do (* a:=a xor b *)
      a.bol[i]:=(a.bol[i]<>b.bol[i]);
    for i:=0 to 15 do (* b:=a shifted left by 11 *)
      begin
        j:=(i+11)mod 16;
        if j>10 then b.bol[j]:=a.bol[i] else b.bol[j]:=false;
      end;
    for i:=0 to 15 do (* a:=a xor b *)
      a.bol[i]:=(a.bol[i]<>b.bol[i]);
    a.bol[15]:=false; (* must clear the sign bit *)
    seed:=a.int;
    q:=(a.int-1)/32767; (* modified for a range of [0,1) *)
    range:=hi-lo+1;
    rnd0:=trunc(q*range)+lo;
  end;

function rnd1(lo,hi:integer):integer;
  (* Meekings' Pascal version, from  PN #12 *)
  (* This may or may not run *)
  
  const pshift=2048;
        qshift=16;
        big=32767;
  
  type dual=record
              case boolean of
                true:(int:integer);
                false:(bol:boolean);
              end;
  
  var a,b,acomp,bcomp:dual;
      range:integer;
      q:real;
  
  begin
    a.int:=seed;
    b.int:=a.int div qshift; (* b:=a shifted right by 4 *)
    acomp.int:=big-a.int;
    bcomp.int:=big-b.int;
    a.bol:=(a.bol and bcomp.bol)or(acomp.bol and b.bol); (* a:=a xor b *)
    b.int:=a.int * pshift; (* b:=a shifted left by 11 *)
    acomp.int:=big-a.int;
    bcomp.int:=big-b.int;
    a.bol:=(a.bol and bcomp.bol)or(acomp.bol and b.bol); (* a:=a xor b *)
    seed:=a.int; (* result is always positive *)
    q:=(a.int-1)/32767; (* modified for a range of [0,1) *)
    range:=hi-lo+1;
    rnd1:=trunc(q*range)+lo;
  end;

function rnd2(lo,hi:integer):integer;
  (* Meekings' Pascal version, using boolean XOR *)
  (* This may or may not run *)
  
  const pshift=2048;
        qshift=16;
        pmod=16; (* Modified to clear sign bit *)
        big=32767;
  
  type dual=record
              case boolean of
                true:(int:integer);
                false:(bol:boolean);
              end;
  
  var a,b:dual;
      range:integer;
      q:real;
  
  begin
    a.int:=seed;
    b.int:=a.int div qshift; (* b:=a shifted right by 4 *)
    a.bol:=(a.bol and not b.bol)or(not a.bol and b.bol); (* a:=a xor b *)
    b.int:=a.int mod pmod * pshift; (* b:=a shifted left by 11, sign cleared *)
    a.bol:=(a.bol and not b.bol)or(not a.bol and b.bol); (* a:=a xor b *)
    seed:=a.int; (* result is always positive *) 
    q:=(a.int-1)/32767; (* modified for a range of [0,1) *)
    range:=hi-lo+1;
    rnd2:=trunc(q*range)+lo;
  end;

function rnd3 (lo,hi:integer):integer;
  (* Meekings' Pascal version, using Miner's XOR *)
  (* This should run *)
    
  const pshift=2048;
        pmod=16; (* modified to clear sign bit *)
        qshift=16;
  
  var q:real; range:integer;
      a,b:record case boolean of
        true:(int:integer);
        false:(bitset:packed set of 0..15);
      end;
  
  begin
    a.int:=seed;
    b.int:=a.int div qshift; (* b:=a shifted right by 4 *)
    a.bitset:=(a.bitset-b.bitset)+(b.bitset-a.bitset); (* a:=a xor b *)
    b.int:=a.int mod pmod * pshift; (* b:=a shifted left by 11, sign cleared *)
    a.bitset:=(a.bitset-b.bitset)+(b.bitset-a.bitset); (* a:=a xor b *)
    seed:=a.int; (* result is always positive *)
    q:=(a.int-1)/32767; (* modified for a range of [0,1) *)
    range:=hi-lo+1;
    rnd3:=trunc(q*range)+lo;
  end;

procedure sort;
  (* Generate a random integer from 1 to 10, and *)
  (* increment the corresponding array member *)

var a:array[0..11] of integer;
    j,k,m:integer;
    r:real;

begin
  write('Testing ');
  for j:=0 to 11 do a[j]:=0;
  for j:=1 to 10000 do
    begin
      if j mod 1000 = 0 then write('.');
      case num of (* use the specified  RND function *)
          0:k:=rnd0(1,10);
          1:k:=rnd1(1,10);
          2:k:=rnd2(1,10);
          3:k:=rnd3(1,10);
        end;
      a[k]:=a[k]+1;
    end;
  writeln;
  writeln('0 expected in a[0] and a[11], 930 to 1070 in a[1]..a[10]') ;
  for j:=0 to 11 do writeln('  a[',j,']=',a[j]);
end;


procedure display;
  (* Generate a random screen position, *)
  (* gotoxy there, and write a marker *)

var i,x,y:integer;

begin
  blankscr;
  for i:=1 to 1000 do
      begin
          case num of
              0: begin x:=rnd0(0,78); y:=rnd0(0,22) end;
              1: begin x:=rnd1(0,78); y:=rnd1(0,22) end;
              2: begin x:=rnd2(0,78); y:=rnd2(0,22) end;
              3: begin x:=rnd3(0,78); y:=rnd3(0,22) end;
           end;
        gotoxy(x,y);
        write('*');
      end;
end;

procedure check;
  (* Check for run length, no zero or negative integers, *)
  (* and no duplicate positive integers *)

type cnt=0..3;
     byte=0..255;
     rec=packed record
           case boolean of
              true:(x:byte; y:byte);
              false:(z:integer);
           end;

var j,k,m,n,t:integer;
    count:packed array[0..255,0..255] of cnt;
    alias:rec; (* compiler will not allow 65536 x 2 array *)

begin
    n:=0;
    write('Zeroing array ');
    for j:=0 to 255 do
      for k:=0 to 255 do
        begin
          if k=0 then if j mod 10 = 0 then write('.');
          count[j,k]:=0;
        end;
    writeln;
    write('Filling array ');
    repeat
      case num of (* use the specified  RND function, *)
          0:t:=rnd0(0,1);
          1:t:=rnd1(0,1);
          2:t:=rnd2(0,1);
          3:t:=rnd3(0,1);
        end;
      alias.z:=seed; (* but check the seed *)
      if n mod 2560 = 0 then write('.');
      n:=n+1;
      count[alias.x,alias.y]:=count[alias.x,alias.y]+1;
    until ((alias.z=12345) or (count[alias.x,alias.y]=3));
     (* seed has come full circle, or generator is repeating *)
    writeln;
    writeln;
    writeln('Run length:  ',n);
    writeln;
    writeln('Checking negative integers');
    n:=0;
    for j:=0 to 255 do
      for k:=128 to 255 do
        if count[j,k]<>0 then 
          n:=n+1;
    writeln;
    if n=0 then write('No ') else write(n,' ');
    writeln('negative integers generated');
    writeln;
    if count[0,0]=0
      then writeln('Zero was not generated')
      else writeln('Zero was generated');
    writeln;
    writeln('Checking positive integers');
    n:=0;
    m:=0;
    for j:=0 to 255 do
      for k:=0 to 127 do
        if count[j,k]<>1 then 
          begin
            if count[j,k]=0
              then
                if ((j=0) and (k=0))
                  then (* don't count zero as missing *)
                  else  m:=m+1
              else n:=n+1;
          end;
    writeln;
    if m=0 then write('No ') else write(m,' ');
    writeln('missing positive integers');
    writeln;
    if n=0 then write('No ') else write(n,' ');
    writeln('duplicate positive integers');
    end;

begin (* randomtest *)
  repeat
    seed  :=12345; 
    blankscr;
    repeat
      gotoxy(0,0);
      write('S(ort, D(isplay, C(heck, Q(uit ? ');
      read(test);
    until test in ['S','s','D','d','C','c','Q','q'];
    if test in ['Q','q'] then exit(program);
    repeat
      gotoxy(0,1);
      write('Generator number [0..3] ? ');
      readln(num);
    until num in [0..3];
    case test of
        'S','s': sort;
        'D','d': display;
        'C','c':check;
    end;
    gotoxy(0,23);
    write('Hit SPACE to continue: ');
    read(test);
  until false
end.


========================================================================================
DOCUMENT :usus Folder:VOL23:spelldoc.text
========================================================================================

                             SPELLDOC
        
        Speller is a simple spelling checker.  Speller reads an
input text file and sorts it into an alphabetical list of unique
words. This list of words is then checked against a dictionary,
and all words that are found in the dictionary are removed from
the list.  The remaining list consists of "flagged", or
potentially misspelled words.  This list can be displayed,
printed, sent to a file, or simply ignored.  An optional second
pass can then be made through the text file.  During the second 
pass, each text word is looked up in the list of flagged words. 
If a text word is found, a flag ("<") is inserted in the text
file.  The editor is then used to find each of the flags and
correct the error.
        
        A practical spelling checker must check a text file of
reasonable length against a large dictionary in a reasonable
amount of time.  Speller uses memory only for the list of unique
text words, which is considerably shorter than the text file
itself.  This allows a reasonably long text file to be checked
against a dictionary file that is limited only by disk space. 
        
        Speller spends the vast majority of its run time in
reading text and looking up words.  The time spent in reading
text is minimized by using routines from IOUNIT in place of the
standard constructs.  The time spent in looking up words is
minimized by using a binary tree search algorithm from Niklaus
Wirth's program "Cross Reference Generator" in his book
Algorithms + Data Structures = Programs.

Running Speller
        Speller announces its presence by displaying "Speller",
and then prompts for the name of the input text file, which can
be any UCSD text file.  If only a name is entered then ".text"
is appended to the name.  I/O checking is turned off while an
attempt is made to access the file on the default disk drive.
If there is a problem, the name is displayed and the process
repeats.  If no name is entered, it is assumed that the program
was entered by mistake, and Speller terminates.
        
        After the text file is successfully opened, the program
displays "Sorting text" and begins to sort the input text. An
indication of progress is provided by displaying a "." as each
tenth line is read from the input text file.  After the sort has
been completed, the program prompts for the name of the input
dictionary file.  The dictionary file is an alphebetical
list of correctly spelled words, one to a line, in an otherwise
standard UCSD text file.  The process of opening the dictionary
file is the same as that of opening the text file. If no name is
entered, the word list is not checked and the program goes
directly to the output procedure.
        
        After the input dictionary file is successfully opened,
the program prompts for the name of a new (output) dictionary
file.  An attempt is made to open this file in the same way as
the previous files.  If the file can be opened, each word from
the input dictionary file is copied to the output dictionary
file, and text words that were not found in the dictionary can
be added.  If no file name is entered, the option of adding
words to the dictionary is not available.
        
        In either case, the program displays "Checking text" and
begins to check the word list against the dictionary.  If the
option of adding words to the dictionary has not been exercised,
the indications of progress are the same as when reading a text
file.
        
        If words are being added to the dictionary, the only
indication of progress is an occasional message that goes
something like:

          "Line 338: snurf not found.  Enter it (Y) ? ".

        Either "Y" or "y" will cause the word to be added to the
dictionary. If the answer is any other character, the message
continues with:

                        " Flag it (Y) ? "

        Either "Y" or "y" will cause the word to be added to the
list of flagged words, any other character will cause the word
to be removed from the list of flagged words.
        
        After the entire list of words has been checked, (or if
no dictionary file name was entered), the program prompts for
the name of the output list file, which can be CONSOLE:,
PRINTER:, etc, as well as a disk file.  The process of opening
the output file is the same as before.

        If the output file is successfully opened, the program
displays "Writing output list", and the output list is sent to
its destination.  The output is a sorted list of the flagged
words, along with the line number of the first appearance and a
count of the total number of appearances in the original text
file.  If no file name is entered, the word list is not written.
        
        The program then prompts for the name of the marked text
file.  After this file is successfully opened, the input text
file is copied to the output text file, with a "<" inserted at
the end of each flagged word.  If no file name is entered, the
marked text file is not written.
        
        The program finishes by displaying the number of lines,
words, and unique words that were found in the text file,
the number of unique words that were flagged, and the number of
words of memory still available.
        
Implementation Notes
        Speller converts all text to lower case, so that neither
"pascal" nor "PASCAL" is flagged as a potential spelling error.
Words are defined as beginning with a..z or 0..9, and as
continuing with a..z, 0..9, "-","'", or "/".  Words beginning
with 0..9 increment the word count but are not checked. Byte-
flipped is two words: "byte-" and "flipped".  Byte-flipped,
ain't, and I/O are all words, but M(unched is two words: "m" and
"unched".  
        
        The maximum length of a word is defined by the constant
MAXCHAR as 14 characters.  Words up to and including maxchar
characters in length are accepted as is.  Words longer than this
are truncated, and the last character is changed to a "-".
        
        Words are defined in the procedure GETTOKEN, and the
definition can be changed as desired.
        
        Speller uses a "literal dictionary", which means that
the dictionary is just a long list of words.  The dictionary is 
formatted as one word per line, in alphabetical order, with no
leading or trailing spaces.  (Using GETTOKEN rather than 
READLINE to read the dictionary removes the formatting 
restrictions at the cost of doubling the time to read the 
dictionary).  The dictionary can be edited just as any other
text file.  Speller's dictionary is defined as a sorted list of
words known to be spelled correctly. Considerable care should be
used in adding words to the dictionary; a spelling check using a
corrupt dictionary is of little value.
        
Performance
        Speller runs a complete check at a rate of roughly 300
text words per minute, depending on the specific system, the
length of the files, etc.  The sorting method used by Speller
is recursive, which means that the procedure includes a call to
itself.  Because of this recursion, both the memory and the
time required to sort a text file depend on the order of the
words in the input text. If the file contains normal English
text, the performance of the sort is roughly equivalent to the
performance of a binary search.  If the input text is already
sorted, or nearly so, the performance of the sort degrades to
that of a linear search. The result is a slow sort requiring
copious memory.  Replying to "Input text file" with "dict.text"
will probably cause "*STACK OVERFLOW*" many minutes later.
        
        The maximum length of the input text file is determined
primarily by the number of unique words encountered, and is
limited to roughly three times the capacity of the screen
editor. The length of the dictionary file is limited by the disk
capacity and the user's patience.  If the dictionary is to be
edited, the editor's limitations on file length become
important.  However, note that it is relatively easy to modify
the procedure CHECKDICT to read several dictionary files in
sequence.
        
                                CR


========================================================================================
DOCUMENT :usus Folder:VOL23:speller.text
========================================================================================


PROGRAM SPELLER;

{     (c) Copyright 1983 by Charles Rockwell.  All rights reserved. }
{ Permission is granted only for not-for-profit use by USUS members.}
{ Author:  Charles Rockwell, Microlog, Box 116, Guilford CT, 06437. }

USES (*$U IOUNIT.CODE *) IOUNIT;
{ This construct assumes IOUNIT.CODE resides in SYSTEM.LIBRARY }
{ changed to look for IOUNIT in a code file called IOUNIT.CODE - gws }

CONST 
      MAXCHAR = 14;                (* CHARACTERS PER TOKEN *)
      MAXDIGITS = 5;               (* DIGITS IN LINE NUMBER *)
      MAXSTR = 132;                (* CHARACTERS IN STRING *)

TYPE 
     ALPHA = STRING[MAXCHAR];
     FILENAME = STRING[20];
     WORDREF = ^WORD;
     WORD = RECORD
              KEY: ALPHA;          (* A WORD *)
              FIRST: INTEGER;      (* FIRST LINE NUMBER *)
              COUNT: INTEGER;      (* OCCURRENCES *)
              LEFT: WORDREF;       (* POINTERS TO LEFT AND     *)
              RIGHT: WORDREF;      (*     RIGHT WORDS IN TREE  *)
            END;

VAR 
    OUT:BOOLEAN;
    FILEOK: BOOLEAN;               (* FILE IS OPEN *)
    DOTS: BOOLEAN;                 (* WRITE DOTS TO SCREEN *)
    LBUF: STRING[MAXSTR];          (* INPUT LINE BUFFER *)
    LPTR: INTEGER;                 (* INPUT LINE POINTER *)
    MARK: BOOLEAN;                 (* WRITING MARKED TEXT FILE *)
    ROOT: WORDREF;                 (* START OF THE TREE *)
    DICTWRITE: BOOLEAN;            (* ADDING ENTRIES TO DICT *)
    LCOUNT: INTEGER;               (* RUNNING LINE COUNT *)
    LINECOUNT: INTEGER;            (* LINES IN TEXT *)
    WCOUNT: INTEGER;               (* RUNNING WORD COUNT *)
    WORDCOUNT: INTEGER;            (* TOKENS IN TEXT *)
    DICTCOUNT: INTEGER;            (* UNIQUE WORDS IN TEXT *)
    FLAGCOUNT: INTEGER;            (* WORDS FLAGGED FOR OUTPUT *)
    CORECOUNT: INTEGER;            (* MINIMUM WORDS OF MEMORY *)
    TOKEN: ALPHA;                  (* A WORD *)
    SPACES: ALPHA;                 (* A BLANK WORD *)
    CH: CHAR;
    SOURCE: FILENAME;              (* INPUT FILE NAME *)
    DEST: FILENAME;                (* OUTPUT FILE NAME *)
    TITLE: FILENAME;               (* FILE NAME FOR HEADER *)

(*---------------------------------------------------------------------*)

PROCEDURE REPORT;               (* SEND PROGRESS REPORT TO SCREEN *)
BEGIN
  IF DOTS THEN WRITE('.');
  IF CORECOUNT>VARAVAIL('speller')  (* MEMAVAIL *)
    THEN CORECOUNT := VARAVAIL('speller')
END;

PROCEDURE GETTOKEN;                              (* READ A WORD *)

VAR 
    K: INTEGER;
    DONE: BOOLEAN;

  PROCEDURE READCH(VAR C:CHAR);
  BEGIN
    IF LPTR>LENGTH(LBUF)
      THEN
        BEGIN
          IF MARK
            THEN
              BEGIN
                DELETE(LBUF,LENGTH(LBUF),1);
                WRITELINE(LBUF)
              END;
          IF EOFFLAG THEN
            BEGIN
              OUT:=TRUE;
              EXIT(GETTOKEN)
            END;
          READLINE(LBUF);
          LBUF := CONCAT(LBUF,' ');
          LPTR := 1;
          IF LCOUNT MOD 10 = 0 THEN REPORT;
          LCOUNT := LCOUNT+1
        END;
    C := LBUF[LPTR];
    LPTR := LPTR+1;
    IF C IN ['A'..'Z'] THEN C := CHR(ORD(C)+32)
  END; (* READCH *)

BEGIN (* GETTOKEN *)
  REPEAT
    DONE := TRUE;
    K := 0;
    TOKEN := SPACES;
    REPEAT READCH(CH)
      UNTIL CH IN ['a'..'z','0'..'9'];
        (* A WORD STARTS WITH THESE *)
(*$R- *)
    REPEAT
      K := K+1;
      IF K<= MAXCHAR THEN TOKEN[K] := CH;
      READCH(CH)
    UNTIL NOT(CH IN ['a'..'z','0'..'9','''','/','-']);
                     (* AND CONTINUES WITH THESE *)
    IF (TOKEN[1] IN ['0'..'9'])
      THEN (* COUNT AND IGNORE *)
        BEGIN
          WCOUNT := WCOUNT+1;
          DONE := FALSE
        END
  UNTIL DONE;
  IF K > MAXCHAR
    THEN
      BEGIN
        TOKEN[MAXCHAR] := '-';
        K := MAXCHAR
      END;
  TOKEN[0] := CHR(ORD(K))
(*$R+ *)
END; (* GETTOKEN *)

(*---------------------------------------------------------------------*)

PROCEDURE INIT;

VAR 
    K: INTEGER;
BEGIN (* INIT *)
  LBUF := ' ';
  LPTR := LENGTH(LBUF)+1;
  MARK := FALSE;
  ROOT := NIL;
  LCOUNT := 0;
  WCOUNT := 0;
  WORDCOUNT := 0;
  DICTCOUNT := 0;
  CORECOUNT := VARAVAIL('speller'); (* MEMAVAIL *)
  SPACES := '';
  FOR K:=1 TO MAXCHAR DO SPACES := CONCAT(SPACES,' ');
  WRITELN('Speller');
  WRITELN
END; (* INIT *)

(*---------------------------------------------------------------------*)

PROCEDURE SORTTEXT;                            (* SORT THE TEXT *)

  PROCEDURE SORTTREE(VAR W1:WORDREF);    (* TRAVERSE THE TREE *)
  
  VAR 
      W: WORDREF;
  BEGIN (* SORTTREE *)
    W := W1;
    IF W=NIL
      THEN                     (* PLACE FOR NEW WORD FOUND *)
        BEGIN
          NEW(W);
          WITH W^ DO
            BEGIN
              KEY := TOKEN;       (* ENTER THE WORD *)
              COUNT := 1;
              LEFT := NIL;
              RIGHT := NIL;
              FIRST := LCOUNT
            END;
          W1 := W;
          WCOUNT := WCOUNT+1;
          DICTCOUNT := DICTCOUNT+1
        END
      ELSE IF TOKEN<W^.KEY THEN SORTTREE(W^.LEFT)
          ELSE IF TOKEN>W^.KEY THEN SORTTREE(W^.RIGHT)
              ELSE
                BEGIN                     (* OLD WORD FOUND *)
                  W^.COUNT := W^.COUNT+1;
                  WCOUNT := WCOUNT+1
                END
  END; (* SORTTREE *)

BEGIN (* SORTTEXT *)
  WRITELN;
  WRITE('Input text file:    ');
  READLN(SOURCE);
  FILEOK := RESETFILE(SOURCE);
  IF NOT FILEOK THEN EXIT(PROGRAM);
  OUT:=FALSE;
  TITLE := SOURCE;
  WRITELN;
  WRITE('Reading text ');
  DOTS := TRUE;
  GETTOKEN;
  WHILE NOT OUT DO
    BEGIN
      SORTTREE(ROOT);
      GETTOKEN
    END;
  WRITELN
END; (* SORTTEXT *)

(*---------------------------------------------------------------------*)

PROCEDURE CHECKDICT;                     (* CHECK THE WORD LIST *)

VAR 
    ENTRY: ALPHA;

  PROCEDURE GETENTRY;
  BEGIN
    IF DICTWRITE THEN WRITELINE(ENTRY);
    READLINE(ENTRY);
    IF LCOUNT MOD 100 = 0 THEN REPORT;
    LCOUNT := LCOUNT+1
  END;
  
  PROCEDURE CHECKTREE (W:WORDREF);       (* TRAVERSE THE TREE *)
  
    PROCEDURE CHECKWORD(VAR W:WORDREF);     (* LOOKUP THE WORD *)
    BEGIN (* CHECKWORD *)
      WHILE ENTRY < W^.KEY DO GETENTRY;
      IF ENTRY = W^.KEY
        THEN
          BEGIN
            W^.COUNT := 0;
            FLAGCOUNT := FLAGCOUNT-1
          END
        ELSE (* ENTRY > W^.KEY *)
          IF DICTWRITE
            THEN
              BEGIN
                WRITELN;
                WRITE('Line ',W^.FIRST:MAXDIGITS,
                      ' : ',W^.KEY:14,
                      ' not found.  Enter it (Y) ?');
                READ(CH);
                IF CH IN ['Y','y']
                  THEN
                    BEGIN
                      WRITELN;
                      IF DICTWRITE THEN WRITELINE(W^.KEY);
                      W^.COUNT := 0;
                      FLAGCOUNT := FLAGCOUNT-1
                    END
                  ELSE (* NOT CH IN Y,y *)
                    BEGIN
                      WRITE(' Flag for output (Y) ?');
                      READ(CH);
                      WRITELN;
                      IF NOT (CH IN ['Y','y'])
                        THEN
                          BEGIN
                            W^.COUNT := 0;
                            FLAGCOUNT := FLAGCOUNT-1
                          END
                    END
              END
    END; (* CHECKWORD *)
  
  BEGIN (* CHECKTREE *)
    IF W<>NIL
      THEN
        BEGIN
          CHECKTREE(W^.LEFT);
          CHECKWORD(W);
          CHECKTREE(W^.RIGHT)
        END
  END; (* CHECKTREE *)

BEGIN (* CHECKDICT *)
  LINECOUNT := LCOUNT;
  LCOUNT := 0;
  WORDCOUNT := WCOUNT;
  FLAGCOUNT := DICTCOUNT;
  WRITELN;
  WRITE('Input dict file:    ');
  READLN(SOURCE);
  FILEOK := RESETFILE(SOURCE);
  WRITELN;
  IF FILEOK
    THEN
      BEGIN
        WRITE('New dict file:      ');
        READLN(DEST);
        DICTWRITE := REWRITEFILE(DEST);
        DOTS := NOT DICTWRITE;
        WRITELN;
        WRITE('Checking text ');
        IF DICTWRITE THEN WRITELN;
        READLINE(ENTRY);
        CHECKTREE(ROOT);
        WHILE NOT EOFFLAG DO GETENTRY;
        IF DICTWRITE
          THEN
            BEGIN
              WRITELINE(ENTRY);
              CLOSEOUTFILE
            END;
        IF DOTS THEN WRITELN
      END
END; (* CHECKDICT *)

(*---------------------------------------------------------------------*)

PROCEDURE PRINTLIST;                    (* WRITE THE ERROR FILE *)

  PROCEDURE HEADER;           (* WRITE TOP OF OUTPUT FILE *)
  BEGIN (* HEADER *)
    WRITELINE('');
    WRITELINE(CONCAT('Spelling check of file ',TITLE));
    WRITELINE('');
    WRITELINE('');
    WRITELINE('Word               Count   Line');
    WRITELINE('')
  END; (* HEADER *)
  
  PROCEDURE PRINTTREE(W:WORDREF);        (* TRAVERSE THE TREE *)
  
    PROCEDURE WRITEIT;
    
    VAR 
        S1: STRING;
        S2:ALPHA;
        K:INTEGER;
      
      PROCEDURE CONV(X:INTEGER; VAR S:ALPHA);
        VAR
            D:INTEGER;
            J:INTEGER;
            L:INTEGER;
        BEGIN
          (*$R- *)
          L:=X;
          FOR J:=1 TO MAXDIGITS DO S[J]:='0';
          S[0]:=CHR(MAXDIGITS);
          J:=1;
          IF X > 9999 THEN
            BEGIN
              D := L DIV 10000;
              L:=L-D*10000;
              S[J]:=CHR(D+48);
            END
          ELSE S[J]:=' ';
          J:=J+1;
          IF X > 999 THEN
            BEGIN
              D := L DIV 1000;
              L:=L-D*1000;
              S[J]:=CHR(D+48);
            END
          ELSE S[J]:=' ';
          J:=J+1;
          IF X > 99 THEN
            BEGIN
              D := L DIV 100;
              L:=L-D*100;
              S[J]:=CHR(D+48);
            END
          ELSE S[J]:=' ';
          J:=J+1;
          IF X > 9 THEN
            BEGIN
              D := L DIV 10;
              L:=L-D*10;
              S[J]:=CHR(D+48);
            END
          ELSE S[J]:=' ';
          J:=J+1;
          S[J]:=CHR(L+48)
      (*$R+ *)
        END;
    
    BEGIN  (* CONVERT INTEGERS TO STRINGS FOR WRITELINE *)
      S1 := W^.KEY;
      (*$R- *)
      FOR K:=(LENGTH(S1)+1) TO MAXCHAR DO S1[K]:=' ';
      S1[0]:=CHR(MAXCHAR);
      (*$R+ *)
      CONV(W^.COUNT,S2);
      S1:=CONCAT(S1,'   ',S2);
      CONV(W^.FIRST,S2);
      S1:=CONCAT(S1,'   ',S2);
      WRITELINE(S1);
      IF LCOUNT MOD 10 = 0 THEN REPORT;
      LCOUNT := LCOUNT+1
    END;
  
  BEGIN (*PRINTTREE*)
    IF W<>NIL
      THEN
        BEGIN
          PRINTTREE(W^.LEFT);
          IF W^.COUNT<>0 THEN WRITEIT;
          PRINTTREE(W^.RIGHT)
        END
  END; (* PRINTTREE *)

BEGIN (*PRINTLIST*)
  IF FLAGCOUNT>0
    THEN
      BEGIN
        WRITELN;
        WRITE('Output list file:   ');
        READLN(DEST);
        FILEOK := REWRITEFILE(DEST);
        WRITELN;
        IF FILEOK
          THEN
            BEGIN
              DOTS := (POS(':',DEST)<>LENGTH(DEST));
              WRITE('Writing output list ');
              HEADER;
              LCOUNT := 0;
              PRINTTREE(ROOT);
              CLOSEOUTFILE;
              WRITELN
            END
      END
END; (* PRINTLIST *)

(*---------------------------------------------------------------------*)

PROCEDURE MARKTREE(W:WORDREF);

BEGIN
  IF TOKEN<W^.KEY THEN MARKTREE(W^.LEFT)
    ELSE IF TOKEN>W^.KEY THEN MARKTREE(W^.RIGHT)
        ELSE
          BEGIN (* FOUND A TOKEN *)
            IF W^.COUNT<>0
              THEN (* INSERT FLAG INTO LINE BUFFER *)
                BEGIN
                  LPTR := LPTR-1;
                  INSERT('<',LBUF,LPTR);
                  LPTR := LPTR+2
                END
          END
END;

PROCEDURE MARKTEXT;
BEGIN
  IF FLAGCOUNT>0
    THEN
      BEGIN
        WRITELN;
        FILEOK := RESETFILE(TITLE);
        IF NOT FILEOK
          THEN
            BEGIN
              WRITELN('Fatal error -- input file lost');
              EXIT(PROGRAM)
            END;
        WRITE('Marked text file:   ');
        READLN(DEST);
        FILEOK := REWRITEFILE(DEST);
        WRITELN;
        IF FILEOK
          THEN
            BEGIN
              WRITE('Marking text ');
              OUT:=FALSE;
              LCOUNT := 0;
              DOTS := (POS(':',DEST)<>LENGTH(DEST));
              READLINE(LBUF);
              LBUF:=CONCAT(LBUF,' ');
              LPTR:=1;
              MARK := TRUE;
              GETTOKEN;
              WHILE NOT OUT DO
                BEGIN
                  MARKTREE(ROOT);
                  GETTOKEN
                END;
              CLOSEOUTFILE;
              WRITELN
            END
      END
END; (* MARKTEXT *)

(*---------------------------------------------------------------------*)

PROCEDURE WRAPUP;
BEGIN (* WRAPUP *)
  WRITELN;
  WRITELN('Input lines:  ',LINECOUNT:8);
  WRITELN('Input words:  ',WORDCOUNT:8);
  WRITELN('Unique words: ',DICTCOUNT:8);
  WRITELN('Flagged words:',FLAGCOUNT:8);
  WRITELN('Free memory:  ',CORECOUNT:8)
END; (* WRAPUP *)

(*---------------------------------------------------------------------*)

BEGIN (* SPELLER *)
  INIT;
  SORTTEXT;
  CHECKDICT;
  PRINTLIST;
  MARKTEXT;
  WRAPUP
END.

========================================================================================
DOCUMENT :usus Folder:VOL23:stargame.text
========================================================================================

{
(*$L-PRINTER:*)
}

                            (****STARGAME.TEXT****)
                                (****4/1/83****)

(* Original autor is not known to me. This version executes only on the *)
(* Heathkit H-19 terminal.  Revised by Hays Busch. For more information *)
(* call 303-238-7227 or write 3071 Oak St., Lakewood, CO. 80215         *)
        
{  Modified (kludged) for terminal independence.  If you have an H-19, you
   can put back all the code that I commented out, and the game will look
   a little nicer, but it will work the same - gws }
   
PROGRAM THE_STAR_GAME;
CONST
  T_SID_HORZ = 3;               {top side horizontal}
  T_MID_HORZ = 9;               {top middle horizontal}
  B_MID_HORZ = 15;              {bottom etc.}
  B_SID_HORZ = 21;
  L_SID_VERT = 30;              {left side vertical}
  L_MID_VERT = 36;
  R_MID_VERT = 42;              {right etc.}
  R_SID_VERT = 48;
VAR
  star                  : ARRAY [1..9] OF 0..1;
  move_numb             : INTEGER;
  rand_seed             : REAL;
  u_r_c, l_r_c,                 {upper right corner, etc.}
  l_l_c, u_l_c,                 {lower left corner, etc.}
  h_ln, v_ln,                   {horiz and vert line}
  dn_t, lf_t,                   {down & left T}
  up_t, rt_t,                   {up & right T}
  crs                   : CHAR;  {cross}
  star_top,
  star_mid,
  star_bot              : STRING[3];
  
  PROCEDURE BELL;
  BEGIN
    WRITE(CHR(7));
  END;  {alarm}
  
  PROCEDURE CLEAR_SCREEN;
  var buf : packed array [ 0..23 ] of char;
  BEGIN
    (**WRITE(CHR(27),'E');  {H-19 clearscreen}*)
    fillchar ( buf, sizeof ( buf ) , chr ( 10 ) );
    gotoxy ( 0, 23 );
    unitwrite ( 2, buf, sizeof ( buf ) );
  END;  {clear screen}
  
  PROCEDURE CLR_LINE_RIGHT(clr_col,clr_row:INTEGER);
  var buf : packed array [ 0..79 ] of char;
  BEGIN
    fillchar ( buf, sizeof( buf ), chr ( 32 ) );
    GOTOXY(clr_col,clr_row);
    (**WRITE(CHR(27),'K'); {H-19 command}*)
    unitwrite ( 2, buf, 80-clr_col );
  END;  {clear line right}
  
  
  PROCEDURE START_GRAPHICS;
  BEGIN
    (*WRITE(CHR(27),'F'); {graphics on}
    write(CHR(27),'x5');{cursor off}*)
  END;  {start graphics and cursor off}
  
  PROCEDURE END_GRAPHICS;
  BEGIN 
    (*WRITE(CHR(27),'G'); {graphics mode off}
    write(CHR(27),'y5');{cursor on}*)
  END;  {end graphics and cursor on}
  
  FUNCTION REPLY_CHAR:CHAR;
  VAR
    rc_char     : CHAR;
  BEGIN
    READ(KEYBOARD,rc_char);
    REPLY_CHAR := rc_char;
  END;  {reply char}
  
  PROCEDURE INITIALIZE;
  VAR
    i_go_ahead  : CHAR;
    i_continue  : BOOLEAN;
  BEGIN
    GOTOXY(30,2);WRITE('THE STAR GAME');
    GOTOXY(15,4);WRITE('The object of the game is to fill all boxes in');
    GOTOXY(15,5);WRITE('the rectangle...EXCEPT #5...with a star.  The');
    GOTOXY(15,6);WRITE('problem is, when you change one star, you change');
    GOTOXY(15,7);WRITE('several other stars as well!');
    GOTOXY(15,9);WRITE('To change a star, type its box number.  Typing');
    GOTOXY(15,10);WRITE('an empty box number will just add one count to');
    GOTOXY(15,11);WRITE('your score...which is not good!');
    GOTOXY(15,13);WRITE('If you erase all stars, you lose right away.');
    GOTOXY(15,15);WRITE('Player who fills all boxes...EXCEPT #5...with a');
    GOTOXY(15,16);WRITE('star, in the least number of turns, wins.');
    GOTOXY(15,18);WRITE('There is a pattern to the play...try to find');
    GOTOXY(15,19);WRITE('it and you can win every time.  GOOD LUCK!');
    REPEAT
      BELL;
      GOTOXY(15,22);WRITE('Type "C" to continue  -> ');
      i_go_ahead := REPLY_CHAR;
      GOTOXY(40,22);WRITE(i_go_ahead);
      i_continue := FALSE;
      IF i_go_ahead IN ['C','c']
      THEN i_continue := TRUE;
    UNTIL i_continue;
    CLEAR_SCREEN;
    (**
    u_r_c := 'c';                       {Heath H-19 termainal graphics}
    l_r_c := 'd';
    l_l_c := 'e';
    u_l_c := 'f';
    h_ln := 'a';
    v_ln := '`';
    dn_t := 's';
    lf_t := 't';
    up_t := 'u';
    rt_t := 'v';
    crs := 'b';
    star_top := 'y`x';
    star_mid := 'aia';
    star_bot := 'x`y';
    *)
    u_r_c := '+';                       {ASCII character graphics - gws }
    l_r_c := '+';
    l_l_c := '+';
    u_l_c := '+';
    h_ln := '-';
    v_ln := '|';
    dn_t := '+';
    lf_t := '+';
    up_t := '+';
    rt_t := '+';
    crs := '+';
    star_top := '* *';
    star_mid := ' * ';
    star_bot := '* *';
    BELL;
    GOTOXY(20,10); WRITE('Enter a number between 1 and 100 -> ');
    READLN(rand_seed);
  END;  {initialize}
  
  PROCEDURE DRAW_FIELD;
  VAR
    df_x,
    df_y        : INTEGER;
  
    PROCEDURE DRAW_LINE(dl_x_start,dl_x_end,dl_y_start,dl_y_end:INTEGER);
    VAR
      dl_x_axis, dl_y_axis      : INTEGER;
      
      PROCEDURE DRAW_DIAG;
      BEGIN
        END_GRAPHICS;
        WRITE('LINE COORDINATES YIELD DIAGONAL');
        START_GRAPHICS;
      END;  {draw diagonal}
      
    BEGIN {draw_line}
      IF (dl_x_end <> dl_x_start) AND (dl_y_end <> dl_y_start)
      THEN DRAW_DIAG
      ELSE IF dl_x_end <> dl_x_start
           THEN                    {draw a horizontal line}
             BEGIN
               IF dl_x_start < dl_x_end
               THEN FOR dl_x_axis := dl_x_start TO dl_x_end DO
                      BEGIN
                        GOTOXY(dl_x_axis,dl_y_start); WRITE(h_ln);
                      END
               ELSE FOR dl_x_axis := dl_x_start DOWNTO dl_x_end DO
                      BEGIN
                        GOTOXY(dl_x_axis,dl_y_start); WRITE(h_ln);
                      END;
             END
           ELSE                    {draw a vertical line}
             BEGIN
               IF dl_y_start < dl_y_end
               THEN FOR dl_y_axis := dl_y_start TO dl_y_end DO
                      BEGIN
                        GOTOXY(dl_x_start,dl_y_axis); WRITE(v_ln);
                      END
               ELSE FOR dl_y_axis := dl_y_start DOWNTO dl_y_end DO
                      BEGIN
                        GOTOXY(dl_x_start,dl_y_axis); WRITE(v_ln);
                      END;
             END;
    END;  {draw line}
    
  BEGIN {draw field}
    CLEAR_SCREEN;
    START_GRAPHICS;
    
{first draw the box}

    DRAW_LINE((L_SID_VERT + 1),(R_SID_VERT - 1),T_SID_HORZ,T_SID_HORZ);
    GOTOXY(R_SID_VERT,T_SID_HORZ); WRITE(u_r_c);
    DRAW_LINE(R_SID_VERT,R_SID_VERT,(T_SID_HORZ + 1),(B_SID_HORZ - 1));
    GOTOXY(R_SID_VERT,B_SID_HORZ); WRITE(l_r_c);
    DRAW_LINE((R_SID_VERT - 1),(L_SID_VERT + 1),B_SID_HORZ,B_SID_HORZ);
    GOTOXY(L_SID_VERT,B_SID_HORZ); WRITE(l_l_c);
    DRAW_LINE(L_SID_VERT,L_SID_VERT,(B_SID_HORZ - 1),(T_SID_HORZ + 1));
    GOTOXY(L_SID_VERT,T_SID_HORZ); WRITE(u_l_c);
    
{next the high middle line}

    GOTOXY(L_SID_VERT,T_MID_HORZ); WRITE(rt_t);
    DRAW_LINE((L_SID_VERT + 1),(R_SID_VERT - 1),T_MID_HORZ,T_MID_HORZ);
    GOTOXY(R_SID_VERT,T_MID_HORZ); WRITE(lf_t);
    
{next low middle line}

    GOTOXY(L_MID_VERT,T_SID_HORZ); WRITE(dn_t);
    DRAW_LINE(L_MID_VERT,L_MID_VERT,(T_SID_HORZ + 1),(T_MID_HORZ - 1));
    GOTOXY(L_MID_VERT,T_MID_HORZ); WRITE(crs);
    DRAW_LINE(L_MID_VERT,L_MID_VERT,(T_MID_HORZ + 1),(B_SID_HORZ - 1));
    GOTOXY(L_MID_VERT,B_SID_HORZ); WRITE(up_t);
    
{next low middle line}

    GOTOXY(L_SID_VERT,B_MID_HORZ); WRITE(rt_t);
    DRAW_LINE((L_SID_VERT + 1),(L_MID_VERT - 1),B_MID_HORZ,B_MID_HORZ);
    GOTOXY(L_MID_VERT,B_MID_HORZ); WRITE(crs);
    DRAW_LINE((L_MID_VERT + 1),(R_SID_VERT - 1),B_MID_HORZ,B_MID_HORZ);
    GOTOXY(R_SID_VERT,B_MID_HORZ); WRITE(lf_t);
    
{finally right middle line}

    GOTOXY(R_MID_VERT,T_SID_HORZ); WRITE(dn_t);
    DRAW_LINE(R_MID_VERT,R_MID_VERT,(T_SID_HORZ + 1),(T_MID_HORZ - 1));
    GOTOXY(R_MID_VERT,T_MID_HORZ); WRITE(crs);
    DRAW_LINE(R_MID_VERT,R_MID_VERT,(T_MID_HORZ + 1),(B_MID_HORZ - 1));
    GOTOXY(R_MID_VERT,B_MID_HORZ); WRITE(crs);
    DRAW_LINE(R_MID_VERT,R_MID_VERT,(B_MID_HORZ + 1),(B_SID_HORZ - 1));
    GOTOXY(R_MID_VERT,B_SID_HORZ); WRITE(up_t);
    
{then number the boxes}

    GOTOXY((L_SID_VERT + 1),(T_SID_HORZ + 1)); WRITE('1');
    GOTOXY((L_MID_VERT + 1),(T_SID_HORZ + 1)); WRITE('2');
    GOTOXY((R_MID_VERT + 1),(T_SID_HORZ + 1)); WRITE('3');
    GOTOXY((L_SID_VERT + 1),(T_MID_HORZ + 1)); WRITE('4');
    GOTOXY((L_MID_VERT + 1),(T_MID_HORZ + 1)); WRITE('5');
    GOTOXY((R_MID_VERT + 1),(T_MID_HORZ + 1)); WRITE('6');
    GOTOXY((L_SID_VERT + 1),(B_MID_HORZ + 1)); WRITE('7');
    GOTOXY((L_MID_VERT + 1),(B_MID_HORZ + 1)); WRITE('8');
    GOTOXY((R_MID_VERT + 1),(B_MID_HORZ + 1)); WRITE('9');
    END_GRAPHICS;
  END;  {draw field}
  
  PROCEDURE DRAW_STAR(ds_star:INTEGER);
  VAR
    ds_x,
    ds_y       : INTEGER;
  BEGIN
    START_GRAPHICS;
    CASE ds_star OF                             {first find out which star}
      1: BEGIN
           ds_x := L_SID_VERT + 2;
           ds_y := T_SID_HORZ + 2;
         END;
      2: BEGIN
           ds_x := L_MID_VERT + 2;
           ds_y := T_SID_HORZ + 2;
         END;
      3: BEGIN
           ds_x := R_MID_VERT + 2;
           ds_y := T_SID_HORZ + 2;
         END;
      4: BEGIN
           ds_x := L_SID_VERT + 2;
           ds_y := T_MID_HORZ + 2;
         END;
      5: BEGIN
           ds_x := L_MID_VERT + 2;
           ds_y := T_MID_HORZ + 2;
         END;
      6: BEGIN
           ds_x := R_MID_VERT + 2;
           ds_y := T_MID_HORZ + 2;
         END;
      7: BEGIN
           ds_x := L_SID_VERT + 2;
           ds_y := B_MID_HORZ + 2;
         END;
      8: BEGIN
           ds_x := L_MID_VERT + 2;
           ds_y := B_MID_HORZ + 2;
         END;
      9: BEGIN
           ds_x := R_MID_VERT + 2;
           ds_y := B_MID_HORZ + 2;
         END;
    END; {case}
    IF star[ds_star] <> 0
    THEN                                        {build the star}
      BEGIN
        GOTOXY(ds_x,ds_y + 0); WRITE(star_top);     {  \|/  }
        GOTOXY(ds_x,ds_y + 1); WRITE(star_mid);     {  -*-  }
        GOTOXY(ds_x,ds_y + 2); WRITE(star_bot);     {  /|\  }
      END
    ELSE
      BEGIN
        GOTOXY(ds_x,ds_y + 0); WRITE('   ');
        GOTOXY(ds_x,ds_y + 1); WRITE('   ');
        GOTOXY(ds_x,ds_y + 2); WRITE('   ');
      END;
    END_GRAPHICS;                                  {shut off the graphics}
  END;  {draw star}
  
  PROCEDURE GEN_BOARD;
  VAR
    gb_index    : INTEGER;
  
    FUNCTION RANDOM:INTEGER;
    VAR
      r_ptr      :^REAL;
      r_int      :INTEGER;
    BEGIN
      REPEAT
        NEW(r_ptr);
      UNTIL r_ptr^ <> 0;
      IF r_ptr^ < 0
      THEN r_ptr^ := 0 - r_ptr^;
      rand_seed := rand_seed * r_ptr^;
      REPEAT
        WHILE rand_seed > 1 DO
          rand_seed := rand_seed / 10;
        WHILE rand_seed < 0.1 DO
          rand_seed := rand_seed * 10;
        r_int := TRUNC(rand_seed * 10.0);
      UNTIL (r_int >= 1) AND (r_int <= 9);
      RANDOM := r_int;
    END;  {random}
    
  BEGIN {gen_board}
    DRAW_FIELD;
    FOR gb_index := 1 TO 9 DO
      star[gb_index] := 0;
    star[RANDOM] := 1;
    FOR gb_index := 1 TO 9 DO
      DRAW_STAR(gb_index);
    move_numb := 1;
  END;  {generate board}
  
  PROCEDURE PLAY;
  VAR
    p_move      : CHAR;
    p_index     : INTEGER;
  
    PROCEDURE FLIP(fstar:INTEGER);
    BEGIN
      IF star[fstar] = 0
      THEN star[fstar] := 1
      ELSE star[fstar] := 0;
      DRAW_STAR(fstar);
    END;  {flip}
    
    FUNCTION FINISHED:BOOLEAN;
    VAR
      f_sum,
      f_index   : INTEGER;
    BEGIN
      f_sum := 0;
      FOR f_index := 1 to 9 DO
        f_sum := f_sum + star[f_index];
      IF (f_sum = 0) OR ((f_sum = 8) AND (star[5] = 0))
      THEN FINISHED := TRUE
      ELSE FINISHED := FALSE;
    END;  {finished}
    
  BEGIN {play}
    REPEAT
      GOTOXY(60,0); WRITE('MOVE -> ',move_numb:3);
      GOTOXY(0,0); WRITE('Enter move -> ');
      IF move_numb = 35
      THEN
        BEGIN
          BELL;
          GOTOXY(0,24); WRITE('Give up ???  Type "Q" instead of box number');
          GOTOXY(15,0);
        END;
      p_move := REPLY_CHAR;
      IF p_move IN ['Q','q']
      THEN
        BEGIN
          CLEAR_SCREEN;
          EXIT(PROGRAM);
        END;
      IF p_move IN ['1'..'9']
      THEN
        BEGIN
          p_index := ORD(p_move) - ORD('0');
          IF star[p_index] = 1
          THEN CASE p_index OF
                 1: BEGIN
                      FLIP(1);
                      FLIP(5);
                      FLIP(4);
                      FLIP(2);
                    END;
                 2: BEGIN
                      FLIP(2);
                      FLIP(1);
                      FLIP(3);
                    END;
                 3: BEGIN
                      FLIP(3);
                      FLIP(5);
                      FLIP(2);
                      FLIP(6);
                    END;
                 4: BEGIN
                      FLIP(4);
                      FLIP(7);
                      FLIP(1);
                    END;
                 5: BEGIN
                      FLIP(5);
                      FLIP(2);
                      FLIP(6);
                      FLIP(8);
                      FLIP(4);
                    END;
                 6: BEGIN
                      FLIP(6);
                      FLIP(3);
                      FLIP(9);
                    END;
                 7: BEGIN
                      FLIP(7);
                      FLIP(5);
                      FLIP(8);
                      FLIP(4);
                    END;
                 8: BEGIN
                      FLIP(8);
                      FLIP(9);
                      FLIP(7);
                    END;
                 9: BEGIN
                      FLIP(9);
                      FLIP(5);
                      FLIP(6);
                      FLIP(8);
                    END;
                 END; {case}
          move_numb := move_numb + 1;
        END
      ELSE
        BEGIN
          FOR p_index := 1 TO 10 DO
            BELL;
        END;
    UNTIL FINISHED;
    IF star[1] = 1                      {test for win vs loss}
    THEN
      BEGIN
        GOTOXY(0,23);
        WRITE('You won in -> ',(move_numb - 1):3,' moves.  ');
        BELL;
      END
    ELSE
      BEGIN
        GOTOXY(0,23);
        WRITE('You lost in -> ',(move_numb - 1):3,' moves.  ');
        FOR p_index := 1 TO 250 DO
          BELL;
      END;
  END;  {play}
  
BEGIN {star game}
  CLEAR_SCREEN;
  INITIALIZE;
  REPEAT
    GEN_BOARD;
    PLAY;
    CLR_LINE_RIGHT(0,24);
    WRITE('Another game?  <Y/N> ');
  UNTIL NOT(REPLY_CHAR IN ['y','Y']);
  CLEAR_SCREEN;
END.  {program}


========================================================================================
DOCUMENT :usus Folder:VOL23:vol23.doc.text
========================================================================================

                                 USUS Volume 23
                 A Spelling Checker, a IV.x menu driven Filer 
                              and some other stuff

VOL23:
STARGAME.TEXT     28 A simple, but captivating game
RNDTEST.TEXT      16 A random number generator and some simple tests
RNDDOC.TEXT       14 Documentation for RNDTEST
IOUNIT.TEXT       16 A unit to quickly read and write characters and strings
IOTEST.TEXT        8 A program to test and benchmark IOUNIT
IODOC.TEXT        10 Documentation for IOUNIT and IOTEST
SPELLER.TEXT      24 A Pascal spelling checker that uses IOUNIT
DICT.TEXT         78 A small literal dictionary for SPELLER
SPELLDOC.TEXT     18 Documentation for SPELLER and DICT
DF.DOCUM.TEXT     26 The Display Filer Documentation
DF.IV.0.TEXT      86 Display Filer for IV.0
DF.IV.1.TEXT      96 Display Filer for IV.1
VOL23.DOC.TEXT     8 You're reading it
-----------------------------------------------------------------------------
Please transfer the text below to a disk label if you copy this volume.

    USUS Volume 23 -***- USUS Software Library
                         
   For not-for-profit use by USUS members only.
  May be used and distributed only according to 
      stated policy and the author's wishes.



This volume was assembled by George Schreyer from material collected by
the Library committee.

__________________________________________________________________________




========================================================================================
DOCUMENT :usus Folder:VOL24:adv.miscinfo
========================================================================================

24 80


========================================================================================
DOCUMENT :usus Folder:VOL24:advx.doc.text
========================================================================================


                                    ADVENTURE 

     The history of this version of Adventure has been lost, and I am
     unable to credit the originator.  This program was converted to UCSD
     Pascal from a PL/1 version found on our local computer system.  This
     version was obviously converted from a Fortran version (it said so in
     the comments) but any history was not indicated.  If you need
     assistance with this program, you can write me.  My address is:

                               Michael R. Turner
                               1622 Colonial Way
                               Frederick, Md. 21701
                               (301)-663-9181

     Extended by Ted Beck.  The changes to make the 500-point version were
     converted from a CDC CYBER 74 FORTRAN program written by Tony Jarrett
     and Paul Zemlin.  It in turn was modified from an early DEC PDP-11
     FORTRAN version of Adventure.

     Some bugs fixed by George Schreyer.  In particular, the data files
ADVXxx.TEXT are VERY sensitive to a blank line at the end of the file. There
should NOT be a blank line.  Also, the initialization procedure would eat both
of my machines alive.  It was reading an even number of blocks onto a space on
the heap not large enough to hold the data, causing damage to whatever was just
above that space, usually the code pool. I padded the data spaces to make room.
Also, the entire program was one segment of 10,000+ words.  This is too big to
run on the LSI-11 extended memory system and probably some others.  I segmented
the program (in no particularly readonable fashion) to allow the program to run
on smaller machines.  If you don't like it, just comment out the 'segment's.
     
GETTING STARTED.

The steps required to run Adventure are:


1).  Compile ADVxINIT.  Files needed are:

        ADVxINIT.TEXT
        ADVxCONS.TEXT


2).  Compile ADVx.  Files needed are:

        ADVx.TEXT
        ADVxCONS.TEXT
        ADVxSUBS.TEXT
        ADVxVERB.TEXT
        ADVxSEGS.TEXT

3).  Run ADVxINIT to build the run-time data files for Adventure.
     Files needed are:

        ADVxS1.TEXT
        ADVxS2.TEXT
        ADVxS3.TEXT
        ADVxS4.TEXT
        ADVxS5.TEXT
        ADVxS6.TEXT
        ADVxS7.TEXT
        ADVxS8.TEXT
        ADVxS9.TEXT
        ADVxS10.TEXT
        ADVxS11.TEXT
        ADVxINIT.CODE

     There are two output files produced by ADVxINIT:

        ADVxMSGS[95]
        ADVxDATA[24]

     Insure that there are at least 119 free contiguous blocks on the
     default disk.  ADVxINIT creates the message file completely before
     opening the data file.  That way ADVxINIT will complete execution
     successfully even if only 119 free blocks are available.


4).  Build an ADV.MISCINFO file.  This is nothing more than a text file
     with two numbers in it.  The format is HEIGHT WIDTH (e.g. 24 80).  If
     you are an APPLE user using the 24x40 screen, this file is not needed
     (see Notes, below).


5).  The only files needed to run Adventure are:

        ADVxDATA
        ADVxMSGS
        ADVx.CODE
        ADV.MISCINFO (optional)


6).  Be prepared to spend hours exploring the cave.  Try not to look at
     the source or the data files until all of Adventuredom pays tribute
     to you, O Grand Master Adventurer!


Notes:

     There is a save game feature.  Try SAVE.  You might like it.  The
     program asks for your name, but any identifier can be used as long as
     it is valid for a filename.  Each save file requires 6 blocks.

     The system clock is used to initialize the random number generator.
     If the value returned by the TIME function is zero, then the user is
     prompted for a number to start the random number generator.

     The system MISCINFO is not used because the APPLE sets the screen
     width to 80 on the 40 character screen.  Flipping side to side may be
     OK during editing, but not during Adventure.  Also, The program
     defaults are such that APPLE users do not need an ADV.MISCINFO.

     ADVx.TEXT has {$S+} to allow it to compile on most machines.


=========================================================================
PROGRAM-SECTION. 


ADVx.TEXT............The Adventure program.


ADVxCONS.TEXT........Include file of constants for array dimensions.


ADVxSUBS.TEXT........Include file of Adventure subprograms.


ADVxVERB.TEXT........Include file of Adventure subprograms.


ADVxINIT.TEXT........Initialization program.  This program reads ADVxS1
                     through ADVxS11 and produces ADVxDATA and ADVxMSGS.


=========================================================================
DATA-FILES-SECTION.


ADVx.MISCINFO........Miscellaneous information for Adventure.


ADVxS1.TEXT..........Long form descriptions.

     Each line contains a location number, a space, and a line of text.
     The set of adjacent lines whose numbers are X form the long
     description of location X.


ADVxS2.TEXT..........Short form descriptions.

     Same format as ADVxS1.  Not all places have short descriptions.


ADVxS3.TEXT..........Travel Table.

     Each line contains a location number (X), a condition value (M), a
     second location number (N), and a list of motion numbers from 
     ADVxS4.  Each motion represents a verb which will take you to N
     if you are at X.  M and N are interpreted as follows:

        If N<=300     location to go to.
        If 300<N<=500 N-300 is used to select special code.
        If N>500      Message N-500 is to be issued.

     Meanwhile, M specifies the condition of motion:

        If M=0        Unconditional.
        If 0<M<100    M% probability of motion.
        If M=100      Unconditional but forbidden to dwarves.
        If 100<M<=200 Must be carrying object M-100.
        If 200<M<=300 Must be carrying or be in the same room as M-200.
        If 300<M<=400 Property of (M MOD 100) must <> 0.
        If 400<M<=500 Property of (M MOD 100) must <> 1.
        If 500<M<=600 Property of (M MOD 100) must <> 2.
                      Etc.

     If the condition is not met, then the next *DIFFERENT* 'destination'
     value is used (Unless it fails to meet *IT'S* conditions, in which
     case the next is found, etc.).  Typically, the next destination will
     be for one of the same verbs, so that its only use is as the
     alternate destination for those verbs.  For instance:

               15  110  22  29  31  34  35  23  43
               15    0  14  45

     says that from location 15, any of the verbs (29, 31, ..., 43) will take
     you to 22 if you are carrying object 10.  Otherwise, they or verb 45
     will take you to location 14.  And:

               11  303   8  49
               11    0   9  50

     says that from 11, 49 takes him to 8 unless the PROP(3)=0.  In that
     case, 49 takes you to 9.  Verb 50 always takes you to 9.


ADVxS4.TEXT..........Vocabulary

     Each line contains a number and a five letter word.  Let M=N DIV 1000.

        If M=0.  The word is a motion verb used in ADVxS3.
        If M=1.  The word is an object.
        If M=2.  The word is an action word (e.g. ATTACK).
        If M=3.  Special case word.  N MOD 1000 is an index into ADVxS6
                 messages.


ADVxS5.TEXT..........Object descriptions.

     Each line contains a number and a message.  If 1<=N<=100, it is the
     'INVENTORY' message for object N.  Otherwise N should be 000, 100, 200
     etc. and the message is the description of the preceding object when
     it's property value is N DIV 100.  The N DIV 100 is used to
     distinguish multiple messages from multi-line messages.  Properties
     that produce no message must be given a null message.


ADVxS6.TEXT..........Miscellaneous messages.

     Same format as ADVxS1, ADVxS2 and ADVxS5, except that the numbers are
     not related to anything.  (Except for special verbs in ADVxS4).


ADVxS7.TEXT..........Object locations.

     Each line contains an object number and its initial location (zero if
     none) and a second location (also zero if none).  If the object is
     immovable, the second location is set to -1.  If the object has two
     locations (e.g. GRATE), the second location field is set to the second
     location and is assumed to be immovable.


ADVxS8.TEXT..........Action defaults.

     Each line contains an 'ACTION-VERB' number and the index (into ADVxS6)
     of the default message for the verb. 


ADVxS9.TEXT..........Liquid Assetts, etc.

     Each line contains a number (N) and up to 20 location numbers.  Bit N
     (where 0 is the units bit) is set in COND(LOC) for each loc given.
     The bits currently assigned are:

               0   Location is not dark.
               1   If bit 2 is on; 1=oil, 0=water.
               2   Liquid asset, set bit 1.
               3   Pirate doesn't go here unless following player.

     The other bits are used to indicate areas of interest to the hint
     routines:
               4 Trying to get into the cave.
               5 Trying to catch the bird.
               6 Trying to deal with the snake.
               7 Lost in a maze.
               8 Pondering the dark room.
               9 At Witt's end.  COND(LOC) is set to 2, overriding all
                 other bits, if LOC has forced motion.


ADVxS10.TEXT.........Player class messages.

     Each line contains a number N and a message describing the
     classification of the player.  The scoring section selects the
     appropriate message.  A message applies to a players whose scores are
     higher than the previous N but not higher than this N.


ADVxS11.TEXT.........Hints.

     Each line contains a hint number corresponding to the COND(LOC) bits
     (see ADVxS9), the number of turns he must be at the right LOC(s)
     before triggering the hint, the points deducted for the hint, the
     message number of the question (from ADVxS6) and the message number
     of the hint (also from ADVxS6).  Hint numbers 1-3 are not usable as
     the COND(LOC) bits 1-3 are otherwise assigned.


ADVxDATA and ADVxMSGS.....Run-time data files.

     These files are produced by ADVxINIT from ADVxS1..ADVxS11.  They
     must be on the default disk in order to run the Adventure program.


=========================================================================

========================================================================================
DOCUMENT :usus Folder:VOL24:advx.text
========================================================================================

{$S+} 
PROGRAM ADVENTURE;

CONST
  {$I advxcons.text }
  VERSION = 500;
  KEYS = 1;
  LAMP = 2;
  GRATE = 3;
  CAGE = 4;
  ROD = 5;
  ROD2 = 6;
  STEPS = 7;
  BIRD = 8;
  DOOR = 9;
  PILLOW = 10;
  SNAKE = 11;
  FISSURE = 12;
  TABLET = 13;
  CLAM = 14;
  OYSTER = 15;
  MAGAZINE = 16;
  DWARF = 17;
  KNIFE = 18;
  FOOD = 19;
  BOTTLE = 20;
  WATER = 21;
  OIL = 22;
  MIRROR = 23;
  PLANT = 24;
  PLANT2 = 25;
  AXE = 28;
  DRAGON = 31;
  CHASM = 32;
  TROLL = 33;
  TROLL2 = 34;
  BEAR = 35;
  MESSAGE = 36;
  VEND_MACHINE = 38;
  BATTERY = 39;
  wizard = 41;
  door2 = 42;
  ball = 43;
  
  NUGGET = 50;
  COINS = 54;
  CHEST = 55;
  EGGS = 56;
  TRIDENT = 57;
  VASE = 58;
  EMERALD = 59;
  PYRAMID = 60;
  PEARL = 61;
  RUG = 62;
  SPICES = 63;
  CHAIN = 64;
  jade = 68;
  scroll = 70;
  
  BACK = 8;
  NULL = 21;
  LOOK = 57;
  DEPRESSION = 63;
  ENTRANCE = 64;
  CAVE = 67;
  
  SAY = 3;
  LOCK = 6;
  THROW = 17;
  FIND = 19;
  INVENTORY = 20;
  
  MAXTRS = 73;
  MAXDIE = 3;
  MAXHLD = 6;
  DALTLC = 18;

TYPE
  CH512 = PACKED ARRAY[1..512] OF CHAR;
  CHAR6 = PACKED ARRAY[1..6] OF CHAR;
  ARYS = RECORD
           CASE BOOLEAN OF
             FALSE : (DBLK    : CH512);
             TRUE  : (TRAVEL  : ARRAY[1..trvsiz] OF INTEGER;
                      TRAVEL2 : ARRAY[1..trvsiz] OF INTEGER;
                      TRAVEL3 : ARRAY[1..trvsiz] OF INTEGER;
                      ATAB    : ARRAY[1..tabsiz] OF STRING[5];
                      KTAB    : ARRAY[1..tabsiz] OF INTEGER;
                      LTEXT   : ARRAY[1..locsiz] OF INTEGER;
                      STEXT   : ARRAY[1..locsiz] OF INTEGER;
                      KEY     : ARRAY[1..locsiz] OF INTEGER;
                      PLAC    : ARRAY[1..100] OF INTEGER;
                      FIXD    : ARRAY[1..100] OF INTEGER;
                      PTEXT   : ARRAY[1..100] OF INTEGER;
                      ACTSPK  : ARRAY[1..vrbsiz] OF INTEGER;
                      RTEXT   : ARRAY[1..rtxsiz] OF INTEGER;
                      CTEXT   : ARRAY[1..clsmax] OF INTEGER;
                      CVAL    : ARRAY[1..clsmax] OF INTEGER;
                      HINTS   : ARRAY[1..hntmax, 1..4] OF INTEGER;
                      pad     : packed array [ 1..70 ] of char) {round out
                                                              19 blocks - gws }
         END;
  VARYS = RECORD
            CASE BOOLEAN OF
              FALSE : (DBLK   : CH512);
              TRUE  : (COND   : ARRAY[1..locsiz] OF INTEGER;
                       ABB    : ARRAY[1..locsiz] OF INTEGER;
                       ATLOC  : ARRAY[1..locsiz] OF INTEGER;
                       PLACE  : ARRAY[1..100] OF INTEGER; 
                       FIXED  : ARRAY[1..100] OF INTEGER;
                       LINK   : ARRAY[1..200] OF INTEGER;
                       PROP   : ARRAY[1..100] OF INTEGER;
                       HINTLC : ARRAY[1..hntmax] OF INTEGER;
                       HINTED : ARRAY[1..hntmax] OF BOOLEAN;
                       DSEEN  : ARRAY[1..6] OF BOOLEAN;
                       DLOC   : ARRAY[1..6] OF INTEGER;
                       ODLOC  : ARRAY[1..6] OF INTEGER;
                       TK     : ARRAY[1..20] OF INTEGER;
                       PADDER : PACKED ARRAY [ 1..444 ] OF CHAR) {round out
                                                                5 blocks - gws}
          END;
  VBLS = RECORD
           CASE BOOLEAN OF
             FALSE : (DBLK : CH512);
             TRUE  : (HLDING, LOC, OLDLOC : INTEGER;
                      OLDLC2, CLOCK1, CLOCK2 : INTEGER;
                      CHLOC,CHLOC2, TALLY, TALLY2 : INTEGER;
                      DFLAG, DTOTAL, FOOBAR, TURNS : INTEGER;
                      VERB, OBJ, LIMIT, IWEST, KNFLOC : INTEGER;
                      ABBNUM, DKILL, NUMDIE, DETAIL : INTEGER;
                      PANIC, CLOSING, CLOSED, WZDARK : BOOLEAN;
                      wizflg, stflag, VERSION : INTEGER;
                      PASSWORD : STRING[20])
         END;

VAR
  NEWLOC, RESTART, I, J, K, KK, K2 : INTEGER;
  MAXSCORE, TVCOND, ATTACK, STICK : INTEGER;
  FOO, SCORE, HINT, SPK : INTEGER;
  wizbo, BONUS, SEED : INTEGER;
  RESUME, OK, SKIPIT, STEAL : BOOLEAN;
  GAVEUP, YEA, SKIPDWARF, ALLDONE, HE_DIED, PIT : BOOLEAN; 
  NEWLOCSET, LMWARN, SKIPDESCRIBE : BOOLEAN;
  HNTSIZ, CLSSES : INTEGER;
  ARY : ^ARYS;
  VARY : ^VARYS;
  VBL : ^VBLS;
  LINE, TERMWIDTH, TERMHIGHT : INTEGER;
  KKWORD, WD1, WD2 : STRING[5];
  WD1X, WD2X : STRING;
  ACHAR : STRING[1];
  TESTPW : STRING[20];
  NAMEOFUSER : STRING[40];
  INFILE : FILE;
  MSGFILE : FILE OF CHAR6;

  PROCEDURE READINIT(VAR BFR : CH512; NUM : INTEGER); forward;
  
  
  segment PROCEDURE INITIALIZE;

  VAR
    I, J, K, X : INTEGER;
    ININFO : TEXT;


    PROCEDURE INITP2;

    VAR
      I, J : INTEGER;

    BEGIN { INITP2 }
      TIME(I, J);
      IF J = 0 THEN J := I;
      WHILE J = 0 DO
        BEGIN
          WRITELN('No clock.');
          WRITELN('Please enter a number from 1 to 32767 ');
          READ(J);
          WRITELN
        END;
      IF (J MOD 2) = 0 THEN J := J + 1;
      SEED := J;
      LINE := 1;
      VARY^.DLOC[1] := 19;
      VARY^.DLOC[2] := 27; 
      VARY^.DLOC[3] := 33;
      VARY^.DLOC[4] := 44;
      VARY^.DLOC[5] := 64;
      VARY^.DLOC[6] := 114;
      vbl^.wizflg := 0;
      vbl^.stflag := 0;
      VBL^.CHLOC := 86;
      VBL^.CHLOC2 := 140;
      VBL^.ABBNUM := 5;
      BONUS := 0;
      VBL^.OLDLOC := 0;
      VBL^.OLDLC2 := 0;
      RESTART := 0;
      KK := 0;
      VBL^.TALLY := 0;
      VBL^.TALLY2 := 0;
      TVCOND := 0;
      VBL^.DKILL := 0;
      VBL^.DFLAG := 0;
      VBL^.DTOTAL := 0;
      ATTACK := 0;
      STICK := 0;
      VBL^.KNFLOC := 0;
      MAXSCORE := 0;
      VBL^.FOOBAR := 0;
      VBL^.TURNS := 0;
      VBL^.VERB := 0;
      VBL^.OBJ := 0;
      VBL^.IWEST := 0;
      FOO := 0;
      VBL^.NUMDIE := 0;
      SCORE := 0;
      VBL^.DETAIL := 0;
      VBL^.HLDING := 0;
      SPK := 0;
      OK := FALSE;
      SKIPIT := FALSE;
      STEAL := FALSE;
      VBL^.PANIC := FALSE;
      VBL^.CLOSING := FALSE;
      VBL^.CLOSED := FALSE;
      VBL^.WZDARK := FALSE;
      GAVEUP := FALSE;
      SKIPDWARF := FALSE;
      ALLDONE := FALSE;
      LMWARN := FALSE;
      SKIPDESCRIBE := FALSE;
      ALLDONE := FALSE;
      HE_DIED := FALSE;
      PIT := FALSE;
      NEWLOCSET := FALSE;
      KKWORD := '';
      WD1 := '';
      WD2 := '';
      WD1X := '';
      WD2X := '';
      ACHAR := ' '
    END;  { INITP2 }


  BEGIN { INITIALIZE }
    { READ IN ARRAYS }
    {$I-}
    RESET(ININFO, 'ADV.MISCINFO');
    {$I+}
    IF IORESULT = 0 THEN
      BEGIN
        READ(ININFO, TERMHIGHT, TERMWIDTH);
        CLOSE(ININFO)
      END
    ELSE
      BEGIN
        TERMHIGHT := 24;  { DEFAULT FOR APPLE }
        TERMWIDTH := 40
      END;
    RESET(INFILE, 'ADVxDATA');
    RESET(MSGFILE, 'ADVxMSGS');
    NEW(ARY);
    READINIT(ARY^.DBLK, SIZEOF(ARYS));
    NEW(VARY);
    READINIT(VARY^.DBLK, SIZEOF(VARYS));
    CLOSE(INFILE);
    NEW(VBL);
    INITP2;
    CLSSES := 0;
    FOR I := 1 TO clsmax DO IF ARY^.CTEXT[I] <> 0 THEN CLSSES := I;
    FOR I := 4 TO hntmax DO IF ARY^.HINTS[I, 1] <> 0 THEN HNTSIZ := I;
    FOR X := 50 TO 100 DO
      IF ARY^.PTEXT[X] <> 0 THEN VBL^.TALLY := VBL^.TALLY - VARY^.PROP[X];
    FOR I := 1 TO tabsiz DO
      IF ARY^.ATAB[I] = '' THEN
        BEGIN
          ARY^.ATAB[I] := '     ';
          ARY^.ATAB[I, 1] := CHR(255);
          ARY^.ATAB[I, 2] := CHR(I DIV 256);
          ARY^.ATAB[I, 3] := CHR(I MOD 256)
        END
  END;  { INITIALIZE }

  {$I ADVXSEGS  .TEXT }

  SEGMENT PROCEDURE DOWHATHESAYS;

  {$I ADVxVERB.TEXT }

    PROCEDURE ANALANOBJ;


      PROCEDURE ASKWHATTODO;

      BEGIN
        IF WD2 <> '' THEN
          BEGIN
            RESTART := 1;
            EXIT(ANALANOBJ)
          END;
        IF VBL^.VERB <> 0 THEN
          BEGIN
            ANALATVERB;
            EXIT(ANALANOBJ)
          END;
        WRITELN('What do you want to do with the ', WD1, WD1X, '.');
        RESTART := 1;
        EXIT(DOWHATHESAYS)
      END;  { ASKWHATTODO }


    BEGIN { ANALANOBJ }
      VBL^.OBJ := K;
      IF (VARY^.FIXED[K] = VBL^.LOC) OR HERE(K) THEN ASKWHATTODO;
      IF K = GRATE THEN
        BEGIN
          IF (VBL^.LOC = 1) OR (VBL^.LOC = 4) OR (VBL^.LOC = 7) THEN
             K := DEPRESSION;
          IF (VBL^.LOC > 9) AND (VBL^.LOC < 15) THEN K := ENTRANCE;
          IF K <> GRATE THEN
            BEGIN
              SET_NEW_LOC;
              EXIT(ANALANOBJ)
            END
        END;
      IF K = DWARF THEN
        FOR I := 1 TO 5 DO
          IF (VARY^.DLOC[I] = VBL^.LOC) AND (VBL^.DFLAG >= 2) THEN ASKWHATTODO;
      IF ((LIQ = K) AND HERE(BOTTLE)) OR (K = LIQLOC(VBL^.LOC)) THEN
        ASKWHATTODO;
      IF (VBL^.OBJ = PLANT) AND AT(PLANT2) AND (VARY^.PROP[PLANT2] = 0) THEN
        BEGIN
          VBL^.OBJ := PLANT2;
          ASKWHATTODO
        END;
      if ( vbl^.obj = door ) and at ( door2 ) then
         begin
            vbl^.obj := door2;
            askwhattodo;
         end;  
      IF (VBL^.OBJ = KNIFE) AND (VBL^.KNFLOC = VBL^.LOC) THEN
        BEGIN
          VBL^.KNFLOC := -1;
          SPEAK(ARY^.RTEXT[116])
        END
      ELSE
        IF (VBL^.OBJ = ROD) AND HERE(ROD2) THEN
          BEGIN
            VBL^.OBJ := ROD2;
            ASKWHATTODO
          END
        ELSE
          IF ((VBL^.VERB = FIND) OR (VBL^.VERB = INVENTORY)) AND
            (WD2 = '') THEN
            ASKWHATTODO
          ELSE
            WRITELN('I see no ', WD1, WD1X, ' here.');
      SKIPDWARF := TRUE;
      SKIPDESCRIBE := TRUE;
      EXIT(DOWHATHESAYS)
    END;  { ANALANOBJ }


    PROCEDURE ANALAVERB;

    BEGIN
      VBL^.VERB := K;
      SPK := ARY^.ACTSPK[VBL^.VERB];
      IF (WD2 <> '') AND (VBL^.VERB <> SAY) THEN
        BEGIN
          RESTART := 1;
          EXIT(ANALAVERB)
        END;
      IF VBL^.VERB = SAY THEN
        IF WD2 = '' THEN
          ANALANITVERB
        ELSE
          ANALATVERB
      ELSE
        IF VBL^.OBJ = 0 THEN
          ANALANITVERB
        ELSE
          ANALATVERB
    END;  { ANALAVERB }


    PROCEDURE CLOSE1;

    BEGIN 
      VARY^.PROP[GRATE] := 0;
      VARY^.PROP[FISSURE] := 0;
      FOR I := 1 TO 6 DO VARY^.DSEEN[I] := FALSE;
      MOVE(TROLL,0);
      MOVE(TROLL + 100, 0);
      MOVE(TROLL2, ARY^.PLAC[TROLL]);
      MOVE(TROLL2 + 100, VARY^.FIXED[TROLL]);
      JUGGLE(CHASM);
      IF VARY^.PROP[BEAR] <> 3 THEN DESTROY(BEAR);
      VARY^.PROP[CHAIN] := 0;
      VARY^.FIXED[CHAIN] := 0;
      VARY^.PROP[AXE] := 0;
      VARY^.FIXED[AXE] := 0;
      SPEAK(ARY^.RTEXT[129]);
      VBL^.CLOCK1 := -1;
      VBL^.CLOSING := TRUE
    END;  { CLOSE1 }


    PROCEDURE CLOSE2;

    BEGIN
      VARY^.PROP[BOTTLE] := PUT(BOTTLE, 115, 1);
      VARY^.PROP[PLANT] := PUT(PLANT, 115, 0);
      VARY^.PROP[OYSTER] := PUT(OYSTER, 115, 0);
      VARY^.PROP[LAMP] := PUT(LAMP, 115, 0);
      VARY^.PROP[ROD] := PUT(ROD, 115, 0);
      VARY^.PROP[DWARF] := PUT(DWARF, 115, 0);
      VBL^.LOC := 115;
      VBL^.OLDLOC := 115;
      NEWLOC := 115;
      FOO := PUT(GRATE, 116, 0);
      VARY^.PROP[SNAKE] := PUT(SNAKE, 116, 1);
      VARY^.PROP[BIRD] := PUT(BIRD, 116, 1);
      VARY^.PROP[CAGE] := PUT(CAGE, 116, 0);
      VARY^.PROP[ROD2] := PUT(ROD2, 116, 0);
      VARY^.PROP[PILLOW] := PUT(PILLOW, 116, 0);
      VARY^.PROP[MIRROR] := PUT(MIRROR, 115, 0);
      VARY^.FIXED[MIRROR] := 116;
      FOR I := 1 TO 100 DO
        IF TOTING(I) THEN DESTROY(I);
      SPEAK(ARY^.RTEXT[132]);
      VBL^.CLOSED := TRUE;
      EXIT(DOWHATHESAYS)
    END;  { CLOSE2 }


  BEGIN { DOWHATHESAYS }
    IF VBL^.FOOBAR > 0 THEN
      VBL^.FOOBAR := -VBL^.FOOBAR
    ELSE
      VBL^.FOOBAR := 0;
    VBL^.TURNS := VBL^.TURNS + 1;
    if wd1 = 'DESCR' then
      begin
        speak(ary^.ltext[vbl^.loc]);
        restart := 1;
        exit(dowhathesays)
      end;
    K := SAY;
    IF (VBL^.VERB = SAY) AND (WD2 <> '') THEN VBL^.VERB := 0;
    IF VBL^.VERB <> SAY THEN
      BEGIN
        IF (VBL^.TALLY = 0) AND 
           (VBL^.LOC >= 15) AND 
           (VBL^.LOC <> 33) and
           (vbl^.loc <= 140 ) THEN
          VBL^.CLOCK1 := VBL^.CLOCK1 - 1;
        IF VBL^.CLOCK1 = 0 THEN
          CLOSE1
        ELSE
          IF VBL^.CLOCK1 < 0 THEN VBL^.CLOCK2 := VBL^.CLOCK2 - 1;
        IF VBL^.CLOCK2 = 0 THEN
          CLOSE2
        ELSE
          BEGIN
            IF VARY^.PROP[LAMP] = 1 THEN VBL^.LIMIT := VBL^.LIMIT - 1;
            IF (VBL^.LIMIT <= 30) AND HERE(BATTERY) AND
              (VARY^.PROP[BATTERY] = 0) AND HERE(LAMP) THEN
              BEGIN
                SPEAK(ARY^.RTEXT[188]);
                VARY^.PROP[BATTERY] := 1;
                IF TOTING(BATTERY) THEN DROP(BATTERY, VBL^.LOC);
                VBL^.LIMIT := VBL^.LIMIT + 2500;
                LMWARN := FALSE
              END
            ELSE
              IF VBL^.LIMIT = 0 THEN
                BEGIN
                  VBL^.LIMIT := -1;
                  VARY^.PROP[LAMP] := 0;
                  IF HERE(LAMP) THEN SPEAK(ARY^.RTEXT[184])
                END
              ELSE
                IF (VBL^.LIMIT < 0) AND (VBL^.LOC <= 8) THEN
                  BEGIN
                    SPEAK(ARY^.RTEXT[185]);
                    ALLDONE := TRUE;
                    GAVEUP := TRUE;
                    EXIT(DOWHATHESAYS)
                  END
                ELSE
                  IF VBL^.LIMIT <= 30 THEN
                    BEGIN
                      IF NOT LMWARN AND HERE(LAMP) THEN
                        BEGIN
                          LMWARN := TRUE;
                          SPK := 187;
                          IF VARY^.PLACE[BATTERY] = 0 THEN SPK := 183;
                          IF VARY^.PROP[BATTERY] = 1 THEN SPK := 189;
                          SPEAK(ARY^.RTEXT[SPK])
                        END
                    END;
            K := 43;  { WHERE? }
            IF LIQLOC(VBL^.LOC) = WATER THEN K := 70;
            IF (WD1 = 'ENTER') AND ((WD2 = 'STREA') OR (WD2 = 'WATER')) THEN
              BEGIN
                SPEAK(ARY^.RTEXT[K]);
                SKIPDWARF := TRUE;
                SKIPDESCRIBE := TRUE
              END
            ELSE
              REPEAT
                RESTART := 0;
                IF (WD1 = 'ENTER') AND (WD2 <> '') THEN
                  BEGIN
                    WD1 := WD2;
                    WD1X := WD2X;
                    if (wd1 = 'DOOR') and at(door2) then wd1 := 'DOOR2';
                    WD2 := ''
                  END
                ELSE
                  BEGIN
                    IF ((WD1 = 'WATER') OR (WD1 = 'OIL')) AND
                      ((WD2 = 'PLANT') OR (WD2 = 'DOOR')) THEN
                        IF AT(VOCAB(WD2,1)) THEN WD2 := 'POUR'
                  END;
                IF WD1 = 'WEST' THEN
                  BEGIN
                    VBL^.IWEST := VBL^.IWEST + 1;
                    IF VBL^.IWEST = 10 THEN SPEAK(ARY^.RTEXT[17])
                  END;
                I := VOCAB(WD1, -1);
                IF I = -1 THEN
                  BEGIN
                    SPK := 60;
                    IF PERCENT(20) THEN SPK := 61;
                    IF PERCENT(20) THEN SPK := 13;
                    SPEAK(ARY^.RTEXT[SPK]);
                    RESTART := 1;
                    EXIT(DOWHATHESAYS)
                  END
                ELSE
                  BEGIN
                    K := I MOD 1000;
                    CASE (I DIV 1000) OF
                      0 : SET_NEW_LOC;
                      1 : ANALANOBJ;
                      2 : ANALAVERB;
                      3 : BEGIN
                            SKIPDWARF := TRUE;
                            SKIPDESCRIBE := TRUE;
                            IF K <> 0 THEN SPEAK(ARY^.RTEXT[K])
                          END
                    END;
                    IF RESTART <> 0 THEN
                      BEGIN
                        WD1 := WD2;
                        WD1X := WD2X;
                        WD2 := ''
                      END
                  END
              UNTIL RESTART = 0  { SHORT RESTART }
          END
      END
  END;  { DOWHATHESAYS }

 (*$I ADVXSUBS.TEXT *)

  PROCEDURE REINCARNATION;

  BEGIN
    IF HE_DIED THEN
      BEGIN
        IF PIT THEN
          BEGIN
            SPEAK(ARY^.RTEXT[23]);
            VBL^.OLDLC2 := VBL^.LOC
          END;
        IF VBL^.CLOSING THEN
          BEGIN
            SPEAK(ARY^.RTEXT[131]);
            VBL^.NUMDIE := VBL^.NUMDIE + 1
          END
        ELSE
          BEGIN
            YEA := YES(81 + (VBL^.NUMDIE * 2), 82 + (VBL^.NUMDIE * 2), 54);
            VBL^.NUMDIE := VBL^.NUMDIE + 1;
            IF (VBL^.NUMDIE <> MAXDIE) AND YEA THEN
              BEGIN
                HE_DIED := FALSE;  { SAVED! }
                SKIPDWARF := TRUE;
                VARY^.PLACE[WATER] := 0;
                VARY^.PLACE[OIL] := 0;
                IF TOTING(LAMP) THEN VARY^.PROP[LAMP] := 0;
                FOR J := 100 DOWNTO 1 DO
                  IF TOTING(J) THEN
                    BEGIN
                      K := VBL^.OLDLC2;
                      IF J = LAMP THEN K := 1;
                      DROP(J, K)
                    END;
                VBL^.LOC := 3;
                VBL^.OLDLOC := VBL^.LOC
              END
          END
      END
  END;  { REINCARNATION }


  PROCEDURE ENDGAME;

  BEGIN
    SCORE := GETSCORE(FALSE);
    WRITELN;
    WRITE('You scored ', SCORE, ' out of a possible ', MAXSCORE);
    IF TERMWIDTH < 64 THEN WRITELN;
    IF VBL^.TURNS = 1 THEN
      KKWORD := '.'
    ELSE
      KKWORD := 's.';
    WRITELN(' using ', VBL^.TURNS, ' turn', KKWORD);
    FOR I := 1 TO CLSSES DO
      IF ARY^.CVAL[I] >= SCORE THEN
        BEGIN
          SPEAK(ARY^.CTEXT[I]);
          IF I = CLSSES THEN
            BEGIN
              WRITE('To achieve the next higher rating would ');
              IF TERMWIDTH < 64 THEN WRITELN;
              WRITELN('be a neat trick!');
              WRITELN;
              WRITELN('Congratulations.')
            END
          ELSE
            BEGIN
              K := ARY^.CVAL[I] + 1 - SCORE;
              KKWORD := 's.';
              IF K = 1 THEN KKWORD := '.';
              WRITE('To achieve the next higher rating, you need ');
              IF TERMWIDTH < 64 THEN WRITELN;
              WRITELN(K, ' more point', KKWORD)
            END;
          I := CLSSES  { EXIT THIS MESS }
      END
  END;  { ENDGAME }

  PROCEDURE READINIT{VAR BFR : CH512; NUM : INTEGER};

  BEGIN
    NUM := (NUM + 511) DIV 512;
    IF NUM <> BLOCKREAD(INFILE, BFR, NUM) THEN
      BEGIN
        WRITE('Error reading array file.');
        EXIT(ADVENTURE)
      END
  END;  { READINIT }

  PROCEDURE GETNEWCOMMAND;  

  VAR
    W1FLAG, DONE : BOOLEAN;
    INLINE : STRING;

  BEGIN { GETNEWCOMMAND }
    IF VBL^.CLOSED THEN
      BEGIN
        IF (VARY^.PROP[OYSTER] < 0) AND TOTING(OYSTER) THEN PSPEAK(OYSTER, 1);
        FOR I := 1 TO 100 DO
          IF TOTING(I) AND (VARY^.PROP[I] < 0) THEN
            VARY^.PROP[I] := -1 - VARY^.PROP[I]
      END;
    LINE := 1;
    WD1 := '';
    WD2 := '';
    WD1X := '';
    WD2X := '';
    VBL^.WZDARK := DARK;
    IF (VBL^.KNFLOC > 0) AND (VBL^.KNFLOC <> VBL^.LOC) THEN VBL^.KNFLOC := 0;
    I := RAN(1);
    REPEAT
      repeat
        READLN(INLINE);
      until length ( inline ) > 0;  {no null strings - gws}
      INLINE := CONCAT(INLINE, '  : ');
      WHILE INLINE[1] = ' ' DO DELETE(INLINE, 1, 1)
    UNTIL INLINE <> ' : ';
    W1FLAG := FALSE;
    DONE := FALSE;
    REPEAT
      ACHAR := COPY(INLINE, 1, 1);
      if achar[1] in ['a'..'z'] then achar[1] := chr(ord(achar[1]) - 32);
      DELETE(INLINE, 1, 1);
      IF ACHAR = ' ' THEN
        BEGIN
          DONE := W1FLAG;
          W1FLAG := TRUE
        END
      ELSE
        IF W1FLAG THEN
          IF LENGTH(WD2) = 5 THEN
            WD2X := CONCAT(WD2X, ACHAR)
          ELSE
            WD2 := CONCAT(WD2, ACHAR)
        ELSE
          IF LENGTH(WD1) = 5 THEN
            WD1X := CONCAT(WD1X, ACHAR)
          ELSE
            WD1 := CONCAT(WD1, ACHAR)
    UNTIL DONE
  END;  { GETNEWCOMMAND }



BEGIN { ADVENTURE }
  INITIALIZE;
  VARY^.HINTED[3] := YES(65, 1, 0);
  IF VARY^.HINTED[3] THEN
    RESUME := FALSE
  ELSE
    RESUME := YES(201, 0, 0);
  IF RESUME THEN
    BEGIN
      NAMEANDPW;
      {$I-}
      RESET(INFILE, NAMEOFUSER);
      {$I+}
      IF IORESULT <> 0 THEN
        BEGIN
          WRITELN('Sorry, you do not have a saved game.');
          RESUME := FALSE
        END
      ELSE
        BEGIN
          READINIT(VARY^.DBLK, SIZEOF(VARYS));
          READINIT(VBL^.DBLK, SIZEOF(VBLS)); 
          CLOSE(INFILE);
          IF TESTPW <> VBL^.PASSWORD THEN
            BEGIN
              WRITE('Incorrect password.');
              EXIT(ADVENTURE)
            END;
          IF VERSION <> VBL^.VERSION THEN
            BEGIN
              IF VERSION > VBL^.VERSION THEN
                WRITE('Old save file - new')
              ELSE
                WRITE('New save file - old');
              WRITE(' Adventure.  Sorry.');
              EXIT(ADVENTURE)
            END
        END;
      VBL^.LIMIT := MAX(VBL^.LIMIT, 150);  { GIVE HIM SOME TIME }
    END;
  IF NOT RESUME THEN
    BEGIN
      VBL^.LOC := 1;
      VBL^.CLOCK1 := 30;
      VBL^.CLOCK2 := 25;
      IF VARY^.HINTED[3] THEN
        VBL^.LIMIT := 1000
      ELSE
        VBL^.LIMIT := 330
    END;
  NEWLOC := VBL^.LOC;
  REPEAT
    REPEAT
      IF SKIPDWARF THEN
        SKIPDWARF := FALSE
      ELSE
        BEGIN
          TESTCLOSE;
          VBL^.LOC := NEWLOC;
          if (vbl^.loc = 149) and (vary^.prop[wizard] <> 1) then
            begin
              wizbo := ran(100);
              if wizbo <= 76 then
                begin
                  speak(ary^.rtext[211]);
                  if (wizbo >= 50) and (vbl^.wizflg <> 0) then
                    begin
                      speak(ary^.rtext[53]);
                      vbl^.oldlc2 := vbl^.loc;
                      he_died := true
                    end
                  else
                    begin
                      speak(ary^.rtext[52]); 
                      vbl^.wizflg := 1
                    end
                end
            end;
          IF not he_died and (VBL^.LOC <> 0) THEN
            IF NOT FORCED(VBL^.LOC) AND NOT BITSET(NEWLOC, 3) THEN
              IF VBL^.DFLAG = 0 THEN
                IF VBL^.LOC >= 15 THEN
                  VBL^.DFLAG := 1
                ELSE
              ELSE
                DWARFSTUFF
        END;
      NEWLOCSET := FALSE;
      IF NOT HE_DIED THEN
        BEGIN
          IF SKIPDESCRIBE THEN
            SKIPDESCRIBE := FALSE
          ELSE
            BEGIN
              WRITELN;
              DESCRIBE_CURRENT_LOCATION
            END;
          IF NOT HE_DIED AND NOT NEWLOCSET THEN
            BEGIN
              VBL^.VERB := 0;
              VBL^.OBJ := 0;
              RESTART := 0;
              REPEAT
                IF RESTART <> 2 THEN
                  BEGIN
                    CHECKHINTS;
                    GETNEWCOMMAND
                  END;
                RESTART := 0;
                DOWHATHESAYS
              UNTIL RESTART = 0;  { LONG RESTART }
            END
        END
    UNTIL HE_DIED OR ALLDONE;  { MAIN LOOP }
    REINCARNATION
  UNTIL HE_DIED OR ALLDONE;  { NO MORE RE-INCARNATIONS }
  ENDGAME
END.


========================================================================================
DOCUMENT :usus Folder:VOL24:advx1.text
========================================================================================

  1 You are standing at the end of a road before a small brick building.
  1   Around you is a forest.  A small stream flows out of the building and
  1  down a gully.
  2 You have walked up a hill, still in the forest.  The road slopes back down
  2  the other side of the hill.  There is a building in the distance.
  3 You are inside a building, a well house for a large spring.
  4 You are in a valley in the forest beside a stream tumbling along a rocky
  4  bed.
  5 You are in open forest, with a deep valley to one side.
  6 You are in open forest near both a valley and a road.
  7 At your feet all the water of the stream splashes into a 2-inch slit in the
  7  rock.  Downstream the streambed is bare rock.
  8 You are in a 20-foot depression floored with bare dirt.  Set into the dirt
  8  is a strong steel grate mounted in concrete.  A dry streambed leads into
  8  the depression.
  9 You are in a small chamber beneath a 3x3 steel grate leading to the
  9  surface.  A low crawl over cobbles leads inward to the west.
 10 You are crawling over cobbles in a low passage.  There is a dim light at
 10  the east end of the passage.
 11 You are in a debris room filled with stuff washed in from the surface.  A
 11  low wide passage with cobbles becomes plugged with mud and debris here,
 11  but an awkward canyon leads upward and to the west.  A note on the wall
 11  says: 'Magic word XYZZY'.
 12 You are in an awkward sloping east/west canyon.
 13 You are in a splendid chamber thirty feet high.  The walls are frozen
 13  rivers of orange stone.  An awkward canyon and a good passage exit from
 13  the east and west sides of the chamber.
 14 At your feet is a small pit breathing traces of white mist.  An east
 14  passage ends here except for a small crack leading on.
 15 You are at one end of a vast hall stretching forward out of sight to the
 15  west.  There are openings to either side.  Nearby, a wide stone staircase
 15  leads downward.  The hall is filled with wisps of white mist swaying to
 15  and fro almost as if alive.  A cold wind blows up the staircase.  There is
 15  a passage at the top of a dome behind you.
 16 The crack is far too small for you to follow.
 17 You are on the east bank of a fissure slicing clear across the hall.  The
 17  mist is quite thick here, and the fissure is too wide to jump.
 18 This is a low room with a crude note on the wall.  The note says: 'You
 18  won't get it up the steps'.
 19 You are in the hall of the mountain king, with passages off in all
 19  directions.
 20 You are at the bottom of the pit with a broken neck.
 21 You didn't make it.
 22 The dome is unclimbable.
 23 You are at the west end of the twopit room.  There is a large hole in the
 23  wall above the pit at this end of the room.
 24 You are at the bottom of the eastern pit in the twopit room.  There is a
 24  small pool of oil in one corner of the pit.
 25 You are at the bottom of the western pit in the twopit room.  There is a
 25  large hole in the wall about 25 feet above you.
 26 You clamber up the plant and scurry through the hole at the top.
 27 You are on the west side of the fissure in the hall of mists.
 28 You are in a low north/south passage at a hole in the floor.  The hole goes
 28  down to an east/west passage.
 29 You are in the south side chamber.
 30 You are in the west side chamber of the hall of the mountain king.  A
 30  passage continues west and up here.
 31
 32 You can't get by the snake.
 33 You are in a large room, with a passage to the south, a passage to the
 33  west, and a wall of broken rock to the east.  There is a large 'Y2' on a
 33  rock in the room's center.
 34 You are in a jumble of rock, with cracks everywhere.
 35 You're at a low window overlooking a huge pit, which extends up out of
 35  sight.  A floor is indistinctly visible over 50 feet below.  Traces of
 35  white mist cover the floor of the pit, becoming thicker to the right.
 35   Marks in the dust around the window would seem to indicate that someone
 35  has been here recently.  Directly across the pit from you and 25 feet away
 35  there is a similar window looking into a lighted room.  A shadowy figure
 35  can be seen there peering back at you.
 36 You are in a dirty broken passage.  To the east is a crawl.  To the west is
 36  a large passage.  Above you is a hole to another passage.
 37 You are on the brink of a small clean climbable pit.  A crawl leads west.
 38 You are in the bottom of a small pit with a little stream, which enters and
 38  exits through tiny slits.
 39 You are in a large room full of dusty rocks.  There is a big hole in the
 39  floor.  There are cracks everywhere, and a passage leading east.
 40 You have crawled through a very low wide passage parallel to and north of
 40  the hall of mists.
 41 You are at the west end of hall of mists.  A low wide crawl continues west
 41  and another goes north.  To the south is a little passage 6 feet off the
 41  floor.
 42 You are in a maze of twisty little passages, all alike.
 43 You are in a maze of twisty little passages, all alike.
 44 You are in a maze of twisty little passages, all alike.
 45 You are in a maze of twisty little passages, all alike.
 46 Dead end.
 47 Dead end.
 48 Dead end.
 49 You are in a maze of twisty little passages, all alike.
 50 You are in a maze of twisty little passages, all alike.
 51 You are in a maze of twisty little passages, all alike.
 52 You are in a maze of twisty little passages, all alike.
 53 You are in a maze of twisty little passages, all alike.
 54 Dead end.
 55 You are in a maze of twisty little passages, all alike.
 56 Dead end.
 57 You are on the brink of a thirty foot pit with a massive orange column down
 57  one wall.  You could climb down here but you could not get back up.  The
 57  maze continues at this level.
 58 Dead end.
 59 You have crawled through a very low wide passage parallel to and north of
 59  the hall of mists.
 60 You are at the east end of a very long hall apparently without side
 60  chambers.  To the east a low wide crawl slants up.  To the north a round
 60  two foot hole slants down.
 61 You are at the west end of a very long featureless hall.  The hall joins up
 61  with a narrow north/south passage.
 62 You are at a crossover of a high north/south passage and a low east/west
 62  one.
 63 Dead end.
 64 You are at a complex junction.  A low hands and knees passage from the
 64  north joins a higher crawl from the east to make a walking passage going
 64  west.  There is also a large room above.  The air is damp here.
 65 You are in bedquilt, a long east/west passage with holes everywhere.  To
 65  explore at random select NORTH, SOUTH, UP, or DOWN.
 66 You are in a room whose walls resemble swiss cheese.  Obvious passages go
 66  west, east, northeast, and northwest.  Part of the room is occupied by a
 66  large bedrock block.
 67 You are at the east end of the twopit room.  The floor here is littered
 67  with thin rock slabs, which make it easy to descend the pits.  There is a
 67  path here bypassing the pits to connect passages from east and west.
 67   There are holes all over, but the only big one is on the wall directly
 67  over the west pit where you can't get to it.
 68 You are in a large low circular chamber whose floor is an immense slab
 68  fallen from the ceiling (slab room).  East and west there once were large
 68  passages, but they are now filled with boulders.  Low small passages go
 68  north and south, and the south one quickly bends west around the boulders.
 69 You are in a secret north/south canyon above a large room.
 70 You are in a secret north/south canyon above a sizable passage.
 71 You are in a secret canyon at a junction of three canyons, bearing north,
 71  south, and southeast.  The north one is as tall as the other two combined.
 72 You are in a large low room.  Crawls lead north, southeast, and southwest.
 73 You are in the Egyptian room.  Your lamp reveals ancient hieroglyphics
 73  carved into the stone walls.  A passage once went east but is now filled
 73  with massive marble blocks.  There is a crawl to the south and a larger
 73  passage to the west.
 74 You are in a secret canyon which here runs east/west.  It crosses over a
 74  very tight canyon 15 feet below.  If you go down you may not be able to
 74  get back up.
 75 You are at a wide place in a very tight north/south canyon.
 76 The canyon here becomes too tight to go further south.
 77 You are in a tall east/west canyon.  A low tight crawl goes three feet
 77  north and seems to open up.
 78 The canyon runs west into a massive iron door set in granite.  A path
 78  continues to the south.
 79 The stream flows out through a pair of 1 foot diameter sewer pipes.  It
 79  would be advisable to use the exit.
 80 You are in a maze of twisty little passages, all alike.
 81 Dead end.
 82 Dead end.
 83 You are in a maze of twisty little passages, all alike.
 84 You are in a maze of twisty little passages, all alike.
 85 Dead end.
 86 Dead end.
 87 You are in a maze of twisty little passages, all alike.
 88 You are in a long, narrow corridor stretching out of sight to the west.  At
 88  the eastern end is a hole through which you can see a profusion of leaves.
 89 There is nothing here to climb.  Use 'UP' or 'OUT' to leave the pit.
 90 You have climbed up the plant and out of the pit.
 91 You are at the top of a steep incline above a large room.  You could climb
 91  down here, but you would not be able to climb back up.  There is a passage
 91  leading back to the north.
 92 You are in the giant room.  The ceiling here is too high up for your lamp
 92  to show it.  Cavernous passages lead east, north, and south.  On the west
 92  wall is scrawled the inscription: 'FEE FIE FOE FOO' [sic].
 93 The passage here is blocked by a recent cave-in.
 94 You are at one end of an immense north/south passage.
 95 You are in a magnificent cavern with a rushing stream, which cascades over
 95  a sparkling waterfall into a roaring whirlpool which disappears through
 95  some stairs in the floor.  Passages exit to the south and west.
 96 You are in the soft room.  The walls are covered with heavy curtains, the
 96  floor with a thick pile carpet.  Moss covers the ceiling.
 97 This is the oriental room.  Ancient oriental cave drawings cover the walls.
 97   A gently sloping passage leads upward to the north, another passage leads
 97  southeast, and a hands and knees crawl leads west.
 98 You are following a wide path around the outer edge of a large cavern.  Far
 98  below, through a heavy white mist, strange splashing noises can be heard.
 98   The mist rises up through a fissure in the ceiling.  The path exits to
 98  the south and west.
 99 You are in an alcove.  A small northwest path seems to widen after a short
 99  distance.  An extremely tight tunnel leads east.  It looks like a very
 99  tight squeeze.  An eerie light can be seen at the other end.
100 You're in a small chamber lit by an eerie green light.  An extremely narrow
100  tunnel exits to the west.  A dark corridor leads northeast.
101 You're in the dark-room.  There is a corridor exiting to the south and a
101  similar one leading east.
102 You are in an arched hall.  A coral passage once continued up and east from
102  here, but is now blocked by debris.  The air smells of sea water.
103 You're in a large room carved out of sedimentary rock.  The floor and walls
103  are littered with bits of shells imbedded in the stone.  A shallow passage
103  proceeds downward, and a somewhat steeper one leads up.  A low hands and
103  knees passage enters from the south.
104 You are in a long sloping corridor with ragged sharp walls.
105 You are in a cul-de-sac about eight feet across.
106 You are in an anteroom leading to a large passage to the east.  Small
106  passages go west and up.  The remnants of recent digging are evident.  A
106  sign in midair here says: 'Cave under construction beyond this point.
106   Proceed at your own risk.  [Witt Construction Company]'.
107 You are in a maze of twisty little passages, all different.
108 You are at Witt's end.  Passages lead off in *all* directions.
109 You are in a north/south canyon about 25 feet across.  The floor is covered
109  by white mist seeping in from the north.  The walls extend upward for well
109  over 100 feet.  Suspended from some unseen point far above you, an
109  enormous two-sided mirror is hanging parallel to and midway between the
109  canyon walls.  (The mirror is obviously provided for the use of the
109  dwarves, who as you know, are extremely vain.)  A small window can be seen
109  in either wall, some fifty feet up.
110 You're at a low window overlooking a huge pit, which extends up out of
110  sight.  A floor is indistinctly visible over 50 feet below.  Traces of
110  white mist cover the floor of the pit, becoming thicker to the left.
110   Marks in the dust around the window would seem to indicate that someone
110  has been here recently.  Directly across the pit from you and 25 feet away
110  there is a similar window looking into a lighted room.  A shadowy figure
110  can be seen there peering back at you.
111 A large stalactite extends from the roof and almost reaches the floor
111  below.  You could climb down it, and jump from it to the floor, but having
111  done so you would be unable to reach it to climb back up.
112 You are in a little maze of twisting passages, all different.
113 You are at the edge of a large underground reservoir.  An opaque cloud of
113  white mist fills the room and rises rapidly upward.  The lake is fed by a
113  stream, which tumbles out of a hole in the wall about 10 feet overhead and
113  splashes noisily into the water somewhere within the mist.  The only
113  passage goes back toward the south.
114 Dead end.
115 You are at the northeast end of an immense room, even larger than the giant
115  room.  It appears to be a repository for the 'Adventure' program.  Massive
115  torches far overhead bathe the room with smoky yellow light.  Scattered
115  about you can be seen a pile of bottles (all of them empty), a nursery of
115  young beanstalks murmuring quietly, a bed of oysters, a bundle of black
115  rods with rusty stars on their ends, and a collection of brass lanterns.
115   Off to one side a great many dwarves are sleeping on the floor, snoring
115  loudly.  A sign nearby reads: 'Do not disturb the dwarves!'  An immense
115  mirror is hanging against one wall, and stretches to the other end of the
115  room, where various other sundry objects can be glimpsed dimly in the
115  distance.
116 You are at the southwest end of the repository.  To one side is a pit full
116  of fierce green snakes.  On the other side is a row of small wicker cages,
116  each of which contains a little sulking bird.  In one corner is a bundle
116  of black rods with rusty marks on their ends.  A large number of velvet
116  pillows are scattered about on the floor.  A vast mirror stretches off to
116  the northeast.  At your feet is a large steel grate, next to which is a
116  sign which reads: 'Treasure vault.  Keys in main office.'
117 You are on one side of a large, deep chasm.  A heavy white mist rising up
117  from below obscures all view of the far side.  A southwest path leads away
117  from the chasm into a winding corridor.
118 You are in a long winding corridor sloping out of sight in both directions.
119 You are in a secret canyon which exits to the north and east.
120 You are in a secret canyon which exits to the north and east.
121 You are in a secret canyon which exits to the north and east.
122 You are on the far side of the chasm.  A northeast path leads away from the
122  chasm on this side.
123 You're in a long east/west corridor.  A faint rumbling noise can be heard
123  in the distance.
124 The path forks here.  The left fork leads northeast.  A dull rumbling seems
124  to get louder in that direction.  The right fork leads southeast down a
124  gentle slope.  The main corridor enters from the west.
125 The walls are quite warm here.  From the north can be heard a steady roar,
125  so loud that the entire cave seems to be trembling.  Another passage leads
125  south, and a low crawl goes east.
126 You are on the edge of a breath-taking view.  Far below you is an active
126  volcano, from which great gouts of molten lava come surging out, cascading
126  back down into the depths.  The glowing rock fills the farthest reaches of
126  the cavern with a blood-red glare, giving everything an eerie, macabre
126  appearance.  The air is filled with flickering sparks of ash and a heavy
126  smell of brimstone.  The walls are hot to the touch, and the thundering of
126  the volcano drowns out all other sounds.  Embedded in the jagged roof far
126  overhead are myriad twisted formations composed of pure white alabaster,
126  which scatter the murky light into sinister apparitions upon the walls.
126   To one side is a deep gorge, filled with a bizarre chaos of tortured rock
126  which seems to have been crafted by the devil himself.  An immense river
126  of fire crashes out from the depths of the volcano, burns its way through
126  the gorge, and plummets into a bottomless pit far off to your left.  To
126  the right, an immense geyser of blistering steam erupts continuously from
126  a barren island in the center of a sulfurous lake, which bubbles
126  ominously.  The far right wall is aflame with an incandescence of its own,
126  which lends an additional infernal splendor to the already hellish scene.
126   A dark, foreboding passage exits to the south.
127 You are in a small chamber filled with large boulders.  The walls are very
127  warm, causing the air in the room to be almost stifling from the heat.
127   The only exit is a crawl heading west, through which is coming a low
127  rumbling.
128 You are walking along a gently sloping north/south passage lined with oddly
128  shaped limestone formations.
129 You are standing at the entrance to a large, barren room.  A sign posted
129  above the entrance reads:  'Caution!  Bear in room!'
130 You are inside a barren room.  The center of the room is completely empty
130  except for some dust.  Marks in the dust lead away toward the far end of
130  the room.  The only exit is the way you came in.
131 You are in a maze of twisting little passages, all different.
132 You are in a little maze of twisty passages, all different.
133 You are in a twisting maze of little passages, all different.
134 You are in a twisting little maze of passages, all different.
135 You are in a twisty little maze of passages, all different.
136 You are in a twisty maze of little passages, all different.
137 You are in a little twisty maze of passages, all different.
138 You are in a maze of little twisting passages, all different.
139 You are in a maze of little twisty passages, all different.
140 Dead end.
141 You are in a deep rocky depression.  To the north are the remains of a once
141  magnificent castle.  A path leads north and there is a retreat to the
141  southwest.
142 You are standing at the edge of a moat.  The water is deep and stagnant,
142  but a tree has fallen across which you could cross.
143 You are standing in the rubble strewn courtyard of the castle.  Corridors
143  lead east, west, north, and south.
144 You are in the waiting room of the east spire.  Some very dangerous looking
144  stairs lead up.  There is an exit to the west.
145 You are at the base of the west spire.  A headsmans block, notched and
145  stained, stands in the center.  Stairs lead up and down.  There is an exit
145  to the east.
146 You have entered into the banquet room.  Old bones and broken glass litter
146  the floor.  An immense granite table fills most of the room.  Passages
146  lead north, south, east, and west.
147 You are at the top of the east spire.  It is a clear day and you can see
147  for miles with blinding clarity.  Far below you and to the south, a vast
147  forest of trees blankets the ground.  A small brook is also visible,
147  wandering aimlessly throughout the forest.  In all other directions stark,
147  grey, innaccesable mountains arise.  Heavy snow caps most of these peaks,
147  and winds can be seen whipping loose snow particles throughout the crags.
148 The stairs ahead have collapsed.  The only way out is back down the stairs.
148   A sign hanging here says: 'Too bad...there used to be a nice view here.
148   Try the east spire.'.
149 You are in the dungeon.  Smokey torches are set into the walls.  Old prison
149  cells, many containing distorted skeletons line the south side.  Stairs
149  lead up and a tunnel leads east.
150 You are standing before a heavy iron door in a muddy little room.
150   Instruments of torture clutter the floor.  A passage leads west.
151 You appear to be in the barracks.  A thick layer of dust covers the floor.
151   A passage leads east.
152 You are in the servants quarters.  Cobwebs hang eerily from the ceiling.
152   An exit leads west.
153 You are at the south end of the throne room.  A beautifully mosaiced
153  floor is littered with leaves and debris.  A doorway leads south.
154 You are at the north end of the throne room.  Cockroaches run for cover on
154  a massive marble throne.  Passages lead east and west.
155 You have entered the royal suite but much has been destroyed by a cave in.
155   The sky can be seen from a hole in the roof.  There are some stairs close
155  by leading down.
156 You are in the knights quarters.  Some broken weapons are scattered on the
156  floor along with some empty wine kegs.  Stairs lead down and there is a
156  passage to the south.
157 You are in a secret passage behind the throne.  The only way out is down.
158 You are in a large chamber with a marble floor.  A window once covered the
158  east wall but was broken long ago.  A cold wind blows in.  There is a hall
158  leading north.
159 It is freezing cold here.  Ice has formed on the walls from the spray of
159  water rushing into a hole in the floor.  Awkward looking stairs lead up.
160 You are in a high bastillion overlooking the courtyard.  Snow and ice has
160  gathered here and been packed by the wind.  A hole in the floor leads
160  down.

========================================================================================
DOCUMENT :usus Folder:VOL24:advx10.text
========================================================================================

 35 You are obviously a rank amateur.  Better luck next time.
100 Your score qualifies you as a Novice Class Adventurer.
130 You have achieved the rating: 'Experienced Adventurer'.
200 You may now consider yourself a 'Seasoned Adventurer'.
250 You have reached 'Junior Master' status.
300 Your score puts you in Master Adventurer class C.
330 Your score puts you in Master Adventurer class B.
350 Your score puts you in Master Adventurer class A.
400 Your score puts you in the Apprentice Wizard class.
450 Your score puts you in the Sub-Wizard class.
499 You may now consider yourself a Wizard!!
500 All of Adventuredom gives tribute to you, Adventurer Grandwizard!

========================================================================================
DOCUMENT :usus Folder:VOL24:advx11.text
========================================================================================

 4   4   2  62  63
 5   5   2  18  19
 6   8   2  20  21
 7  75   4 176 177
 8  25   5 178 179
 9  20   3 180 181

========================================================================================
DOCUMENT :usus Folder:VOL24:advx2.code
========================================================================================

< binary file -- not listed >

========================================================================================
DOCUMENT :usus Folder:VOL24:advx2.text
========================================================================================

  1 You're at end of road again.
  2 You're at hill in road.
  3 You're inside building.
  4 You're in valley.
  5 You're in forest.
  6 You're in forest.
  7 You're at slit in streambed.
  8 You're outside grate.
  9 You're below the grate.
 10 You're in cobble crawl.
 11 You're in debris room.
 13 You're in bird chamber.
 14 You're at top of small pit.
 15 You're in hall of mists.
 17 You're on east bank of fissure.
 18 You're in nugget of gold room.
 19 You're in hall of mountain king.
 23 You're at west end of twopit room.
 24 You're in east pit.
 25 You're in west pit.
 33 You're at 'Y2'.
 35 You're at window on pit.
 36 You're in dirty passage.
 39 You're in dusty rock room.
 41 You're at west end of hall of mists.
 57 You're at brink of pit.
 60 You're at east end of long hall.
 61 You're at west end of long hall.
 64 You're at complex junction.
 66 You're in swiss cheese room.
 67 You're at east end of twopit room.
 68 You're in slab room.
 71 You're at junction of three secret canyons.
 73 You're in Egyptian room.
 74 You're in secret east/west canyon above tight canyon.
 88 You're in narrow corridor.
 91 You're at steep incline above large room.
 92 You're in giant room.
 95 You're in cavern with waterfall.
 96 You're in soft room.
 97 You're in oriental room.
 98 You're in misty cavern.
 99 You're in alcove.
100 You're in plover room.
101 You're in dark-room.
102 You're in arched hall.
103 You're in shell room.
106 You're in anteroom.
108 You're at Witt's end.
109 You're in mirror canyon.
110 You're at window on pit.
111 You're at top of stalactite.
113 You're at reservoir.
115 You're at NE end.
116 You're at SW end.
117 You're on SW side of chasm.
118 You're in sloping corridor.
122 You're on NE side of chasm.
123 You're in corridor.
124 You're at fork in path.
125 You're at junction with warm walls.
126 You're at breath-taking view.
127 You're in chamber of boulders.
128 You're in limestone passage.
129 You're in front of barren room.
130 You're in barren room.
141 You're at view of castle.
142 You're at moat.
143 You're in castle courtyard.
144 You're in east waiting room.
145 You're in execution room.
146 You're in banquet room.
147 You're at top of east spire.
148 Dead end.
149 You're in the dungeon.
150 You're in muddy little chamber.
151 You're in barracks.
152 You're in servants quarters.
153 You're at south end of throne room.
154 You're at north end of throne room.
155 You're in royal suite.
156 You're in knights quarters.
157 You're in secret passage.
158 You're in large marble chamber.
159 You're in polar room.
160 You're in high bastillion.

========================================================================================
DOCUMENT :usus Folder:VOL24:advx3.text
========================================================================================

  1   0   2   2  44  29
  1   0   3   3  12  19  43
  1   0   4   5  13  14  46  30
  1   0   5   6  45
  1   0   8  63
  2   0   1   2  12   7  43  45  30
  2   0   5   6  45  46
  3   0   1   3  11  32  44
  3   0  11  62
  3   0  33  65
  3   0  79   5  14
  4   0   1   4  12  45
  4   0   5   6  43  44  29
  4   0   7   5  46  30
  4   0   8  63
  5   0   4   9  43  30
  5   0 141  47
  5  50   5   6   7  45
  5   0   6   6
  5   0   5  44  46
  6   0   1   2  45
  6   0   4   9  43  44  30
  6   0   5   6  46
  7   0   1  12
  7   0   4   4  45
  7   0   5   6  43  44
  7   0   8   5  15  16  46  63
  7   0 595  60  14  30
  8   0   5   6  43  44  46
  8   0   1  12
  8   0   7   4  13  45
  8 303   9   3  19  30
  8   0 593   3
  9 303   8  11  29
  9   0 593  11
  9   0  10  17  18  19  44
  9   0  14  31
  9   0  11  51
 10   0   9  11  20  21  43  64
 10   0  11  19  22  44  51
 10   0  14  31
 11 303   8  63
 11   0   9  64
 11   0  10  17  18  23  24  43
 11   0  12  25  19  29  44
 11   0   3  62
 11   0  14  31
 12 303   8  63
 12   0   9  64
 12   0  11  30  43  51
 12   0  13  19  29  44
 12   0  14  31
 13 303   8  63
 13   0   9  64
 13   0  11  51
 13   0  12  25  43
 13   0  14  23  31  44
 14 303   8  63
 14   0   9  64
 14   0  11  51
 14   0  13  23  43
 14 150  20  30  31  34
 14   0  15  30
 14   0  16  33  44
 15   0  18  36  46
 15   0  17   7  38  44
 15   0  19  10  30  45
 15 150  22  29  31  34  35  23  43
 15   0  14  29
 15   0  34  55
 16   0  14   1
 17   0  15  38  43
 17 312 596  39
 17 412  21   7
 17 412 597  41  42  44  69
 17   0  27  41
 18   0  15  38  11  45
 19   0  15  10  29  43
 19 311  28  45  36
 19 311  29  46  37
 19 311  30  44   7
 19   0  32  45
 19  35  74  49
 19 211  32  49
 19   0  74  66
 20   0   0   1
 21   0   0   1
 22   0  15   1
 23   0  67  43  42
 23   0  68  44  61
 23   0  25  30  31
 23   0 648  52
 24   0  67  29  11
 25   0  23  29  11
 25 724  31  56
 25   0  26  56
 26   0  88   1
 27 312 596  39
 27 412  21   7
 27 412 597  41  42  43  69
 27   0  17  41
 27   0  40  45
 27   0  41  44
 28   0  19  38  11  46
 28   0  33  45  55
 28   0  36  30  52
 29   0  19  38  11  45
 30   0  19  38  11  43
 30   0  62  44  29
 31 524  89   1
 31   0  90   1
 32   0  19   1
 33   0   3  65
 33   0  28  46
 33   0  34  43  53  54
 33   0  35  44
 33 159 302  71
 33   0 100  71
 34   0  33  30  55
 34   0  15  29
 35   0  33  43  55
 35   0  20  39
 36   0  37  43  17
 36   0  28  29  52
 36   0  39  44
 36   0  65  70
 37   0  36  44  17
 37   0  38  30  31  56
 38   0  37  56  29  11
 38   0 595  60  14  30   4   5
 39   0  36  43  23
 39   0  64  30  52  58
 39   0  65  70
 40   0  41   1
 41   0  42  46  29  23  56
 41   0  27  43
 41   0  59  45
 41   0  60  44  17
 42   0  41  29
 42   0  42  45
 42   0  43  43
 42   0  45  46
 42   0  80  44
 43   0  42  44
 43   0  44  46
 43   0  45  43
 44   0  43  43
 44   0  48  30
 44   0  50  46
 44   0  82  45
 45   0  42  44
 45   0  43  45
 45   0  46  43
 45   0  47  46
 45   0  87  29  30
 46   0  45  44  11
 47   0  45  43  11
 48   0  44  29  11
 49   0  50  43
 49   0  51  44
 50   0  44  43
 50   0  49  44
 50   0  51  30
 50   0  52  46
 51   0  49  44
 51   0  50  29
 51   0  52  43
 51   0  53  46
 52   0  50  44
 52   0  51  43
 52   0  52  46
 52   0  53  29
 52   0  55  45
 52   0  86  30
 53   0  51  44
 53   0  52  45
 53   0  54  46
 54   0  53  44  11
 55   0  52  44
 55   0  55  45
 55   0  56  30
 55   0  57  43
 56   0  55  29  11
 57   0  13  30  56
 57   0  55  44
 57   0  58  46
 57   0  83  45
 57   0  84  43
 58   0  57  43  11
 59   0  27   1
 60   0  41  43  29  17
 60   0  61  44
 60   0  62  45  30  52
 61   0  60  43
 61   0  62  45
 61 100 107  46
 62   0  60  44
 62   0  63  45
 62   0  30  43
 62   0  61  46
 63   0  62  46  11
 64   0  39  29  56  59
 64   0  65  44  70
 64   0 103  45  74
 64   0 106  43
 65   0  64  43
 65   0  66  44
 65  80 556  46
 65   0  68  61
 65  80 556  29
 65  50  70  29
 65   0  39  29
 65  60 556  45
 65  75  72  45
 65   0  71  45
 65  80 556  30
 65   0 106  30
 66   0  65  47
 66   0  67  44
 66  80 556  46
 66   0  77  25
 66   0  96  43
 66  50 556  50
 66   0  97  72
 67   0  66  43
 67   0  23  44  42
 67   0  24  30  31
 68   0  23  46
 68   0  69  29  56
 68   0  65  45
 69   0  68  30  61
 69 331 120  46
 69   0 119  46
 69   0 109  45
 69   0 113  75
 70   0  71  45
 70   0  65  30  23
 70   0 111  46
 71   0  65  48
 71   0  70  46
 71   0 110  45
 72   0  65  70
 72   0 118  49
 72   0  73  45
 72   0  97  48  72
 73   0  72  46
 73   0 111  44
 74   0  19  43
 74 331 120  44
 74   0 121  44
 74   0  75  30
 75   0  76  46
 75   0  77  45
 76   0  75  45
 77   0  75  43
 77   0  78  44
 77   0  66  45  17
 78   0  77  46
 78 342 150  44
 78   0 706  44
 79   0   3   1
 80   0  42  45
 80   0  80  44  46
 80   0  81  43
 81   0  80  44  11
 82   0  44  46  11
 83   0  57  46
 83   0  84  43
 83   0  85  44
 84   0  57  45
 84   0  83  44
 84   0 114  50
 85   0  83  43  11
 86   0  52  29  11
 87   0  45  29  30
 88   0  25  30  56  43
 88   0  20  39
 88   0  92  44  27
 89   0  25   1
 90   0  23   1
 91   0  95  45  73  23
 91   0  72  30  56
 92   0  88  46
 92   0  93  43
 92   0  94  45
 93   0  92  46  27  11
 94   0  92  46  27  23
 94 309  95  45   3  73
 94   0 611  45
 95   0  94  46  11
 95   0  92  27
 95   0  91  44
 95   0 159  30
 96   0  66  44  11
 97   0  66  48
 97   0  72  44  17
 97   0  98  29  45  73
 98   0  97  46  72
 98   0  99  44
 99   0  98  50  73
 99   0 301  43  23
 99   0 100  43
100   0 301  44  23  11
100   0  99  44
100 159 302  71
100   0  33  71
100   0 101  47  22
101   0 100  46  71  11
101   0  51  43
102   0 103  30  74  11
103   0 102  29  38
103   0 104  30
103 114 618  46
103 115 619  46
103   0  64  46
104   0 103  29  74
104   0 105  30
105   0 104  29  11
105   0 103  74
106   0  64  29
106   0  65  44
106   0 108  43
107   0 131  46
107   0 132  49
107   0 133  47
107   0 134  48
107   0 135  29
107   0 136  50
107   0 137  43
107   0 138  44
107   0 139  45
107   0  61  30
108  95 556  43  45  46  47  48  49  50  29  30
108   0 106  43
108   0 626  44
109   0  69  46
109   0 113  45  75
110   0  71  44
110   0  20  39
111   0  73  43
111   0  70  45
111  40  50  30  39  56
111  50  53  30
111   0  45  30
112   0 131  49
112   0 132  45
112   0 133  43
112   0 134  50
112   0 135  48
112   0 136  47
112   0 137  44
112   0 138  30
112   0 139  29
112   0 140  46
113   0 109  46  11
114   0  84  48
115   0 116  49
116   0 115  47
116   0 593  30
117   0 118  49
117 233 660  41  42  69  47
117 332 661  41
117   0 303  41
117 332  21  39
117   0 596  39
118   0  72  30
118   0 117  29
119   0  69  45  11
119   0 653  43   7
120   0  69  45
120   0  74  43
121   0  74  43  11
121   0 653  45   7
122   0 123  47
122 233 660  41  42  69  49
122   0 303  41
122   0 596  39
122   0 124  77
122   0 126  28
122   0 129  40
123   0 122  44
123   0 124  43  77
123   0 126  28
123   0 129  40
124   0 123  44
124   0 125  47  36
124   0 128  48  37  30
124   0 126  28
124   0 129  40
125   0 124  46  77
125   0 126  45  28
125   0 127  43  17
126   0 125  46  23  11
126   0 124  77
126   0 610  30  39
127   0 125  44  11  17
127   0 124  77
127   0 126  28
128   0 124  45  29  77
128   0 129  46  30  40
128   0 126  28
129   0 128  44  29
129   0 124  77
129   0 130  43  19  40   3
129   0 126  28
130   0 129  44  11
130   0 124  77
130   0 126  28
131   0 107  44
131   0 132  48
131   0 133  50
131   0 134  49
131   0 135  47
131   0 136  29
131   0 137  30
131   0 138  45
131   0 139  46
131   0 112  43
132   0 107  50
132   0 131  29
132   0 133  45
132   0 134  46
132   0 135  44
132   0 136  49
132   0 137  47
132   0 138  43
132   0 139  30
132   0 112  48
133   0 107  29
133   0 131  30
133   0 132  44
133   0 134  47
133   0 135  49
133   0 136  43
133   0 137  45
133   0 138  50
133   0 139  48
133   0 112  46
134   0 107  47
134   0 131  45
134   0 132  50
134   0 133  48
134   0 135  43
134   0 136  30
134   0 137  46
134   0 138  29
134   0 139  44
134   0 112  49
135   0 107  45
135   0 131  48
135   0 132  30
135   0 133  46
135   0 134  43
135   0 136  44
135   0 137  49
135   0 138  47
135   0 139  50
135   0 112  29
136   0 107  43
136   0 131  44
136   0 132  29
136   0 133  49
136   0 134  30
136   0 135  46
136   0 137  50
136   0 138  48
136   0 139  47
136   0 112  45
137   0 107  48
137   0 131  47
137   0 132  46
137   0 133  30
137   0 134  29
137   0 135  50
137   0 136  45
137   0 138  49
137   0 139  43
137   0 112  44
138   0 107  30
138   0 131  43
138   0 132  47
138   0 133  29
138   0 134  44
138   0 135  45
138   0 136  46
138   0 137  48
138   0 139  49
138   0 112  50
139   0 107  49
139   0 131  50
139   0 132  43
139   0 133  44
139   0 134  45
139   0 135  30
139   0 136  48
139   0 137  29
139   0 138  46
139   0 112  47
140   0 112  45  11
141   0   5  49
141   0 142  45
141   0   3  12
142   0 143   7  41  42  45  69
142   0 141  46
142   0   5   6  43  44
143 100 142  42  46  69
143   0 144  43
143   0 145  44
143   0 146  45
144   0 147  29
144   0 143  44
145   0 143  43
145   0 148  29
145   0 149  30
146   0 151  44
146   0 152  43
146   0 153  45
146   0 143  46
147   0 144  30
148   0 145  30
149   0 145  29
149   0 150  43
150   0 149  44
150 342  78  43
150   0 706  43
151   0 146  43
152   0 146  44
153   0 154  45
153   0 146  46
154   0 153  46
154   0 155  44
154   0 156  43
154   0 157  30
155   0 154  43  30
155   0 157  78
155   0 156  79
155   0 160  29
156   0 154  44  30
156   0 158  46
156   0 157  79
156   0 155  78
157   0 149  30
158   0 156  45
159   0  95  29
159   0 103  74
160   0 155  30

========================================================================================
DOCUMENT :usus Folder:VOL24:advx4.code
========================================================================================

< binary file -- not listed >

========================================================================================
DOCUMENT :usus Folder:VOL24:advx4.text
========================================================================================

 1016 'SPEL
 3051 ?
   29 ABOVE
 3050 ABRA
 3050 ABRAC
   42 ACROS
   29 ASCEN
 2012 ATTAC
   26 AWKWA
 1028 AXE
    8 BACK
 1069 BAG
 1043 BALL
   40 BARRE
 1052 BARS
 1039 BATTE
 1024 BEANS
 1035 BEAR
   16 BED
   70 BEDQU
 1008 BIRD
 2023 BLAST
 2023 BLOWU
 1020 BOTTL
 1055 BOX
 2028 BREAK
 2026 BRIEF
   54 BROKE
   12 BUILD
 1004 CAGE
 2010 CALM
   25 CANYO
 2001 CAPTU
 1040 CARPE
 2001 CARRY
 2001 CATCH
   67 CAVE
   73 CAVER
 1064 CHAIN
 2003 CHANT
 1032 CHASM
 1055 CHEST
 1014 CLAM
   56 CLIMB
 2006 CLOSE
   18 COBBL
 1054 COINS
    7 CONTI
 2011 CONTI
   33 CRACK
   17 CRAWL
   69 CROSS
 1072 CROWN
   30 D
   22 DARK
   51 DEBRI
   63 DEPRE
   30 DESCE
   57 DESCR
 2023 DETON
 2014 DEVOU
 1051 DIAMO
 3066 DIG
 2002 DISCA
 2029 DISTU
   35 DOME
 1009 DOOR
 1166 DOOR2
   30 DOWN
    5 DOWNS
   30 DOWNW
 1031 DRAGO
 1029 DRAWI
 2015 DRINK
 2002 DROP
 2002 DUMP
 1017 DWARF
 1017 DWARV
   43 E
   43 EAST
 2014 EAT
 1056 EGG
 1056 EGGS
 1059 EMERA
    3 ENTER
   64 ENTRA
 1071 ERMIN
   57 EXAMI
 3066 EXCAV
   11 EXIT
 2011 EXPLO
 2008 EXTIN
 2025 FEE
 3001 FEE
 2021 FEED
 2025 FIE
 3002 FIE
 2012 FIGHT
 1027 FIGUR
 2022 FILL
 2019 FIND
 1012 FISSU
   58 FLOOR
 2025 FOE
 3003 FOE
 2011 FOLLO
 2025 FOO
 3004 FOO
 1019 FOOD
    6 FORES
   77 FORK
    7 FORWA
 2002 FREE
 3079 FUCK
 2025 FUM
 3005 FUM
 2001 GET
 1037 GEYSE
   27 GIANT
 1043 GLASS
 2011 GO
 1050 GOLD
 2011 GOTO
 1003 GRATE
   13 GULLY
 1021 H2O
   38 HALL
 1002 HEADL
 3051 HELP
    2 HILL
 2012 HIT
 3050 HOCUS
   52 HOLE
   12 HOUSE
 2023 IGNIT
   19 IN
 3142 INFO
 3142 INFOR
   19 INSID
 2020 INVEN
   19 INWAR
 1016 ISSUE
 1067 IVORY
 1068 JADE
 1020 JAR
 1053 JEWEL
 1020 JUG
   39 JUMP
 2001 KEEP
 1001 KEY
 1001 KEYS
 2012 KILL
 1018 KNIFE
   79 KNIGH
 1018 KNIVE
 1002 LAMP
 1002 LANTE
   11 LEAVE
   36 LEFT
 2007 LIGHT
 2006 LOCK
   57 LOOK
 3068 LOST
   24 LOW
 1038 MACHI
 1016 MAGAZ
   76 MAIN
 1036 MESSA
 1058 MING
 1023 MIRRO
 3069 MIST
 1040 MOSS
 2003 MUMBL
   45 N
   47 NE
 1056 NEST
   45 NORTH
 2005 NOTHI
   21 NOWHE
 1050 NUGGE
   21 NULL
   50 NW
 2008 OFF
   76 OFFIC
 1022 OIL
 2007 ON
    7 ONWAR
 1069 OPALS
 2004 OPEN
 3050 OPENS
   72 ORIEN
   11 OUT
   32 OUTDO
   11 OUTSI
   41 OVER
 1015 OYSTE
 1066 PAINT
   23 PASSA
 2030 PAUSE
 1061 PEARL
 1062 PERSI
 2027 PERUS
 1010 PILLO
 1030 PIRAT
   31 PIT
 2010 PLACA
 1024 PLANT
 1025 PLANT
 1060 PLATI
   71 PLOVE
   65 PLUGH
 3050 POCUS
 1058 POTTE
 2013 POUR
 2011 PROCE
 2027 PURUS
 2002 PUT
 1060 PYRAM
 2018 QUIT
 1019 RATIO
 2027 READ
 2002 RELEA
   75 RESER
    8 RETRE
    8 RETUR
   37 RIGHT
    2 ROAD
 1071 ROBE
   15 ROCK
 1005 ROD
 1006 ROD
   59 ROOM
   78 ROYAL
 2016 RUB
 1065 RUBY
 1062 RUG
 2011 RUN
   46 S
 1069 SACK
 2030 SAVE
 2003 SAY
 2024 SCORE
 1073 SCEPT
 1070 SCROL
   48 SE
   66 SECRE
 3050 SESAM
 1027 SHADO
 2009 SHAKE
 1058 SHARD
 2028 SHATT
 3050 SHAZA
   74 SHELL
 1052 SILVE
 2003 SING
   61 SLAB
   61 SLABR
 2012 SLAY
   60 SLIT
 2028 SMASH
 1011 SNAKE
   46 SOUTH
 1016 SPELU
 1063 SPICE
   10 STAIR
 1026 STALA
 1068 STATU
 2001 STEAL
   34 STEPS
 1007 STEPS
 1073 STERL
 3139 STOP
   14 STREA
 2012 STRIK
   20 SURFA
 2030 SUSPE
   49 SW
 3147 SWIM
 2009 SWING
 1013 TABLE
 2001 TAKE
 1067 TALIS
 2010 TAME
 2017 THROW
 2017 TOSS
 2001 TOTE
   57 TOUCH
 2011 TRAVE
 1055 TREAS
 3064 TREE
 3064 TREES
 1057 TRIDE
 1033 TROLL
 1034 TROLL
   23 TUNNE
 2011 TURN
   29 U
 2004 UNLOC
   29 UP
    4 UPSTR
   29 UPWAR
 2003 UTTER
    9 VALLE
 1058 VASE
 1010 VELVE
 1038 VENDI
   28 VIEW
 1037 VOLCA
   44 W
 2029 WAKE
 2011 WALK
   53 WALL
 1021 WATER
 2009 WAVE
   44 WEST
 2019 WHERE
 1041 WIZAR
   62 XYZZY
   55 Y2

========================================================================================
DOCUMENT :usus Folder:VOL24:advx5.text
========================================================================================

  1 Set of keys 
  0 There are some keys on the ground here.
  2 Brass lantern
  0 There is a shiny brass lamp nearby.
100 There is a lamp shining nearby.
  3 *grate
  0 The grate is locked.
100 The grate is open.
  4 wicker cage
  0 There is a small wicker cage discarded nearby.
  5 black rod
  0 A three foot black rod with a rusty star on an end lies nearby.
  6 black rod
  0 A three foot black rod with a rusty mark on an end lies nearby.
  7 *steps
  0 Rough stone steps lead down the pit.
100 Rough stone steps lead up the dome.
  8 little bird in cage
  0 A cheerful little bird is sitting here singing.
100 There is a little bird in the cage.
  9 *rusty door
  0 The way north is barred by a massive, rusty, iron door.
100 The way north leads through a massive, rusty, iron door.
 10 velvet pillow
  0 A small velvet pillow lies on the floor.
 11 *snake
  0 A huge green fierce snake bars the way!
100
 12 *fissure
  0
100 A crystal bridge now spans the fissure.
200 The crystal bridge has vanished!
 13 *stone tablet
  0 A massive stone tablet imbedded in the wall reads: 'Congratulations on
  0  bringing light into the dark-room!'
 14 giant clam  >grunt!<
  0 There is an enormous clam here with its shell tightly closed.
 15 giant oyster  >groan!<
  0 There is an enormous oyster here with its shell tightly closed.
100 Interesting.  There seems to be something written on the underside of the
100  oyster.
 16 'Spelunker Today'
  0 There are a few recent issues of 'Spelunker Today' magazine lying here.
 19 tasty food
  0 There is food here.
 20 small bottle
  0 There is a bottle of water here.
100 There is an empty bottle here.
200 There is a bottle of oil here.
 21 water in the bottle
 22 oil in the bottle
 23 *mirror
  0
 24 *plant
  0 There is a tiny little plant in the pit, murmuring: 'water, water, ...'
100 The plant spurts into furious growth for a few seconds.
200 A 12-foot plant now grows out of the pit, bellowing: 'WATER! WATER!!'
300 The plant grows explosively, almost filling the bottom of the pit. 
400 There is a gigantic beanstalk stretching all the way up to the hole.
500 You've over-watered the plant!  It's shriveling up!  It's, it's...
 25 *phony plant (seen in twopit room only when tall enough)
  0
100 The top of a 12-foot-tall beanstalk is poking out of the west pit.
200 A huge beanstalk stretches out of the west pit up to the hole.
 26 *stalactite
  0
 27 *shadowy figure
  0 The shadowy figure seems to be trying to attract your attention.
 28 dwarf's axe
  0 There is a little axe here.
100 There is a little axe lying beside the bear.
 29 *cave drawings
  0
 30 *pirate
  0
 31 *dragon
  0 A huge green fierce dragon bars the way!
100 Congratulations!  You have just vanquished a dragon with your bare hands!
100   (Unbelievable, isn't it?)
200 The body of a huge green dead dragon is lying off to one side.
 32 *chasm
  0 A rickety wooden bridge extends across the chasm, vanishing into the mist.
  0   A sign posted on the bridge reads: 'Stop!  Pay troll!'
100 The wreckage of a bridge (and a dead bear) can be seen at the bottom of the
100  chasm.
 33 *troll
  0 A burly troll blocks the bridge and demands a treasure to cross!!
100 The troll steps out from beneath the bridge and blocks your way.
200
 34 *phony troll
  0 The troll is nowhere to be seen.
 35
  0 There is a ferocious cave bear eying you from the far end of the room!
100 There is a gentle cave bear sitting placidly in one corner.
200 There is a contented-looking bear wandering about nearby.
300
 36 *message in second maze
  0 There is a message scrawled in the dust in a flowery script, reading: 'This
  0  is not the maze where the pirate leaves his treasure chest.'
 37 *volcano and/or geyser
  0
 38 *vending machine
  0 There is a massive vending machine here.  The instructions on it read:
  0  'Drop coins here to receive fresh batteries.'
 39 batteries
  0 There are fresh batteries here.
100 Some worn-out batteries have been discarded nearby.
 40 *carpet and/or moss
  0
 41 *evil wizard
  0 There is an evil looking wizard here eying you darkly!!!
100
 42 *castle-cave door
  0 The great iron door is locked.
100 The great iron door is unlocked.
 43 curiously shaped glass ball
  0 There is an oddly shaped glass ball here!!!
 50 large gold nugget
  0 There is a large sparkling nugget of gold here!
 51 several diamonds
  0 There are diamonds here!
 52 bars of silver
  0 There are bars of silver here!
 53 precious jewelry
  0 There is precious jewelry here!
 54 rare coins
  0 There are many coins here!
 55 treasure chest
  0 The pirate's treasure chest is here!
 56 golden eggs
  0 There is a large nest here, full of golden eggs!
100 The nest of golden eggs has vanished!
200 Done!
 57 jeweled trident
  0 There is a jewel-encrusted trident here!
 58 ming vase
  0 There is a delicate, precious, ming vase here!
100 The vase is now resting, delicately, on a velvet pillow.
200 The floor is littered with worthless shards of pottery. 
300 The ming vase drops with a delicate crash.
 59 egg-sized emerald
  0 There is an emerald here the size of a plover's egg!
 60 platinum pyramid
  0 There is a platinum pyramid here, 8 inches on a side!
 61 glistening pearl
  0 Off to one side lies a glistening pearl!
 62 Persian rug
  0 There is a Persian rug spread out on the floor!
100 The dragon is sprawled out on a Persian rug!!
 63 rare spices
  0 There are rare spices here!
 64 golden chain
  0 There is a golden chain lying in a heap on the floor!
100 The bear is locked to the wall with a golden chain!
200 There is a golden chain locked to the wall!
 65 large flawless ruby
  0 A large flawless ruby lies on the dirt floor!!
 66 priceless oil paintings
  0 There are some priceless oil paintings hanging here!!!
 67 carved ivory talisman
  0 There is a carved ivory talisman here!!!
 68 mysterious jade statue
  0 There is a small jade statue here!!!
 69 small bag of black opals
  0 There is a small bag of black opals here!!!
 70 ancient Dead Sea scrolls
  0 There are some ancient Dead Sea scrolls here!!!
 71 plush ermine robe
  0 There is a plush ermine robe lying here!!!
 72 heavily jeweled crown
  0 There is a heavily jeweled crown lying here!!!
 73 sterling scepter
  0 There is a sterling scepter here!!!

========================================================================================
DOCUMENT :usus Folder:VOL24:advx6.text
========================================================================================

  1 Somewhere nearby is colossal cave, where others have found fortunes in
  1  treasure and gold, though it is rumored that some who enter are never seen
  1  again.  Magic is said to work in the cave.  I will be your eyes and hands.
  1   Direct me with commands of one or two words.  I should warn you that I
  1  look at only the first five letters of each word, so you'll have to enter
  1  'northeast' as 'NE' to distinguish it from 'north'.  (Should you get
  1  stuck, type 'HELP' for some general hints.  For information on how to end
  1  your adventure, etc., type: 'INFO'.)
  2 A little dwarf with a big knife blocks your way.
  3 A little dwarf just walked around a corner, saw you, threw a little axe at
  3  you which missed, cursed, and ran away.
  4 There is a threatening little dwarf in the room with you!
  5 One sharp nasty knife is thrown at you!
  6 None of them hit you!
  7 One of them gets you!
  8 A hollow voice says: 'PLUGH'.
  9 There is no way to go that direction.
 10 I am unsure how you are facing.  Use compass points or nearby objects.
 11 I don't know in from out here.  Use compass points or name something in the
 11  general direction you want to go.
 12 I don't know how to apply that word here.
 13 I don't understand that!
 14 I'm game.  Would you care to explain how?
 15 Sorry, but I am not allowed to give more detail.  I will repeat the long
 15  description of your location.
 16 It is now pitch dark.  If you proceed you will probably fall into a pit.
 17 If you prefer, simply type W rather than WEST.
 18 Are you trying to catch the bird?
 19 The bird is frightened right now and you cannot catch it no matter what you
 19  try.  Perhaps you might try later.
 20 Are you trying to somehow deal with the snake?
 21 You can't kill the snake, or drive it away, or avoid it, or anything like
 21  that.  There is a way to get by, but you don't have the necessary
 21  resources right now.
 22 Do you really want to quit now?
 23 You fell into a pit and broke every bone in your body!
 24 You are already carrying it!
 25 You can't be serious!
 26 The bird was unafraid when you entered, but as you approach it becomes
 26  disturbed and you cannot catch it.
 27 You can catch the bird, but you cannot carry it.
 28 There is nothing here with a lock!
 29 You aren't carrying it!
 30 The little bird attacks the green snake, and in an astounding flurry drives
 30  the snake away.
 31 You have no keys!
 32 It has no lock.
 33 I don't know how to lock or unlock such a thing.
 34 It was already locked.
 35 The grate is now locked.
 36 The grate is now unlocked.
 37 It was already unlocked.
 38 You have no source of light.
 39 Your lamp is now on.
 40 Your lamp is now off.
 41 There is no way to get past the bear to unlock the chain, which is probably
 41  just as well.
 42 Nothing happens.
 43 Where?
 44 There is nothing here to attack.
 45 The little bird is now dead.  Its body disappears.
 46 Attacking the snake both doesn't work and is very dangerous.
 47 You killed a little dwarf.
 48 You attack a little dwarf, but he dodges out of the way.
 49 With what?  Your bare hands?
 50 Good try, but that is an old worn-out magic word.
 51 I know of places, actions, and things.  Most of my vocabulary describes
 51  places and is used to move you there.  To move, try words like FOREST,
 51  BUILDING, DOWNSTREAM, ENTER, EAST, WEST, NORTH, SOUTH, UP, or DOWN.  I
 51  know about a few special objects, like a black rod hidden in the cave.
 51   These objects can be manipulated using some of the action words that I
 51  know.  Usually you will need to give both the object and action words (in
 51  either order), but sometimes I can infer the object from the verb alone.
 51   Some objects also imply verbs; in particular, 'INVENTORY' implies 'TAKE
 51  INVENTORY', which causes me to give you a list of what you're carrying.
 51   The objects have side effects; for instance, the rod scares the bird.
 51   Usually people having trouble moving just need to try a few more words.
 51   Usually people trying unsuccessfully to manipulate an object are
 51  attempting something beyond their (or my!) capabilities and should try a
 51  completely different tack.  To speed the game you can sometimes move long
 51  distances with a single word.  For example, 'BUILDING' usually gets you to
 51  the building from anywhere above ground except when lost in the forest.
 51   Also, note that cave passages turn a lot, and that leaving a room to the
 51  north does not guarantee entering the next from the south.  Good luck!
 52 It misses!
 53 It gets you!
 54 Ok.
 55 You can't unlock the keys.
 56 You have crawled around in some little holes and wound up back in the main
 56  passage.
 57 I don't know where the cave is, but hereabouts no stream can run on the
 57  surface for long.  I would try the stream.
 58 I need more detailed instructions to do that.
 59 I can only tell you what you see as you move about and manipulate things.
 59   I cannot tell you where remote things are.
 60 I don't know that word.
 61 What?
 62 Are you trying to get into the cave?
 63 The grate is very solid and has a hardened steel lock.  You cannot enter
 63  without a key, and there are no keys nearby.  I would recommend looking
 63  elsewhere for the keys.
 64 The trees of the forest are large hardwood oak and maple, with an
 64  occasional grove of pine or spruce.  There is quite a bit of undergrowth,
 64  largely birch and ash saplings plus nondescript bushes of various sorts.
 64   This time of year visibility is quite restricted by all the leaves, but
 64  travel is quite easy if you detour around the spruce and berry bushes.
 65 Welcome to Adventure!!  Would you like instructions?
 66 Digging without a shovel is quite impractical.  Even with a shovel progress
 66  is unlikely.
 67 Blasting requires dynamite.
 68 I'm as confused as you are.
 69 Mist is a white vapor, usually water, seen from time to time in caverns.
 69   It can be found anywhere but is frequently a sign of a deep pit leading
 69  down to water.
 70 Your feet are now wet.
 71 I think I just lost my appetite.
 72 Thank you, it was delicious!
 73 You have taken a drink from the stream.  The water tastes strongly of
 73  minerals, but is not unpleasant.  It is extremely cold.
 74 The bottle of water is now empty.
 75 Rubbing the electric lamp is not particularly rewarding.  Anyway, nothing
 75  exciting happens.
 76 Peculiar.  Nothing unexpected happens.
 77 Your bottle is empty and the ground is wet.
 78 You can't pour that.
 79 Watch it!
 80 Which way?
 81 Oh dear, you seem to have gotten yourself killed.  I might be able to help
 81  you out, but I've never really done this before.  Do you want me to try to
 81  reincarnate you?
 82 All right.  But don't blame me if something goes wr......
 82                                   --- Poof!! ---                        You
 82  are engulfed in a cloud of orange smoke.  Coughing and gasping, you emerge
 82  from the smoke and find....
 83 You clumsy oaf, you've done it again!  I don't know how long I can keep
 83  this up.  Do you want me to try reincarnating you again?
 84 Okay, now where did I put my orange smoke?....  >Poof!<  Everything
 84  disappears in a dense cloud of orange smoke.
 85 Now you've really done it!  I'm out of orange smoke!  You don't expect me
 85  to do a decent reincarnation without any orange smoke, do you?
 86 Okay, if you're so smart, do it yourself!  I'm leaving!
 90 All of a sudden, you hear a high pitched sound coming from the darkness
 90  behind you.  You turn and see three shimmering shapes start to materialize
 90  into humanoid form.  The light and sound surrounding the figures begins to
 90  dim as their features become clearer.  Suddenly the middle shape shouts
 90  out: 'Dammit, Scotty!!  You got the wrong coordinates!!  Beam us up!!!'
 90   The sound and light spring up in renewed intensity for a few seconds and
 90  then fade away as the figures disappear.
 91 Sorry, but I no longer seem to remember how it was you got here.
 92 You can't carry anything more.  You'll have to drop something first.
 93 You can't go through a locked steel grate!
 94 I believe what you want is right here with you.
 95 You don't fit through a two-inch slit!
 96 I respectfully suggest you go across the bridge instead of jumping.
 97 There is no way across the fissure.
 98 You're not carrying anything.
 99 You are currently holding the following:
100 It's not hungry (it's merely pinin' for the fjords).  Besides, you have no
100  bird seed.
101 The snake has now devoured your bird.
102 There's nothing here it wants to eat (except perhaps you).
103 You fool, dwarves eat only coal!  Now you've made him *really* mad!!
104 You have nothing in which to carry it.
105 Your bottle is already full.
106 There is nothing here with which to fill the bottle.
107 Your bottle is now full of water.
108 Your bottle is now full of oil.
109 You can't fill that.
110 Don't be ridiculous!
111 The door is extremely rusty and refuses to open.
112 The plant indignantly shakes the oil off its leaves and asks: 'water?'
113 The hinges are quite thoroughly rusted now and won't budge.
114 The oil has freed up the hinges so that the door will now move, although it
114  requires some effort.
115 The plant has exceptionally deep roots and cannot be pulled free.
116 The dwarves' knives vanish as they strike the walls of the cave.
117 Something you're carrying won't fit through the tunnel with you.  You'd
117  best take inventory and drop something.
118 You can't fit this five-foot clam through that little passage!
119 You can't fit this five-foot oyster through that little passage!
120 I advise you to put down the clam before opening it.  >Strain!<
121 I advise you to put down the oyster before opening it.  >Wrench!<
122 You don't have anything strong enough to open the clam.
123 You don't have anything strong enough to open the oyster.
124 A glistening pearl falls out of the clam and rolls away.  Goodness, this
124  must really be an oyster.  (I never was very good at identifying
124  bivalves.)  Whatever it is, it has now snapped shut again.
125 The oyster creaks open, revealing nothing but oyster inside.  It promptly
125  snaps shut again.
126 You have crawled around in some little holes and found your way blocked by
126  a recent cave-in.  You are now back in the main passage.
127 There are faint rustling noises from the darkness behind you.
128 Out from the shadows behind you pounces a bearded pirate!  'Har, har ' he
128  chortles, 'I'll just take all this booty and hide it away with me chest
128  deep in the maze!'  He snatches your treasure and vanishes into the gloom.
129 A sepulchral voice reverberating through the cave says: 'Cave closing soon.
129   All adventurers must exit immediately through the main office.'
130 A mysterious recorded voice groans into life and announces: 'This exit is
130  closed.  Please leave via main office.'
131 It looks as though you're dead.  Well, seeing as how it's so close to
131  closing time anyway, I think we'll just call it a day.
132 The sepulchral voice entones: 'The cave is now closed.'  As the echoes
132  fade, there is a blinding flash of light (and a small puff of orange
132  smoke). . . .    As your eyes refocus, you look around and find...
133 There is a loud explosion, and a twenty-foot hole appears in the far wall,
133  burying the dwarves in the rubble.  You march through the hole and find
133  yourself in the main office, where a cheering band of friendly elves carry
133  the conquering adventurer off into the sunset.
134 There is a loud explosion, and a twenty-foot hole appears in the far wall,
134  burying the snakes in the rubble.  A river of molten lava pours in through
134  the hole, destroying everything in its path, including you!
135 There is a loud explosion, and you are suddenly splashed across the walls
135  of the room.
136 The resulting ruckus has awakened the dwarves.  There are now several
136  threatening little dwarves in the room with you!  Most of them throw
136  knives at you!  All of them get you!
137 Oh, leave the poor unhappy bird alone.
138 I daresay whatever you want is around here somewhere.
139 I don't know the word 'STOP'.  Use 'QUIT' if you want to give up.
140 You can't get there from here.
141 You are being followed by a very large, tame bear.
142 If you want to end your adventure early, say 'QUIT'.  To see how well
142  you're doing, say 'SCORE'.  To get full credit for a treasure, you must
142  have left it safely in the building, though you get partial credit just
142  for locating it.  You lose points for getting killed, or for quitting,
142  though the former costs you more.  There are also points based on how much
142  (if any) of the cave you've managed to explore; in particular, there is a
142  large bonus just for getting in (to distinguish the beginners from the
142  rest of the pack), and there are other ways to determine whether you've
142  been through some of the more harrowing sections.  If you think you've
142  found all the treasures, just keep exploring for a while.  If nothing
142  interesting happens, you haven't found them all yet.  If something
142  interesting *does* happen, it means you're getting a bonus and have an
142  opportunity to garner many more points in the master's section.  I may
142  occasionally offer hints if you seem to be having trouble.  If I do, I'll
142  warn you in advance how much it will affect your score to accept the
142  hints.  Finally, to save time, you may specify 'BRIEF', which tells me
142  never to repeat the full description of a place unless you explicitly
142  request it.
143 Do you indeed wish to quit now?
144 There is nothing here with which to fill the vase.
145 The sudden change in temperature has delicately shattered the vase.
146 It is beyond your power to do that.
147 I don't know how.
148 It is too far up for you to reach.
149 You killed a little dwarf.  The body vanishes in a cloud of greasy black
149  smoke.
150 The shell is very strong and is impervious to attack.
151 What's the matter, can't you read?  Now you'd best start over.
152 The axe bounces harmlessly off the dragon's thick scales.
153 The dragon looks rather nasty.  You'd best not try to get by.
154 The little bird attacks the green dragon, and in an astounding flurry gets
154  burnt to a cinder.  The ashes blow away.
155 On what?
156 Okay, from now on I'll only describe a place in full the first time you
156  come to it.  To get the full description, say 'LOOK'.
157 Trolls are close relatives with the rocks and have skin as tough as that of
157  a rhinoceros.  The troll fends off your blows effortlessly.
158 The troll deftly catches the axe, examines it carefully, and tosses it
158  back, declaring: 'Good workmanship, but it's not valuable enough.'
159 The troll catches your treasure and scurries away out of sight.
160 The troll refuses to let you cross.
161 There is no longer any way across the chasm.
162 Just as you reach the other side, the bridge buckles beneath the weight of
162  the bear, which was still following you around.  You scrabble desperately
162  for support, but as the bridge collapses you stumble back and fall into
162  the chasm.
163 The bear lumbers toward the troll, who lets out a startled shriek and
163  scurries away.  The bear soon gives up the pursuit and wanders back.
164 The axe misses and lands near the bear where you can't get at it.
165 With what?  Your bare hands?  Against *his* bear hands??
166 The bear is confused; he only wants to be your friend.
167 For crying out loud, the poor thing is already dead!
168 The bear eagerly wolfs down your food, after which he seems to calm down
168  considerably and even becomes rather friendly.
169 The bear is still chained to the wall.
170 The chain is still locked.
171 The chain is now unlocked.
172 The chain is now locked.
173 There is nothing here to which the chain can be locked.
174 There is nothing here to eat.
175 Do you want the hint?
176 Do you need help getting out of the maze?
177 You can make the passages look less alike by dropping things.
178 Are you trying to explore beyond the plover room?
179 There is a way to explore that region without having to worry about falling
179  into a pit.  None of the objects available is immediately useful in
179  discovering the secret.
180 Do you need help getting out of here?
181 Don't go west.
182 Gluttony is not one of the troll's vices.  Avarice, however, is.
183 Your lamp is getting dim.  You'd best start wrapping this up, unless you
183  can find some fresh batteries.  I seem to recall there's a vending machine
183  in the maze.  Bring some coins with you.
184 Your lamp has run out of power.
185 There's not much point in wandering around out here, and you can't explore
185  the cave without a lamp.  So let's just call it a day.
186 There are faint rustling noises from the darkness behind you.  As you turn
186  toward them, the beam of your lamp falls across a bearded pirate.  He is
186  carrying a large chest.  'Shiver me timbers!' he cries, 'I've been
186  spotted!  I'd best hie meself off to the maze to hide me chest!'  With
186  that, he vanishes into the gloom.
187 Your lamp is getting dim.  You'd best go back for those batteries.
188 Your lamp is getting dim.  I'm taking the liberty of replacing the
188  batteries.
189 Your lamp is getting dim, and you're out of spare batteries.  You'd best
189  start wrapping this up.
190 I'm afraid the magazine is written in dwarvish.
191 'This is not the maze where the pirate leaves his treasure chest.'
192 Hmmm, this looks like a clue, which means it'll cost you ten points to read
192  it.  Should I go ahead and read it anyway?
193 It says: 'There is something strange about this place, such that one of the
193  words I've always known now has a new effect.'
194 It says the same thing it did before.
195 I'm afraid I don't understand.
196 'Congratulations on bringing light into the dark-room!'
197 You strike the mirror a resounding blow, whereupon it shatters into a
197  myriad of tiny fragments.
198 You have taken the vase and hurled it delicately to the ground.
199 You prod the nearest dwarf, who wakes up grumpily, takes one look at you,
199  curses, and grabs for his axe.
200 Is this acceptable?
201 Are you resuming an earlier Adventure?
202 It was already locked.
203 The door is now locked.
204 The door is now unlocked.
205 It was already unlocked.
206 You can't get past a locked, heavy iron door.
207 The wizard shrieks as he recognizes the ball.  Unbelievably, he begins to
207  shrink.  The glass pulsates, growing hotter and brighter as the wizard
207  runs around in circles growing smaller and smaller until he is no larger
207  than an ant.  The ball begins to move on its own, toward the wizard who
207  vainly attempts to move away.  As contact is made, both wizard and glass
207  ball disappear in a cloud of smoke and and a clap of thunder.
208 The wizard is now salivating on your arm.
209 Physical violence is useless against the powers of magic.
210 A sign nearby says: 'Keys in main office'.
211 A lightening bolt is hurled at you!!!
212 The wizard gags heartily and slaps your face.
213 The wizard laughs as the axe bounces off an invisible shield!!
214 Unfortunately, the scrolls have been written in Babylonian.

========================================================================================
DOCUMENT :usus Folder:VOL24:advx7.text
========================================================================================

  1   3   0
  2   3   0
  3   8   9
  4  10   0
  5  11   0
  6   0   0
  7  14  15
  8  13   0
  9  94  -1
 10  96   0
 11  19  -1
 12  17  27
 13 101  -1
 14 103   0
 15   0   0
 16 106   0
 17   0  -1
 18   0   0
 19   3   0
 20   3   0
 21   0   0
 22   0   0
 23 109  -1
 24  25  -1
 25  23  67
 26 111  -1
 27  35 110
 28   0   0
 29  97  -1
 30   0   0
 31 119 121
 32 117 122
 33 117 122
 34   0   0
 35 130  -1
 36   0  -1
 37 126  -1
 38 140  -1
 39   0   0
 40  96  -1
 41 149  -1
 42  78 150
 43 157   0
 44   0   0
 45   0   0
 46   0   0
 47   0   0
 48   0   0
 49   0   0
 50  18   0
 51  27   0
 52  35   0
 53  29   0
 54  30   0
 55   0   0
 56  92   0
 57  95   0
 58  97   0
 59 100   0
 60 101   0
 61   0   0
 62 119 121
 63 127   0
 64 130  -1
 65  73   0
 66 155   0
 67 158   0
 68   0   0
 69 148   0
 70 150   0
 71 159   0
 72 160   0
 73 126   0
 74   0   0
 75   0   0
 76   0   0
 77   0   0
 78   0   0
 79   0   0
 80   0   0
 81   0   0
 82   0   0
 83   0   0
 84   0   0
 85   0   0
 86   0   0
 87   0   0
 88   0   0
 89   0   0
 90   0   0
 91   0   0
 92   0   0
 93   0   0
 94   0   0
 95   0   0
 96   0   0
 97   0   0
 98   0   0
 99   0   0
100   0   0

========================================================================================
DOCUMENT :usus Folder:VOL24:advx8.text
========================================================================================

  1  24
  2  29
  3   0
  4  33
  5   0
  6  33
  7  38
  8  38
  9  42
 10  14
 11  43
 12 110
 13  29
 14 110
 15  73
 16  75
 17  29
 18  13
 19  59
 20  59
 21 174
 22 109
 23  67
 24  13
 25 147
 26 155
 27 195
 28 146
 29 110
 30  13
 31  13
 32   0
 33   0
 34   0
 35   0

========================================================================================
DOCUMENT :usus Folder:VOL24:advx9.text
========================================================================================

    0    1    2    3    4    5    6    7    8    9   10
    0  141  142  143  144  145  146  147  148  149  150
    0  151  152  153  154  155  156  157  158
    0  100  115  116  126  160
    1   16   20   21   22   24   26   31   32   40   59
    1   79   89   90
    2    1    3    4    7   24   38   95  113
    3   46   47   48   54   56   58   82   85   86  122
    3  123  124  125  126  127  128  129  130
    4    8
    5   13
    6   19
    7   42   43   44   45   46   47   48   49   50   51
    7   52   53   54   55   56   80   81   82   86   87
    8   99  100  101
    9  108

========================================================================================
DOCUMENT :usus Folder:VOL24:advxcons.text
========================================================================================

clsmax = 12;
hntmax = 20;
locsiz = 160;
rtxsiz = 215;
tabsiz = 320;
trvsiz = 805;
vrbsiz = 35;


========================================================================================
DOCUMENT :usus Folder:VOL24:advxinit.text
========================================================================================

PROGRAM ADVINIT; 

const
  {$I advxcons.text}

TYPE
  CHAR6 = PACKED ARRAY[1..6] OF CHAR;
  ARYS = RECORD
           CASE BOOLEAN OF
             FALSE : ( DBLK : PACKED ARRAY[1..512] OF CHAR);
             TRUE  : (TRAVEL : ARRAY[1..trvsiz] OF INTEGER;
                      TRAVEL2 : ARRAY[1..trvsiz] OF INTEGER;
                      TRAVEL3 : ARRAY[1..trvsiz] OF INTEGER;
                      ATAB : ARRAY[1..tabsiz] OF STRING[5];
                      KTAB : ARRAY[1..tabsiz] OF INTEGER;
                      LTEXT : ARRAY[1..locsiz] OF INTEGER;
                      STEXT : ARRAY[1..locsiz] OF INTEGER;
                      KEY : ARRAY[1..locsiz] OF INTEGER;
                      PLAC : ARRAY[1..100] OF INTEGER;
                      FIXD : ARRAY[1..100] OF INTEGER;
                      PTEXT : ARRAY[1..100] OF INTEGER;
                      ACTSPK : ARRAY[1..vrbsiz] OF INTEGER;
                      RTEXT : ARRAY[1..rtxsiz] OF INTEGER;
                      CTEXT : ARRAY[1..clsmax] OF INTEGER;
                      CVAL : ARRAY[1..clsmax] OF INTEGER;
                      HINTS : ARRAY[1..hntmax, 1..4] OF INTEGER)
         END;
  VARYS = RECORD
            CASE BOOLEAN OF
              FALSE : ( DBLK : PACKED ARRAY[1..512] OF CHAR);
              TRUE  : (COND : ARRAY[1..locsiz] OF INTEGER;
                       ABB : ARRAY[1..locsiz] OF INTEGER;
                       ATLOC : ARRAY[1..locsiz] OF INTEGER;
                       PLACE : ARRAY[1..100] OF INTEGER;
                       FIXED : ARRAY[1..100] OF INTEGER;
                       LINK : ARRAY[1..200] OF INTEGER;
                       PROP : ARRAY[1..100] OF INTEGER;
                       HINTLC : ARRAY[1..hntmax] OF INTEGER;
                       HINTED : ARRAY[1..hntmax] OF BOOLEAN;
                       DSEEN : ARRAY[1..6] OF BOOLEAN;
                       DLOC : ARRAY[1..6] OF INTEGER;
                       ODLOC : ARRAY[1..6] OF INTEGER;
                       TK : ARRAY[1..20] OF INTEGER)
          END;

VAR
  MSGNDX, SEG, CLASSES, RECNUM, I, J, COUNT : INTEGER;
  ACHAR : CHAR;
  ARY : ^ARYS;
  VARY : ^VARYS;
  MSGFILE : FILE OF CHAR6;
  SAVEMSG : STRING[10];
  INFILE : TEXT;
  OUTFILE : FILE;


  PROCEDURE DROP(OBJECT, WHERE : INTEGER);

  BEGIN
    WITH VARY^ DO
      BEGIN
        IF OBJECT > 100 THEN
          FIXED[OBJECT - 100] := WHERE
        ELSE
          PLACE[OBJECT] := WHERE;
        IF WHERE > 0 THEN
          BEGIN
            LINK[OBJECT] := ATLOC[WHERE];
            ATLOC[WHERE] := OBJECT
          END
      END
  END;  { DROP }


  PROCEDURE BLIP;

  BEGIN
    IF COUNT = 50 THEN
      BEGIN
        COUNT := 0;
        WRITELN;
        WRITE('           .')
      END
    ELSE
      WRITE('.');
    COUNT := COUNT + 1
  END;  {BLIP}


  PROCEDURE BLIPER(MSG : STRING); 

  BEGIN
    COUNT := 0;
    WRITELN;
    WRITE(MSG)
  END;  { BLIPER }


  PROCEDURE PUTMSG(MSG : STRING;SAME : BOOLEAN);

  VAR
    I : INTEGER;

  BEGIN { PUTMSG }
    IF LENGTH(MSG) = 0 THEN MSG := ' ';
    IF SAME THEN
      BEGIN
        IF LENGTH(SAVEMSG) <> 0 THEN RECNUM := RECNUM - 1;
        MSG := CONCAT(SAVEMSG, MSG);
        SAVEMSG := ''
      END
    ELSE
      BEGIN
        IF SAVEMSG <> '' THEN
          BEGIN
            WHILE LENGTH(SAVEMSG) < 5 DO SAVEMSG := CONCAT(SAVEMSG, ' ');
            PUTMSG(' ', TRUE)
          END;
        MSGFILE^[1] := CHR(ORD(MSGFILE^[1]) + 128)
      END;
    WHILE LENGTH(MSG) >= 6 DO
      BEGIN
        PUT(MSGFILE);  { PUT LAST MESSAGE }
        FOR I := 1 TO 6 DO MSGFILE^[I] := MSG[I];
        DELETE(MSG, 1, 6);
        RECNUM := RECNUM + 1
      END;
    SAVEMSG := MSG;
    IF LENGTH(SAVEMSG) <> 0 THEN RECNUM := RECNUM + 1
  END;  { PUTMSG }


  PROCEDURE TXTREAD;

  VAR
    LAST, I : INTEGER;
    MSGTXT : STRING[128];

  BEGIN {TXTREAD}
    LAST := 32761;
    REPEAT
      READ(INFILE, MSGNDX);
      BLIP;
      IF NOT EOF(INFILE) THEN
        BEGIN
          IF NOT EOLN(INFILE) THEN READ(INFILE, ACHAR); { ONE BLANK DELIMITER } 
          if (SEG <> 5) and (msgndx <= 0) then
            begin
              write('Bad message number!');
              exit(ADVINIT)
            end;
          CASE SEG OF
            1 : if MSGNDX > locsiz then
                  begin
                    write('Too many locations!');
                    exit(ADVINIT)
                  end
                else
                  IF ARY^.LTEXT[MSGNDX] = 0 THEN ARY^.LTEXT[MSGNDX] := RECNUM;
            2 : if MSGNDX > locsiz then
                  begin
                    write('Too many locations!');
                    exit(ADVINIT)
                  end
                else
                  IF ARY^.STEXT[MSGNDX] = 0 THEN ARY^.STEXT[MSGNDX] := RECNUM;
            5 : IF (MSGNDX > 0) AND (MSGNDX <= 100) THEN
                  IF ARY^.PTEXT[MSGNDX] = 0 THEN ARY^.PTEXT[MSGNDX] := RECNUM;
            6 : if MSGNDX > rtxsiz then
                  begin
                    write('Too many messages!');
                    exit(ADVINIT)
                  end
                else
                  IF ARY^.RTEXT[MSGNDX] = 0 THEN ARY^.RTEXT[MSGNDX] := RECNUM;
            10 : BEGIN
                   if CLASSES >= clsmax then
                     begin
                       write('Too many classes!');
                       exit(ADVINIT)
                     end;
                   CLASSES := CLASSES + 1;
                   IF ARY^.CTEXT[CLASSES] = 0 THEN
                     ARY^.CTEXT[CLASSES] := RECNUM;
                   ARY^.CVAL[CLASSES] := MSGNDX
                 END
          END;
          READLN(INFILE, MSGTXT); 
          PUTMSG(MSGTXT, MSGNDX = LAST);
          LAST := MSGNDX
        END
    UNTIL EOF(INFILE);
    IF LENGTH(SAVEMSG) > 0 THEN
      BEGIN
        WHILE LENGTH(SAVEMSG) < 5 DO SAVEMSG := CONCAT(SAVEMSG, ' ');
        PUTMSG(' ', TRUE)
      END;
    CLOSE(INFILE)
  END;  { TXTREAD }


  PROCEDURE SEGMENT1;

  BEGIN
    BLIPER('<Segment1 >');
    RESET(INFILE, 'ADVx1.TEXT');
    SEG := 1;
    TXTREAD
  END;  { SEGMENT1 }


  PROCEDURE SEGMENT2;

  BEGIN
    BLIPER('<Segment2 >');
    RESET(INFILE, 'ADVx2.TEXT');
    SEG := 2;
    TXTREAD
  END;  { SEGMENT2 }


  PROCEDURE SEGMENT3;

  VAR
    TVINDEX, INDEX, TRVL, TVCOND, VOIB : INTEGER;

  BEGIN { SEGMENT3 }
    TVINDEX := 1;
    BLIPER('<Segment3 >');
    RESET(INFILE, 'ADVx3.TEXT');
    WHILE NOT EOF(INFILE) DO
      BEGIN
        READ(INFILE, INDEX);
        BLIP;
        IF NOT EOLN(INFILE) THEN
          BEGIN
            READ(INFILE, TVCOND, TRVL);
            IF ARY^.KEY[INDEX] = 0 THEN
              ARY^.KEY[INDEX] := TVINDEX
            ELSE
              ARY^.TRAVEL[TVINDEX - 1] := -ARY^.TRAVEL[TVINDEX - 1];
            WHILE NOT EOLN(INFILE) DO
              BEGIN
                if TVINDEX > trvsiz then
                  begin 
                    write('Too many travel options!');
                    exit(ADVINIT)
                  end;
                READ(INFILE, VOIB);
                ARY^.TRAVEL[TVINDEX] := VOIB;
                ARY^.TRAVEL2[TVINDEX] := TRVL;
                ARY^.TRAVEL3[TVINDEX] := TVCOND;
                TVINDEX := TVINDEX + 1
              END;
            ARY^.TRAVEL[TVINDEX - 1] := -ARY^.TRAVEL[TVINDEX - 1];
            READLN(INFILE)
          END
      END;
    CLOSE(INFILE)
  END;  { SEGMENT3 }


  PROCEDURE SEGMENT4;

  VAR
    WORDNUM, NUMBER : INTEGER;

  BEGIN { SEGMENT4 }
    WORDNUM := 0;
    BLIPER('<Segment4 >');
    RESET(INFILE, 'ADVx4.TEXT');
    WHILE NOT EOF(INFILE) DO
      BEGIN
        READ(INFILE, NUMBER);
        BLIP;
        IF NOT EOLN(INFILE) THEN
          BEGIN
            READ(INFILE, ACHAR);
            if WORDNUM >= tabsiz then
              begin
                write('Too many vocabulary words!');
                exit(ADVINIT)
              end;
            WORDNUM := WORDNUM + 1;
            READLN(INFILE, ARY^.ATAB[WORDNUM]);
            ARY^.KTAB[WORDNUM] := NUMBER
          END
      END;
    CLOSE(INFILE)
  END;  { SEGMENT4 }


  PROCEDURE SEGMENT5;

  BEGIN
    BLIPER('<Segment5 >');
    RESET(INFILE, 'ADVx5.TEXT');
    SEG := 5;
    TXTREAD
  END;  { SEGMENT5 }


  PROCEDURE SEGMENT6; 

  BEGIN
    BLIPER('<Segment6 >');
    RESET(INFILE, 'ADVx6.TEXT');
    SEG := 6;
    TXTREAD
  END;  { SEGMENT6 }


  PROCEDURE SEGMENT7;

  VAR
    ILOC1, ILOC2, OBJECT : INTEGER;

  BEGIN { SEGMENT7 }
    BLIPER('<Segment7 >');
    RESET(INFILE, 'ADVx7.TEXT');
    WHILE NOT EOF(INFILE) DO
      BEGIN
        READ(INFILE, OBJECT);
        if OBJECT > 100 then
          begin
            write('Too many objects!');
            exit(ADVINIT)
          end;
        BLIP;
        IF NOT EOLN(INFILE) THEN
          BEGIN
            READLN(INFILE, ILOC1, ILOC2);
            ARY^.PLAC[OBJECT] := ILOC1;
            ARY^.FIXD[OBJECT] := ILOC2
          END
      END;
    CLOSE(INFILE)
  END;  { SEGMENT7 }


  PROCEDURE SEGMENT8;

  VAR
    VOIB, MSGNUM : INTEGER;

  BEGIN { SEGMENT8 }
    BLIPER('<Segment8 >');
    RESET(INFILE, 'ADVx8.TEXT');
    WHILE NOT EOF(INFILE) DO
      BEGIN
        READ(INFILE, VOIB);
        if VOIB > vrbsiz then
          begin
            write('Too many action verbs!');
            exit(ADVINIT)
          end;
        BLIP;
        IF NOT EOLN(INFILE) THEN
          BEGIN
            READLN(INFILE, MSGNUM);
            ARY^.ACTSPK[VOIB] := MSGNUM
          END
      END;
    CLOSE(INFILE)
  END;  { SEGMENT8 } 


  PROCEDURE SEGMENT9;

  VAR
    I, TEMP, COND, LOC : INTEGER;

  BEGIN { SEGMENT9 }
    BLIPER('<Segment9 >');
    RESET(INFILE, 'ADVx9.TEXT');
    WHILE NOT EOF(INFILE) DO
      BEGIN
        READ(INFILE, COND);
        if COND > 15 then
          begin
            write('Too many conditions!');
            exit(ADVINIT)
          end;
        BLIP;
        TEMP := 1;
        FOR I := 1 TO COND DO TEMP := TEMP * 2;
        WHILE NOT EOLN(INFILE) DO
          BEGIN
            READ(INFILE, LOC);
            if LOC > locsiz then
              begin
                write('Too many locations!');
                exit(ADVINIT)
              end;
            VARY^.COND[LOC] := VARY^.COND[LOC] + TEMP
          END;
        READLN(INFILE)
      END;
    CLOSE(INFILE)
  END;  { SEGMENT9 }


  PROCEDURE SEGMENTA;

  BEGIN
    BLIPER('<Segment10>');
    RESET(INFILE, 'ADVx10.TEXT');
    SEG := 10;
    TXTREAD
  END;  { SEGMENTA }


  PROCEDURE SEGMENTB;

  VAR
    HINT, TURNS, POINTS, QUES, ANS : INTEGER;

  BEGIN { SEGMENTB }
    BLIPER('<Segment11>');
    RESET(INFILE, 'ADVx11.TEXT');
    WHILE NOT EOF(INFILE) DO
      BEGIN
        READ(INFILE, HINT);
        if HINT > hntmax then
          begin
            write('Too many hints!'); 
            exit(ADVINIT)
          end;
        BLIP;
        IF NOT EOLN(INFILE) THEN
          BEGIN
            READLN(INFILE, TURNS, POINTS, QUES, ANS);
            ARY^.HINTS[HINT, 1] := TURNS;
            ARY^.HINTS[HINT, 2] := POINTS;
            ARY^.HINTS[HINT, 3] := QUES;
            ARY^.HINTS[HINT, 4] := ANS
          END
      END;
    CLOSE(INFILE)
  END;  { SEGMENTB }


  PROCEDURE LINKUP;

  VAR
    K, I : INTEGER;

  BEGIN {LINKUP}
    BLIP;
    WITH ARY^, VARY^ DO
      FOR I := 1 TO locsiz DO
        IF ((LTEXT[I] <> 0) AND (KEY[I] <> 0)) THEN
          IF TRAVEL[KEY[I]] = 1 THEN COND[I] := 2;
    BLIP;
    WITH ARY^ DO
      FOR I := 100 DOWNTO 1 DO
        IF FIXD[I] > 0 THEN
          BEGIN
            DROP(I + 100, FIXD[I]);
            DROP(I, PLAC[I])
          END;
    BLIP;
    WITH ARY^ DO
      FOR I := 100 DOWNTO 1 DO
        BEGIN
          VARY^.FIXED[I] := FIXD[I];
          IF (PLAC[I] <> 0) AND (FIXD[I] <= 0) THEN DROP(I, PLAC[I])
        END;
    BLIP;
    WITH ARY^, VARY^ DO
      FOR I := 50 TO 100 DO
        IF PTEXT[I] <> 0 THEN PROP[I] := -1
  END;  {LINKUP}


BEGIN { ADVINIT }
  NEW(ARY);
  FILLCHAR(ARY^.DBLK, SIZEOF(ARYS), CHR(0));  { ZERO ARRAYS }
  NEW(VARY);
  FILLCHAR(VARY^.DBLK, SIZEOF(VARYS), CHR(0));  { ZERO ARRAYS }
  CLASSES := 0;
  RECNUM := 1;
  COUNT := 0;
  REWRITE(MSGFILE, 'ADVxMSGS');
  MSGFILE^ := 'MSGFIL';  {WILL BE PUT }
  SAVEMSG := '';
  SEGMENT1;  {LONG DESCRIPTIONS}
  SEGMENT2;  {SHORT DESCRIPTIONS}
  SEGMENT3;   {TRAVEL OPTIONS}
  SEGMENT4;  {WORD TABLE}
  SEGMENT5;  {OBJECT PROPERTIES}
  SEGMENT6;  {MISC MESSAGES}
  SEGMENT7;  {OBJECT LOCATIONS}
  SEGMENT8;  {VERB DEFAULT ACTIONS}
  SEGMENT9;  {LIQUID ASSETS}
  SEGMENTA;  {PLAYER CLASS MESSAGES}
  SEGMENTB;  {HINTS}
  LINKUP;    {BUILD MISC ARRAYS}
  PUTMSG('EXTMSG', FALSE);
  PUT(MSGFILE);  {PURGE LAST BUFFER}
  CLOSE(MSGFILE, LOCK);
  WRITELN;
  writeln('ADVXMSGS created.');
  REWRITE(OUTFILE, 'ADVxDATA');
  I := (SIZEOF(ARYS) + 511) DIV 512;
  IF I <> BLOCKWRITE(OUTFILE, ARY^.DBLK, I) THEN
    BEGIN
      WRITELN('Error writing file.');
      EXIT(ADVINIT)
    END;
  I := (SIZEOF(VARYS) + 511) DIV 512;
  IF I <> BLOCKWRITE(OUTFILE, VARY^.DBLK, I) THEN
    BEGIN
      WRITELN('Error writing file.');
      EXIT(ADVINIT)
    END;
  CLOSE(OUTFILE, LOCK);
  WRITELN('ADVXDATA created.')
END.

========================================================================================
DOCUMENT :usus Folder:VOL24:advxinit2.code
========================================================================================

< binary file -- not listed >

========================================================================================
DOCUMENT :usus Folder:VOL24:advxinit4.code
========================================================================================

< binary file -- not listed >

========================================================================================
DOCUMENT :usus Folder:VOL24:advxsegs.text
========================================================================================

PROCEDURE NAMEANDPW;     FORWARD;
FUNCTION GETSCORE(SCORECMD : BOOLEAN ) : INTEGER;   FORWARD;
FUNCTION TOTING(OBJECT : INTEGER) : BOOLEAN;  FORWARD;
FUNCTION AT(OBJECT : INTEGER) : BOOLEAN;  FORWARD;
FUNCTION MIN(I, J : INTEGER) : INTEGER;  FORWARD;
FUNCTION MAX(I, J : INTEGER) : INTEGER;  FORWARD;
FUNCTION RAN(NUM : INTEGER) : INTEGER;  FORWARD;
FUNCTION PERCENT(I : INTEGER) : BOOLEAN;  FORWARD;
FUNCTION HERE(OBJECT : INTEGER) : BOOLEAN;  FORWARD;
FUNCTION DARK : BOOLEAN;  FORWARD;
FUNCTION FORCED(LOC : INTEGER) : BOOLEAN;  FORWARD;
FUNCTION BITSET(I, J : INTEGER) : BOOLEAN;  FORWARD;
FUNCTION LIQ2(PBOTL : INTEGER) : INTEGER;  FORWARD;
FUNCTION LIQ : INTEGER;  FORWARD;
FUNCTION LIQLOC(LOC : INTEGER) : INTEGER;  FORWARD;
FUNCTION VOCAB(WORD : STRING;WHAT : INTEGER) : INTEGER;  FORWARD;
PROCEDURE CARRY(OBJECT, WHERE : INTEGER);  FORWARD;
PROCEDURE DROP(OBJECT, WHERE : INTEGER);  FORWARD;
PROCEDURE MOVE(OBJECT, WHERE : INTEGER);  FORWARD;
PROCEDURE JUGGLE(OBJECT : INTEGER);  FORWARD;
PROCEDURE DESTROY(OBJECT : INTEGER);  FORWARD;
FUNCTION PUT(OBJECT, WHERE, PVAL : INTEGER) : INTEGER;  FORWARD;
PROCEDURE SPEAK(MSG : INTEGER);  FORWARD;
PROCEDURE PSPEAK(MSG, SKIP : INTEGER);  FORWARD;
FUNCTION YES(MSG, SPKYES, SPKNO : INTEGER) : BOOLEAN;  FORWARD;
PROCEDURE ERRORHALT(I : INTEGER);  FORWARD;
PROCEDURE TESTCLOSE;  FORWARD;
{ SUBROUTINES FOR ADVENTURE } 

SEGMENT PROCEDURE SET_NEW_LOC;

VAR
  T1, T2, T3 : BOOLEAN;


  PROCEDURE PLOVERALCOVE;

  BEGIN
    NEWLOC := 199 - VBL^.LOC; 
    IF (VBL^.HLDING = 0) OR ((VBL^.HLDING = 1) AND TOTING(EMERALD)) THEN
    ELSE
      BEGIN
        NEWLOC := VBL^.LOC;
        SPEAK(ARY^.RTEXT[117])
      END;
    EXIT(SET_NEW_LOC)
  END;  { PLOVERALCOVE }


  PROCEDURE TROLLBRIDGE;

  BEGIN
    IF VARY^.PROP[TROLL] = 1 THEN
      BEGIN
        PSPEAK(TROLL, 1);
        VARY^.PROP[TROLL] := 0;
        MOVE(TROLL2, 0);
        MOVE(TROLL2 + 100, 0);
        MOVE(TROLL, ARY^.PLAC[TROLL]);
        MOVE(TROLL + 100, ARY^.FIXD[TROLL]);
        JUGGLE(CHASM);
        NEWLOC := VBL^.LOC
      END
    ELSE
      BEGIN
        NEWLOC := ARY^.PLAC[TROLL] + ARY^.FIXD[TROLL] - VBL^.LOC;
        IF VARY^.PROP[TROLL] = 0 THEN VARY^.PROP[TROLL] := 1;
        IF TOTING(BEAR) THEN
          BEGIN
            SPEAK(ARY^.RTEXT[162]);
            VARY^.PROP[CHASM] := 1;
            VARY^.PROP[TROLL] := 2;
            DROP(BEAR, NEWLOC);
            VARY^.FIXED[BEAR] := -1;
            VARY^.PROP[BEAR] := 3;
            IF VARY^.PROP[SPICES] < 0 THEN VBL^.TALLY2 := VBL^.TALLY2 + 1;
            VBL^.OLDLC2 := NEWLOC;
            HE_DIED := TRUE
          END
      END;
    EXIT(SET_NEW_LOC)
  END;  { TROLLBRIDGE }


BEGIN { SET_NEW_LOC }
  KK := ARY^.KEY[VBL^.LOC]; 
  IF KK = 0 THEN ERRORHALT(26);
  NEWLOC := VBL^.LOC;
  IF K = NULL THEN EXIT(SET_NEW_LOC);
  SKIPIT := FALSE;
  IF K = BACK THEN
    BEGIN
      SKIPIT := TRUE;
      IF FORCED(K) THEN
        K := VBL^.OLDLC2
      ELSE
        K := VBL^.OLDLOC;
      VBL^.OLDLC2 := VBL^.OLDLOC;
      VBL^.OLDLOC := VBL^.LOC;
      K2 := 0;
      IF K = VBL^.LOC THEN
        BEGIN
          SPEAK(ARY^.RTEXT[91]);
          EXIT(SET_NEW_LOC)
        END;
      OK := FALSE;
      KK := KK - 1;
      REPEAT
        KK := KK + 1;
        IF K = ARY^.TRAVEL2[KK] THEN
          BEGIN
            K := ABS(ARY^.TRAVEL[KK]);
            KK := ARY^.KEY[VBL^.LOC];
            OK := TRUE
          END
        ELSE
          BEGIN
            IF ARY^.TRAVEL2[KK] <= 300 THEN
              BEGIN
                J := ARY^.KEY[ARY^.TRAVEL2[KK]];
                IF FORCED(ARY^.TRAVEL2[KK]) AND (ARY^.TRAVEL2[J] = K) THEN
                  K2 := KK
              END;
            IF ARY^.TRAVEL[KK] < 0 THEN
              BEGIN
                KK := K2;
                IF KK = 0 THEN
                  BEGIN
                    SPEAK(ARY^.RTEXT[140]);
                    EXIT(SET_NEW_LOC)
                  END;
                K := ABS(ARY^.TRAVEL[KK]);
                KK := ARY^.KEY[VBL^.LOC];
                OK := TRUE
              END
          END
      UNTIL OK OR (ARY^.TRAVEL2[KK] = K)
    END;  { BACK }
  IF K = LOOK THEN
    BEGIN
      IF VBL^.DETAIL < 3 THEN SPEAK(ARY^.RTEXT[15]);
      VBL^.DETAIL := VBL^.DETAIL + 1;
      VBL^.WZDARK := FALSE;
      VARY^.ABB[VBL^.LOC] := 0
    END
  ELSE
    IF K = CAVE THEN
      BEGIN
        IF VBL^.LOC < 8 THEN
          SPEAK(ARY^.RTEXT[57])
        ELSE
          SPEAK(ARY^.RTEXT[58])
      END
    ELSE
      BEGIN { NOT SPECIAL }
        IF NOT SKIPIT THEN
          BEGIN
            VBL^.OLDLC2 := VBL^.OLDLOC;
            VBL^.OLDLOC := VBL^.LOC
          END;
        { TRAVEL  = VERB               }
        { TRAVEL2 = WHERE TO GO        }
        { TRAVEL3 = CONDITION (IF ANY) }
        KK := KK - 1;
        REPEAT
          KK := KK + 1;
          OK := (ABS(ARY^.TRAVEL[KK]) = 1) OR (ABS(ARY^.TRAVEL[KK]) = K)
        UNTIL OK OR (ARY^.TRAVEL[KK] < 0);
        IF NOT OK THEN
          BEGIN
            SPK := 12;
            CASE K OF
              43, 44, 45, 46, 47, 48, 49, 50, 29, 30 : SPK := 9;
              7, 36, 37 : SPK := 10;
              11, 19 : SPK := 11;
              62, 65 : SPK := 42;
              17 : SPK := 80
            END;
            IF (VBL^.VERB = FIND) OR (VBL^.VERB = INVENTORY) THEN SPK := 59;
            SPEAK(ARY^.RTEXT[SPK]);
            EXIT(SET_NEW_LOC)
          END;
        REPEAT
          NEWLOC := ARY^.TRAVEL2[KK];
          TVCOND := ARY^.TRAVEL3[KK];
          K := TVCOND MOD 100;
          IF K = 0 THEN
            BEGIN
              T1 := FALSE;
              T2 := FALSE;
              T3 := FALSE
            END
          ELSE
            BEGIN
              T1 := TOTING(K);
              T2 := AT(K);
              T3 := VARY^.PROP[K] <> (TVCOND DIV 100 - 3)
            END;
          IF ((TVCOND <= 100) AND ((TVCOND = 0) OR PERCENT(TVCOND))) OR
            ((TVCOND > 100) AND (TVCOND <= 300) AND
            (T1 OR ((TVCOND > 200) AND T2))) OR ((TVCOND > 300) AND T3) THEN
            BEGIN
              IF NEWLOC <= 300 THEN
                EXIT(SET_NEW_LOC);
              IF NEWLOC <= 500 THEN
                BEGIN
                  NEWLOC := NEWLOC - 300;
                  IF NEWLOC = 1 THEN
                    PLOVERALCOVE
                  ELSE
                    IF NEWLOC = 2 THEN
                      DROP(EMERALD, VBL^.LOC)
                    ELSE
                      IF NEWLOC = 3 THEN
                        TROLLBRIDGE
                      ELSE
                        ERRORHALT(20)
                END
              ELSE
                BEGIN
                  SPEAK(ARY^.RTEXT[NEWLOC - 500]);
                  NEWLOC := VBL^.LOC;
                  EXIT(SET_NEW_LOC)
                END
            END;
          REPEAT
            IF ARY^.TRAVEL[KK] < 0 THEN
              ERRORHALT(25);
            KK := KK + 1
          UNTIL (TVCOND <> ARY^.TRAVEL3[KK]) AND (NEWLOC <> ARY^.TRAVEL2[KK])
        UNTIL FALSE  { EXIT IS BY EXIT PROC }
      END  { NOT SPECIAL }
END;  { SET_NEW_LOC }


SEGMENT PROCEDURE DWARFSTUFF;

VAR
  LASTLOC : INTEGER;
  TBITSET, TFORCED : BOOLEAN;


  PROCEDURE PIRATESTUFF;

  BEGIN { PIRATESTUFF }
    K := 0;
    STEAL := FALSE;
    FOR J := 50 TO MAXTRS DO
      BEGIN
        IF (J = PYRAMID) AND ((VBL^.LOC = ARY^.PLAC[PYRAMID]) OR
          (VBL^.LOC = ARY^.PLAC[EMERALD])) THEN
            { NOTHING }
        ELSE
          BEGIN
            STEAL := STEAL OR TOTING(J);
            IF VARY^.PLACE[J] = VBL^.LOC THEN K := 1
          END
      END;
    IF STEAL THEN
      BEGIN
        SPEAK(ARY^.RTEXT[128]);
        IF VARY^.PLACE[MESSAGE] = 0 THEN MOVE(CHEST, VBL^.CHLOC);
        MOVE(MESSAGE, VBL^.CHLOC2);
        FOR J := 50 TO MAXTRS DO
          BEGIN
            IF (J = PYRAMID) AND ((VBL^.LOC = ARY^.PLAC[PYRAMID]) OR
              (VBL^.LOC = ARY^.PLAC[EMERALD])) THEN
                { NOTHING }
            ELSE
              BEGIN
                IF (VARY^.PLACE[J] = VBL^.LOC) AND (VARY^.FIXED[J] = 0) THEN
                  CARRY(J, VBL^.LOC);
                IF TOTING(J) THEN DROP(J, VBL^.CHLOC)
              END
          END;
        VARY^.DLOC[6] := VBL^.CHLOC;
        VARY^.ODLOC[6] := VBL^.CHLOC;
        VARY^.DSEEN[6] := FALSE
      END
    ELSE
      BEGIN
        IF (VBL^.TALLY = (VBL^.TALLY2 + 1)) AND (K = 0) AND HERE(LAMP) AND
          (VARY^.PLACE[CHEST] = 0) AND (VARY^.PROP[LAMP] = 1) THEN
          BEGIN
            SPEAK(ARY^.RTEXT[186]);
            MOVE(CHEST, VBL^.CHLOC);
            MOVE(MESSAGE, VBL^.CHLOC2);
            VARY^.DLOC[6] := VBL^.CHLOC;
            VARY^.ODLOC[6] := VBL^.CHLOC;
            VARY^.DSEEN[6] := FALSE
          END
        ELSE
          IF (VARY^.ODLOC[6] <> VARY^.DLOC[6]) AND PERCENT(20) THEN
            SPEAK(ARY^.RTEXT[127])
      END
  END;  { PIRATESTUFF }


BEGIN { DWARFSTUFF }
  IF VBL^.DFLAG = 1 THEN 
    IF (VBL^.LOC >= 15) AND PERCENT(95) THEN
      BEGIN
        VBL^.DFLAG := 2;
        FOR I := 1 TO 2 DO
          IF PERCENT(50) THEN VARY^.DLOC[1 + RAN(5)] := 0;
        FOR I := 1 TO 5 DO
          BEGIN
            IF VARY^.DLOC[I] = VBL^.LOC THEN VARY^.DLOC[I] := DALTLC;
            VARY^.ODLOC[I] := VARY^.DLOC[I]
          END;
        SPEAK(ARY^.RTEXT[3]);
        DROP(AXE, VBL^.LOC)
      END
    ELSE
  ELSE
    BEGIN
      VBL^.DTOTAL := 0;
      ATTACK := 0;
      STICK := 0;
      FOR I := 1 TO 6 DO
        IF VARY^.DLOC[I] <> 0 THEN
          BEGIN
            J := 1;
            KK := ARY^.KEY[VARY^.DLOC[I]];
            IF KK <> 0 THEN
              REPEAT
                NEWLOC := ARY^.TRAVEL2[KK];
                IF (J > 1) AND (J <= 21) THEN LASTLOC := VARY^.TK[J - 1];
                IF NEWLOC <= locsiz THEN
                  BEGIN
                    TBITSET := BITSET(NEWLOC, 3);
                    TFORCED := FORCED(NEWLOC)
                  END
                ELSE
                  BEGIN
                    TBITSET := FALSE;
                    TFORCED := FALSE
                  END;
                IF (NEWLOC > 300) OR (NEWLOC = VARY^.ODLOC[I]) OR
                  (NEWLOC < 15) OR ((J > 1) AND (NEWLOC = LASTLOC)) OR
                  (NEWLOC = VARY^.DLOC[I]) OR ((I = 6) AND TBITSET) OR
                  (ARY^.TRAVEL3[KK] = 100) OR TFORCED OR (J >= 20) THEN
                    { nothing } 
                ELSE
                  BEGIN
                    VARY^.TK[J] := NEWLOC;
                    J := J + 1
                  END;
                KK := KK + 1
              UNTIL ARY^.TRAVEL[KK - 1] < 0;
            VARY^.TK[J] := VARY^.ODLOC[I];
            IF J >= 2 THEN J := J - 1;
            J := 1 + RAN(J);
            VARY^.ODLOC[I] := VARY^.DLOC[I];
            VARY^.DLOC[I] := VARY^.TK[J];
            VARY^.DSEEN[I] := (VARY^.DSEEN[I] AND (VBL^.LOC >= 15)) OR
              (VARY^.DLOC[I] = VBL^.LOC) OR (VARY^.ODLOC[I] = VBL^.LOC);
            IF VARY^.DSEEN[I] THEN
              BEGIN
                VARY^.DLOC[I] := VBL^.LOC;
                IF I = 6 THEN
                  IF (VBL^.LOC <> VBL^.CHLOC) AND (VARY^.PROP[CHEST] < 0) THEN
                    PIRATESTUFF
                  ELSE
                ELSE
                  BEGIN
                    VBL^.DTOTAL := VBL^.DTOTAL + 1;
                    IF VARY^.ODLOC[I] = VARY^.DLOC[I] THEN
                      BEGIN
                        ATTACK := ATTACK + 1;
                        IF VBL^.KNFLOC >= 0 THEN VBL^.KNFLOC := VBL^.LOC;
                        IF RAN(1000) < (95 * (VBL^.DFLAG - 2)) THEN
                          STICK := STICK + 1
                      END
                  END
              END
          END
      END;
  IF VBL^.DTOTAL <> 0 THEN
    BEGIN
      IF VBL^.DTOTAL = 1 THEN
        SPEAK(ARY^.RTEXT[4])
      ELSE
        BEGIN
          WRITE('There are ', VBL^.DTOTAL, ' threatening ');
          WRITELN('little dwarves in the room with you.') 
        END;
      IF ATTACK <> 0 THEN
        BEGIN
          IF VBL^.DFLAG = 2 THEN VBL^.DFLAG := 3;
          IF ATTACK = 1 THEN
            BEGIN
              SPEAK(ARY^.RTEXT[5]);
              K := 52
            END
          ELSE
            BEGIN
              K := 6;
              WRITEln(ATTACK, ' of them throw knives at you.')
            END;
          IF STICK > 1 THEN
            WRITELN(STICK, ' of them get you!')
          ELSE
            SPEAK(ARY^.RTEXT[K + STICK]);
          IF STICK <> 0 THEN
            BEGIN
              VBL^.OLDLC2 := VBL^.LOC;
              HE_DIED := TRUE
            END
        END
    END
END;  { DWARFSTUFF }


segment PROCEDURE DESCRIBE_CURRENT_LOCATION;

BEGIN
  IF VBL^.LOC = 0 THEN
    BEGIN
      HE_DIED := TRUE;
      EXIT(DESCRIBE_CURRENT_LOCATION)
    END;
  KK := ARY^.STEXT[VBL^.LOC];
  IF ((VARY^.ABB[VBL^.LOC] MOD VBL^.ABBNUM) = 0) OR (KK = 0) THEN
    KK := ARY^.LTEXT[VBL^.LOC];
  IF (NOT FORCED(VBL^.LOC)) AND DARK THEN
    BEGIN
      IF VBL^.WZDARK AND PERCENT(35) THEN
        BEGIN
          HE_DIED := TRUE;
          PIT := TRUE;
          EXIT(DESCRIBE_CURRENT_LOCATION)
        END;
      KK := ARY^.RTEXT[16]
    END;
  IF TOTING(BEAR) THEN SPEAK(ARY^.RTEXT[141]);
  SPEAK(KK);
  K := 1;
  IF FORCED(VBL^.LOC) THEN
    BEGIN
      SET_NEW_LOC;
      NEWLOCSET := TRUE;
      EXIT(DESCRIBE_CURRENT_LOCATION)
    END;
  IF (VBL^.LOC = 33) AND PERCENT(25) AND NOT VBL^.CLOSING THEN
    SPEAK(ARY^.RTEXT[8]);
  if (vbl^.loc = 36) and percent(30) and (vbl^.stflag = 0) then
    begin
      speak(ary^.rtext[90]);
      vbl^.stflag := 1
    end;
  IF NOT DARK THEN
    BEGIN
      VARY^.ABB[VBL^.LOC] := VARY^.ABB[VBL^.LOC] + 1;
      I := VARY^.ATLOC[VBL^.LOC];
      WHILE I <> 0 DO
        BEGIN
          VBL^.OBJ := I;
          IF VBL^.OBJ > 100 THEN VBL^.OBJ := VBL^.OBJ - 100;
          IF (VBL^.OBJ <> STEPS) OR (NOT TOTING(NUGGET)) THEN
            BEGIN
              IF VARY^.PROP[VBL^.OBJ] < 0 THEN
                IF NOT VBL^.CLOSED THEN
                  BEGIN
                    VARY^.PROP[VBL^.OBJ] := 0;
                    IF (VBL^.OBJ = RUG) OR (VBL^.OBJ = CHAIN) THEN
                      VARY^.PROP[VBL^.OBJ] := 1;
                    VBL^.TALLY := VBL^.TALLY - 1;
                    IF (VBL^.TALLY = VBL^.TALLY2) AND (VBL^.TALLY <> 0) THEN
                      VBL^.LIMIT := MIN(35, VBL^.LIMIT)
                  END;
              IF NOT VBL^.CLOSED THEN
                BEGIN
                  KK := VARY^.PROP[VBL^.OBJ];
                  IF (VBL^.OBJ = STEPS) AND
                    (VBL^.LOC = VARY^.FIXED[STEPS]) THEN 
                    KK := 1;
                  PSPEAK(VBL^.OBJ, KK)
                END
            END;
          I := VARY^.LINK[I]
        END  { WHILE I <> 0 DO }
    END
END; { DESCRIBE_CURRENT_LOCATION }


segment PROCEDURE CHECKHINTS;


  PROCEDURE GIVEHINT;

  BEGIN
    VARY^.HINTLC[HINT] := 0;
    IF YES(ARY^.HINTS[HINT, 3], 0, 54) THEN
      BEGIN
        WRITE('I am prepared to give you a hint,  but ');
        WRITELN(' it will cost you ', ARY^.HINTS[HINT, 2], ' points.');
        VARY^.HINTED[HINT] := YES(175, ARY^.HINTS[HINT, 4], 54);
        IF VARY^.HINTED[HINT] AND (VBL^.LIMIT > 30) THEN
          VBL^.LIMIT := VBL^.LIMIT + 30 * ARY^.HINTS[HINT, 2]
      END
  END;  { GIVEHINT }


  PROCEDURE CAVEHINT;

  BEGIN
    IF (VARY^.PROP[GRATE] = 0) AND NOT HERE(KEYS) THEN
      GIVEHINT
    ELSE
      VARY^.HINTLC[HINT] := 0
  END;  { CAVEHINT }


  PROCEDURE BIRDHINT;

  BEGIN
    IF HERE(BIRD) AND TOTING(ROD) AND (VBL^.OBJ = BIRD) THEN GIVEHINT
  END;  { BIRDHINT }


  PROCEDURE SNAKEHINT;

  BEGIN
    IF HERE(SNAKE) AND NOT HERE(BIRD) THEN
      GIVEHINT
    ELSE
      VARY^.HINTLC[HINT] := 0
  END;  { SNAKEHINT } 


  PROCEDURE MAZEHINT;

  BEGIN
    IF (VARY^.ATLOC[VBL^.LOC] = 0) AND (VARY^.ATLOC[VBL^.OLDLOC] = 0) AND
      (VARY^.ATLOC[VBL^.OLDLC2] = 0) AND (VBL^.HLDING > 1) THEN
      GIVEHINT
    ELSE
      VARY^.HINTLC[HINT] := 0
  END;  { MAZEHINT }


  PROCEDURE DARKHINT;

  BEGIN
    IF (VARY^.PROP[EMERALD] <> -1) AND (VARY^.PROP[PYRAMID] = -1) THEN
      GIVEHINT
    ELSE
      VARY^.HINTLC[HINT] := 0
  END;  { DARKHINT }


  PROCEDURE WITTHINT;

  BEGIN
    GIVEHINT
  END;  { WITTHINT }


BEGIN { CHECKHINTS }
  FOR HINT := 4 TO HNTSIZ DO
    BEGIN
      IF NOT VARY^.HINTED[HINT] THEN
        BEGIN
          IF BITSET(VBL^.LOC, HINT) THEN
            VARY^.HINTLC[HINT] := VARY^.HINTLC[HINT] + 1
          ELSE
            VARY^.HINTLC[HINT] := 0;
          IF VARY^.HINTLC[HINT] >= ARY^.HINTS[HINT, 1] THEN
            CASE HINT OF
              4 : CAVEHINT;
              5 : BIRDHINT;
              6 : SNAKEHINT;
              7 : MAZEHINT;
              8 : DARKHINT;
              9 : WITTHINT
            END  { CASE OF HINT }
        END
    END
END;  { CHECKHINTS }





========================================================================================
DOCUMENT :usus Folder:VOL24:advxsubs.text
========================================================================================

{ SUBROUTINES FOR ADVENTURE } 

PROCEDURE NAMEANDPW;

VAR
  ACHR : CHAR;
  ACHAR : STRING[1];

BEGIN { NAMEANDPW }
  WRITELN('Enter your name please.');
  READLN(NAMEOFUSER);
  WRITELN('Enter your password.');
  READ(KEYBOARD, ACHR);
  if ACHR in ['a'..'z'] then ACHR := chr(ord(ACHR) - 32);
  ACHAR := ' ';
  TESTPW := '';
  WHILE NOT EOLN(KEYBOARD) DO
    BEGIN
      ACHAR[1] := ACHR;
      IF ACHR = CHR(8) THEN
        IF LENGTH(TESTPW) > 0 THEN
          BEGIN
            DELETE(TESTPW, LENGTH(TESTPW), 1);
            WRITE(CHR(8), ' ', CHR(8))
          END
        ELSE
      ELSE
        BEGIN
          WRITE('X');
          TESTPW := CONCAT(TESTPW, ACHAR)
        END;
      READ(KEYBOARD, ACHR);
      if ACHR in ['a'..'z'] then ACHR := chr(ord(ACHR) - 32)
    END;
  NAMEOFUSER := CONCAT(NAMEOFUSER, '.AVSV')
END;  { NAMEANDPW }


FUNCTION GETSCORE{SCORECMD : BOOLEAN) : INTEGER};

VAR
  I, K, SCORE : INTEGER;

BEGIN { GETSCORE }
  MAXSCORE := 0;
  SCORE := 0;
  FOR I := 50 TO MAXTRS DO
    IF ARY^.PTEXT[I] <> 0 THEN
      BEGIN
        IF I = CHEST THEN
          K := 20
        ELSE
          IF I > CHEST THEN
            K := 16
          ELSE
            K := 12;
        IF (VARY^.PROP[I] >= 0) THEN SCORE := SCORE + 2;
        IF (VARY^.PLACE[I] = 3) AND (VARY^.PROP[I] = 0) THEN
          SCORE := SCORE + K - 2;
        MAXSCORE := MAXSCORE + K
      END;
  SCORE := SCORE + (MAXDIE - VBL^.NUMDIE) * 10;
  MAXSCORE := MAXSCORE + MAXDIE * 10;
  IF VBL^.DFLAG <> 0 THEN SCORE := SCORE + 25;
  MAXSCORE := MAXSCORE + 25;
  IF NOT (GAVEUP OR SCORECMD) THEN SCORE := SCORE + 4;
  MAXSCORE := MAXSCORE + 4;
  IF VBL^.CLOSING THEN SCORE := SCORE + 25;
  MAXSCORE := MAXSCORE + 25;
  CASE BONUS OF
    0 : SCORE := SCORE + 10;
    135 : SCORE := SCORE + 25;
    134 : SCORE := SCORE + 30;
    133 : SCORE := SCORE + 45
  END;
  MAXSCORE := MAXSCORE + 45;
  IF VARY^.PLACE[MAGAZINE] = 108 THEN SCORE := SCORE + 1;
  MAXSCORE := MAXSCORE + 1;
  SCORE := SCORE + 2;
  MAXSCORE := MAXSCORE + 2;
  FOR I := 1 TO HNTSIZ DO
    IF VARY^.HINTED[I] THEN SCORE := SCORE - ARY^.HINTS[I, 2];
  GETSCORE := SCORE
END;  { GETSCORE }


FUNCTION TOTING{OBJECT : INTEGER) : BOOLEAN};

BEGIN
  TOTING := (VARY^.PLACE[OBJECT] = -1)
END;  { TOTING } 


FUNCTION AT{OBJECT : INTEGER) : BOOLEAN};

BEGIN
  AT := (VARY^.PLACE[OBJECT] = VBL^.LOC) OR (VARY^.FIXED[OBJECT] = VBL^.LOC)
END;  { AT }


FUNCTION MIN{I, J : INTEGER) : INTEGER};

BEGIN { MIN }
  IF J < I THEN
    MIN := J
  ELSE
    MIN := I
END;  { MIN }


FUNCTION MAX{I, J : INTEGER) : INTEGER};

BEGIN { MAX }
  IF J > I THEN
    MAX := J
  ELSE
    MAX := I
END;  { MAX }


FUNCTION RAN{NUM : INTEGER) : INTEGER};

VAR
  TEMP : INTEGER;
  TEMP2 : REAL;

BEGIN { RAN }
  TEMP := SEED * 899;
  IF TEMP < 0 THEN TEMP := TEMP + 32767 + 1;
  TEMP2 := (TEMP - 1) / 32767.0;
  RAN := TRUNC(TEMP2 * NUM);
  SEED := TEMP
END;  { RAN }


FUNCTION PERCENT{I : INTEGER) : BOOLEAN};

BEGIN
  PERCENT := (RAN(100) < I)
END;  { PERCENT }


FUNCTION HERE{OBJECT : INTEGER) : BOOLEAN};

BEGIN
  HERE := (VARY^.PLACE[OBJECT] = VBL^.LOC) OR TOTING(OBJECT)
END;  { HERE }


FUNCTION DARK {: BOOLEAN};

BEGIN
  DARK := ((VARY^.COND[VBL^.LOC] MOD 2) = 0) AND ((VARY^.PROP[LAMP] = 0) OR
    NOT HERE(LAMP))
END;  { DARK }


FUNCTION FORCED{LOC : INTEGER) : BOOLEAN};

BEGIN
  FORCED := VARY^.COND[LOC] = 2
END;  { FORCED }


FUNCTION BITSET{I, J : INTEGER) : BOOLEAN};

VAR
  K, TEMP : INTEGER;

BEGIN { BITSET }
  TEMP := VARY^.COND[I];
  FOR K := 1 TO J DO TEMP := TEMP DIV 2;
  BITSET := (TEMP MOD 2) = 1
END;  { BITSET }


FUNCTION LIQ2{PBOTL : INTEGER) : INTEGER};

VAR
  TEMP : INTEGER;

BEGIN { LIQ2 }
  TEMP := PBOTL DIV 2;
  LIQ2 := ((1 - PBOTL) * WATER + TEMP * (WATER + OIL))
END;  { LIQ2 }


FUNCTION LIQ {: INTEGER};

BEGIN
  LIQ := LIQ2(MAX(VARY^.PROP[BOTTLE], -1 - VARY^.PROP[BOTTLE]))
END;  { LIQ }


FUNCTION LIQLOC{LOC : INTEGER) : INTEGER};

VAR
  TEMP1, TEMP2 : INTEGER;

BEGIN { LIQLOC }
  TEMP1 := (VARY^.COND[LOC] DIV 2) * 2;  { EVEN COND ONLY }
  TEMP2 := VARY^.COND[LOC] DIV 4;
  LIQLOC := LIQ2((TEMP1 MOD 8 - 5) * (TEMP2 MOD 2) + 1)
END;  { LIQLOC }


FUNCTION VOCAB{WORD : STRING;WHAT : INTEGER) : INTEGER};

VAR
  I, J, K : INTEGER;

BEGIN { VOCAB }
  I := 1;
  J := tabsiz;
  REPEAT
    K := (I + J) DIV 2;
    IF ARY^.ATAB[K] <= WORD THEN I := K + 1; 
    IF ARY^.ATAB[K] >= WORD THEN J := K - 1
  UNTIL I > J;
  IF K > 1 THEN
    IF ARY^.ATAB[K - 1] = WORD THEN K := K - 1;  { FIND FIRST WORD }
  VOCAB := -1;
  IF ARY^.ATAB[K] = WORD THEN VOCAB := ARY^.KTAB[K];
  IF WHAT >= 0 THEN
    BEGIN
      WHILE (ARY^.ATAB[K] = WORD) AND (WHAT <> (ARY^.KTAB[K] DIV 1000)) DO
        K := K + 1;
      IF ARY^.ATAB[K] = WORD THEN VOCAB := ARY^.KTAB[K] MOD 1000
    END
END;  { VOCAB }


PROCEDURE CARRY{OBJECT, WHERE : INTEGER};

VAR
  TEMP : INTEGER;


  PROCEDURE LINKUP;

  BEGIN { LINKUP }
    TEMP := VARY^.ATLOC[WHERE];
    WHILE (VARY^.LINK[TEMP] <> OBJECT) DO TEMP := VARY^.LINK[TEMP];
    VARY^.LINK[TEMP] := VARY^.LINK[OBJECT]
  END;  { LINKUP }


BEGIN { CARRY }
  IF OBJECT <= 100 THEN
    IF VARY^.PLACE[OBJECT] <> -1 THEN
      BEGIN
        VARY^.PLACE[OBJECT] := -1;
        VBL^.HLDING := VBL^.HLDING + 1;
        IF VARY^.ATLOC[WHERE] = OBJECT THEN
          VARY^.ATLOC[WHERE] := VARY^.LINK[OBJECT]
        ELSE
          LINKUP
      END
    ELSE
  ELSE
    IF VARY^.ATLOC[WHERE] = OBJECT THEN
      VARY^.ATLOC[WHERE] := VARY^.LINK[OBJECT] 
    ELSE
      LINKUP
END;  { CARRY }


PROCEDURE DROP{OBJECT, WHERE : INTEGER};

BEGIN
  IF OBJECT > 100 THEN
    VARY^.FIXED[OBJECT - 100] := WHERE
  ELSE
    BEGIN
      IF VARY^.PLACE[OBJECT] = -1 THEN VBL^.HLDING := VBL^.HLDING - 1;
      VARY^.PLACE[OBJECT] := WHERE
    END;
  IF WHERE > 0 THEN
    BEGIN
      VARY^.LINK[OBJECT] := VARY^.ATLOC[WHERE];
      VARY^.ATLOC[WHERE] := OBJECT
    END
END;  { DROP }


PROCEDURE MOVE{OBJECT, WHERE : INTEGER};

VAR
  FROM : INTEGER;

BEGIN { MOVE }
  IF OBJECT > 100 THEN
    FROM := VARY^.FIXED[OBJECT - 100]
  ELSE
    FROM := VARY^.PLACE[OBJECT];
  IF (FROM > 0) AND (FROM <= 300) THEN CARRY(OBJECT, FROM);
  DROP(OBJECT, WHERE)
END;  { MOVE }


PROCEDURE JUGGLE{OBJECT : INTEGER};

BEGIN
  MOVE(OBJECT, VARY^.PLACE[OBJECT]);
  MOVE(OBJECT + 100, VARY^.FIXED[OBJECT])
END;  { JUGGLE }


PROCEDURE DESTROY{OBJECT : INTEGER};

BEGIN
  MOVE(OBJECT, 0)
END;  { DESTROY }


FUNCTION PUT{OBJECT, WHERE, PVAL : INTEGER) : INTEGER};

BEGIN
  MOVE(OBJECT, WHERE);
  PUT := -1 - PVAL
END;  { PUT }


PROCEDURE SPEAK{MSG : INTEGER};

VAR
  I : INTEGER;
  MTEMP : STRING[6];
  MTEMP2 : STRING;
  MTEXT : STRING[255];


  PROCEDURE HOLDUP;

  BEGIN { HOLDUP }
    LINE := LINE + 1;
    IF LINE >= (TERMHIGHT - 1) THEN
      BEGIN
        LINE := 1;
        WRITE(CHR(7), '         Press <RETURN> to continue.');
        READLN
      END
  END;  { HOLDUP }


BEGIN { SPEAK }
  MTEMP := '      ';
  MTEXT := '';
  IF MSG > 0 THEN
    BEGIN
      SEEK(MSGFILE, MSG);
      REPEAT
        GET(MSGFILE);
        FOR I := 1 TO 6 DO MTEMP[I] := MSGFILE^[I];
        IF ORD(MTEMP[1]) > 128 THEN MTEMP[1] := CHR(ORD(MTEMP[1]) - 128);
        IF ORD(MTEMP[2]) > 128 THEN MTEMP[2] := CHR(ORD(MTEMP[2]) - 128);
        MTEXT := CONCAT(MTEXT, MTEMP);
        IF LENGTH(MTEXT) > TERMWIDTH THEN
          BEGIN
            I := TERMWIDTH;
            WHILE MTEXT[I] <> ' ' DO I := I - 1;
            MTEMP2 := COPY(MTEXT, 1, I - 1);
            DELETE(MTEXT, 1, I);
            WRITELN(MTEMP2);
            HOLDUP
          END
      UNTIL ORD(MSGFILE^[1]) > 128;
      IF MTEXT <> '      ' THEN  { DONT PRINT DUMMY MSG }
        BEGIN
          WRITELN(MTEXT);
          HOLDUP
        END
    END
END;  { SPEAK }


PROCEDURE PSPEAK{MSG, SKIP : INTEGER};

VAR
  I, M : INTEGER;

BEGIN { PSPEAK }
  M := ARY^.PTEXT[MSG];
  SEEK(MSGFILE, M);
  FOR I := 0 TO SKIP DO
    BEGIN
      REPEAT
        GET(MSGFILE);
        M := M + 1
      UNTIL ORD(MSGFILE^[1]) > 128
    END;
  GET(MSGFILE);  { INSURE GET BETWEEN SEEKS }
  SPEAK(M)
END;  { PSPEAK }


FUNCTION YES{MSG, SPKYES, SPKNO : INTEGER) : BOOLEAN};

VAR
  i : integer;
  INLINE : STRING;

BEGIN { YES }
  YEA := FALSE;
  SKIPIT := FALSE;
  IF MSG <> 0 THEN SPEAK(ARY^.RTEXT[MSG]);
  LINE := 1;
  REPEAT
    IF SKIPIT THEN WRITELN('Please answer the question with yes or no.');
    SKIPIT := TRUE;
    READLN(INLINE);
    for i := 1 to length(INLINE) do
      if INLINE[i] in ['a'..'z'] then INLINE[i] := chr(ord(INLINE[i]) - 32)
  UNTIL (INLINE = 'YES') OR (INLINE = 'Y') OR (INLINE = 'NO') OR
    (INLINE = 'N');
  YEA := (INLINE = 'YES') OR (INLINE = 'Y');
  IF YEA THEN SPKNO := SPKYES;
  IF SPKNO <> 0 THEN SPEAK(ARY^.RTEXT[SPKNO]);
  YES := YEA
END;  { YES }


PROCEDURE ERRORHALT{I : INTEGER};

BEGIN 
  WRITELN;
  WRITELN('Fatal error # ', I, ' ---- Bye!');
  HALT
END;  { ERRORHALT }


PROCEDURE TESTCLOSE;

VAR
  I : INTEGER;

BEGIN { TESTCLOSE }
  IF (NEWLOC IN [1..8]) AND VBL^.CLOSING THEN
    BEGIN
      SPEAK(ARY^.RTEXT[130]);
      NEWLOC := VBL^.LOC;
      IF NOT VBL^.PANIC THEN VBL^.CLOCK2 := 15;
      VBL^.PANIC := TRUE
    END;
  IF (NEWLOC <> VBL^.LOC) AND NOT FORCED(VBL^.LOC)
    AND NOT BITSET(VBL^.LOC, 3) THEN
    FOR I := 1 TO 5 DO
      IF (VARY^.ODLOC[I] = NEWLOC) AND VARY^.DSEEN[I] THEN
        BEGIN
          NEWLOC := VBL^.LOC;
          SPEAK(ARY^.RTEXT[2]);
          I := 5
        END
END;  { TESTCLOSE }




========================================================================================
DOCUMENT :usus Folder:VOL24:advxverb.text
========================================================================================

PROCEDURE LEAVE; 

BEGIN { LEAVE }
  SKIPDWARF := TRUE;
  SKIPDESCRIBE := TRUE;
  IF SPK <> 0 THEN SPEAK(ARY^.RTEXT[SPK]);
  EXIT(DOWHATHESAYS)
END;  { LEAVE }


PROCEDURE MISCXIT;

BEGIN
  IF (VBL^.OBJ= COINS) AND HERE(VEND_MACHINE) THEN
    BEGIN
      DESTROY(COINS);
      DROP(BATTERY, VBL^.LOC);
      PSPEAK(BATTERY, 0);
      SPK := 0;
      LEAVE
    END
  ELSE
    IF (VBL^.OBJ = BIRD) AND AT(DRAGON) AND (VARY^.PROP[DRAGON] = 0) THEN
      BEGIN
        SPK := 154;
        DESTROY(BIRD);
        VARY^.PROP[BIRD] := 0;
        IF VARY^.PLACE[SNAKE] = ARY^.PLAC[SNAKE] THEN
          VBL^.TALLY2 := VBL^.TALLY2 + 1;
        LEAVE
      END
    ELSE
      IF (VBL^.OBJ = BEAR) AND AT(TROLL) THEN
        BEGIN
          SPK := 163;
          MOVE(TROLL, 0);
          MOVE(TROLL + 100, 0);
          MOVE(TROLL2, ARY^.PLAC[TROLL]);
          MOVE(TROLL2 + 100, ARY^.FIXD[TROLL]);
          JUGGLE(CHASM);
          VARY^.PROP[TROLL] := 2
        END
      ELSE
        IF (VBL^.OBJ = VASE) AND (VBL^.LOC <> ARY^.PLAC[PILLOW]) THEN
          BEGIN
            SPK := 0;
            IF AT(PILLOW) THEN
              VARY^.PROP[VASE] := 0
            ELSE
              BEGIN
                VARY^.PROP[VASE] := 2;
                VARY^.FIXED[VASE] := -1
              END;
            PSPEAK(VASE, VARY^.PROP[VASE] + 1) 
          END
        ELSE
          SPK := 54
END;  { MISCXIT }


PROCEDURE ASKWHATTODOITTO;

BEGIN
  WRITELN(WD1, WD1X, ' what?');
  VBL^.OBJ := 0;
  RESTART := 1;
  EXIT(DOWHATHESAYS)
END;  { ASKWHATTODOITTO }


PROCEDURE FILL_IT;

BEGIN
  IF VBL^.OBJ = VASE THEN
    BEGIN
      SPK := 29;
      IF LIQLOC(VBL^.LOC) = 0 THEN SPK := 144;
      IF (LIQLOC(VBL^.LOC) = 0) OR TOTING(VASE) THEN LEAVE;
      SPEAK(ARY^.RTEXT[145]);
      VARY^.PROP[VASE] := 2;
      VARY^.FIXED[VASE] := -1;
      MISCXIT;
      LEAVE
    END;
  IF (VBL^.OBJ <> 0) AND (VBL^.OBJ <> BOTTLE) THEN LEAVE;
  IF (VBL^.OBJ = 0) AND NOT HERE(BOTTLE) THEN ASKWHATTODOITTO;
  SPK := 107;
  IF LIQLOC(VBL^.LOC) = 0 THEN SPK := 106;
  IF LIQ <> 0 THEN SPK := 105;
  IF SPK <> 107 THEN LEAVE;
  VARY^.PROP[BOTTLE] := ((VARY^.COND[VBL^.LOC] MOD 4) DIV 2) * 2;
  K := LIQ;
  IF TOTING(BOTTLE) THEN VARY^.PLACE[K] := -1;
  IF K = OIL THEN SPK := 108;
  LEAVE
END;  { FILL_IT }


PROCEDURE CARRY_IT;

BEGIN
  IF TOTING(VBL^.OBJ) THEN LEAVE;
  SPK := 25;
  IF (VBL^.OBJ = PLANT) AND (VARY^.PROP[PLANT] <= 0) THEN SPK := 115; 
  IF (VBL^.OBJ = BEAR) AND (VARY^.PROP[BEAR] = 1) THEN SPK := 169;
  IF (VBL^.OBJ = CHAIN) AND (VARY^.PROP[BEAR] <> 0) THEN SPK := 170;
  IF VARY^.FIXED[VBL^.OBJ] <> 0 THEN LEAVE;
  IF (VBL^.OBJ = WATER) OR (VBL^.OBJ = OIL) THEN
    BEGIN
      IF HERE(BOTTLE) AND (LIQ = VBL^.OBJ) THEN
        VBL^.OBJ := BOTTLE
      ELSE
        BEGIN
          VBL^.OBJ := BOTTLE;
          IF VARY^.PROP[BOTTLE] <> 1 THEN
            SPK := 105
          ELSE
            IF TOTING(BOTTLE) THEN
              FILL_IT
            ELSE
              SPK := 104;
          LEAVE
        END
    END;
  IF VBL^.HLDING > MAXHLD THEN
    BEGIN
      SPK := 92;
      LEAVE
    END;
  IF (VBL^.OBJ = BIRD) AND (VARY^.PROP[BIRD] = 0) THEN
    BEGIN
      IF TOTING(ROD) THEN
        BEGIN
          SPK := 26;
          LEAVE
        END;
      IF NOT TOTING(CAGE) THEN
        BEGIN
          SPK := 27;
          LEAVE
        END;
      VARY^.PROP[BIRD] := 1
    END;
  IF ((VBL^.OBJ = BIRD) OR (VBL^.OBJ = CAGE)) AND (VARY^.PROP[BIRD] <> 0) THEN
    CARRY(BIRD + CAGE - VBL^.OBJ, VBL^.LOC);
  CARRY(VBL^.OBJ, VBL^.LOC);
  K := LIQ;
  IF (VBL^.OBJ = BOTTLE) AND (K <> 0) THEN VARY^.PLACE[K] := -1;
  SPK := 54;
  LEAVE
END;  { CARRY_IT }


PROCEDURE DISTURBDWARVES;

BEGIN { DISTURBDWARVES }
  SPEAK(ARY^.RTEXT[136]);
  ALLDONE := TRUE;
  EXIT(DOWHATHESAYS)
END;  { DISTURBDWARVES }


PROCEDURE DROP_IT;

BEGIN
  IF TOTING(ROD2) AND (VBL^.OBJ = ROD) AND NOT TOTING(ROD) THEN
    VBL^.OBJ := ROD2;
  IF NOT TOTING(VBL^.OBJ) THEN LEAVE;
  IF (VBL^.OBJ = BIRD) AND HERE(SNAKE) THEN
    BEGIN
      SPK := 30;
      IF VBL^.CLOSED THEN DISTURBDWARVES;
      DESTROY(SNAKE);
      VARY^.PROP[SNAKE] := 1
    END
  ELSE
    MISCXIT;
  K := LIQ;
  IF K = VBL^.OBJ THEN VBL^.OBJ := BOTTLE;
  IF (VBL^.OBJ = BOTTLE) AND (K <> 0) THEN VARY^.PLACE[K] := 0;
  IF (VBL^.OBJ = CAGE) AND (VARY^.PROP[BIRD] <> 0) THEN DROP(BIRD, VBL^.LOC);
  IF VBL^.OBJ = BIRD THEN VARY^.PROP[BIRD] := 0;
  DROP(VBL^.OBJ, VBL^.LOC);
  LEAVE
END;  { DROP IT }


PROCEDURE SAY_IT;

VAR
  I : INTEGER;

BEGIN { SAY_IT }
  IF WD2 = '' THEN
    BEGIN
      WD2 := WD1;
      WD2X := WD1X
    END;
  I := VOCAB(WD2, -1);
  IF (I = 62) OR (I = 65) OR (I = 71) OR (I = 2025) THEN
    RESTART := 1
  ELSE
    WRITELN('Okay, "', WD2, WD2X, '"')
END;  { SAY_IT }


PROCEDURE L_U_IT;

BEGIN
  IF (VBL^.OBJ = CLAM) OR (VBL^.OBJ = OYSTER) THEN
    BEGIN
      IF VBL^.OBJ = OYSTER THEN
        K := 1
      ELSE
        K := 0;
      SPK := 124 + K;
      IF TOTING(VBL^.OBJ) THEN SPK := 120 + K;
      IF NOT TOTING(TRIDENT) THEN SPK := 122 + K;
      IF VBL^.VERB = LOCK THEN SPK := 61;
      IF SPK = 124 THEN
        BEGIN
          DESTROY(CLAM);
          DROP(OYSTER, VBL^.LOC);
          DROP(PEARL, 105)
        END;
      LEAVE
    END;
  if (vbl^.obj = door) and at(door2) then vbl^.obj := door2;
  IF VBL^.OBJ = DOOR THEN SPK := 111;
  IF (VBL^.OBJ = DOOR) AND (VARY^.PROP[DOOR] = 1) THEN SPK := 54;
  IF VBL^.OBJ = CAGE THEN SPK := 32;
  IF VBL^.OBJ = KEYS THEN SPK := 55;
  IF (VBL^.OBJ = GRATE) OR (VBL^.OBJ = CHAIN) or (vbl^.obj = door2) THEN
    SPK := 31;
  IF (SPK = 31) AND HERE(KEYS) THEN
    BEGIN { KEYS HERE }
      IF VBL^.OBJ = CHAIN THEN
        BEGIN
          IF VBL^.VERB = LOCK THEN
            BEGIN
              IF VARY^.PROP[CHAIN] <> 0 THEN
                SPK := 34 
              ELSE
                IF VBL^.LOC <> ARY^.PLAC[CHAIN] THEN
                  SPK := 173
                ELSE
                  BEGIN
                    SPK := 172;
                    VARY^.PROP[CHAIN] := 2;
                    IF TOTING(CHAIN) THEN DROP(CHAIN, VBL^.LOC);
                    VARY^.FIXED[CHAIN] := -1
                  END
            END
          ELSE
            BEGIN
              IF VARY^.PROP[BEAR] = 0 THEN
                SPK := 41
              ELSE
                IF VARY^.PROP[CHAIN] = 0 THEN
                  SPK := 37
                ELSE
                  BEGIN
                    SPK := 171;
                    VARY^.PROP[CHAIN] := 0;
                    VARY^.FIXED[CHAIN] := 0;
                    IF VARY^.PROP[BEAR] <> 3 THEN VARY^.PROP[BEAR] := 2;
                    VARY^.FIXED[BEAR] := 2 - VARY^.PROP[BEAR]
                  END
            END
        END
      ELSE
        if vbl^.obj = door2 then
          begin
            spk := 202 + vary^.prop[door2];
            if vbl^.verb = lock then
              vary^.prop[door2] := 0
            else
              vary^.prop[door2] := 1;
            spk := spk + 2 * vary^.prop[door2]
          end
        else
          IF VBL^.CLOSING THEN
            BEGIN
              SPK := 130;
              IF NOT VBL^.PANIC THEN VBL^.CLOCK2 := 15;
              VBL^.PANIC := TRUE
            END
          ELSE
            BEGIN
              SPK := 34 + VARY^.PROP[GRATE];
              IF VBL^.VERB = LOCK THEN
                VARY^.PROP[GRATE] := 0
              ELSE
                BEGIN
                  SPK := SPK + 2;
                  VARY^.PROP[GRATE] := 1
                END
            END
    END;
  LEAVE
END;  { L_U_IT }


PROCEDURE SAY_OK;

BEGIN
  SPK := 54;
  LEAVE
END;  { SAY_OK }


PROCEDURE LAMP_ON;

BEGIN
  IF HERE(LAMP) THEN
    IF VBL^.LIMIT < 0 THEN
      SPK := 184
    ELSE
      BEGIN
        VARY^.PROP[LAMP] := 1;
        SPK := 0;
        SPEAK(ARY^.RTEXT[39]);
        SKIPDWARF := TRUE;
        IF VBL^.WZDARK THEN EXIT(DOWHATHESAYS)
      END;
  LEAVE
END;  { LAMP_ON }


PROCEDURE LAMP_OFF;

BEGIN
  IF HERE(LAMP) THEN
    BEGIN
      VARY^.PROP[LAMP] := 0;
      SPEAK(ARY^.RTEXT[40]);
      IF DARK THEN
        SPK := 16
      ELSE
        SPK := 0
    END;
  LEAVE
END;  { LAMP_OFF }


PROCEDURE WAVE_IT;

BEGIN { WAVE_IT }
  IF (NOT TOTING(VBL^.OBJ)) AND ((VBL^.OBJ <> ROD) OR NOT TOTING(ROD2)) THEN
    SPK := 29;
  IF (VBL^.OBJ = ROD) AND AT(FISSURE) AND TOTING(VBL^.OBJ) AND
    NOT VBL^.CLOSING THEN
    BEGIN
      SPK := 0;
      VARY^.PROP[FISSURE] := 1 - VARY^.PROP[FISSURE];
      PSPEAK(FISSURE, 2 - VARY^.PROP[FISSURE])
    END;
  LEAVE
END;  { WAVE_IT }


PROCEDURE KILL_IT;

VAR
  I, J : INTEGER;

BEGIN { KILL_IT }
  I := 0;
  FOR J := 1 TO 5 DO
    IF (VARY^.DLOC[J] = VBL^.LOC) AND (VBL^.DFLAG >= 2) THEN
      BEGIN
        I := J;
        J := 5
      END;
  IF VBL^.OBJ = 0 THEN
    BEGIN
      IF I <> 0 THEN VBL^.OBJ := DWARF;
      IF HERE(SNAKE) THEN VBL^.OBJ := VBL^.OBJ * 100 + SNAKE;
      if vbl^.loc = 149 then
        if vary^.prop[wizard] = 0 then vbl^.obj := 100 * vbl^.obj + wizard;
      IF AT(DRAGON) AND (VARY^.PROP[DRAGON] = 0) THEN
        VBL^.OBJ := VBL^.OBJ * 100 + DRAGON;
      IF AT(TROLL) THEN VBL^.OBJ := VBL^.OBJ * 100 + TROLL;
      IF HERE(BEAR) AND (VARY^.PROP[BEAR] = 0) THEN
        VBL^.OBJ := VBL^.OBJ * 100 + BEAR;
      IF VBL^.OBJ > 100 THEN ASKWHATTODOITTO;
      IF VBL^.OBJ = 0 THEN
        BEGIN
          IF HERE(BIRD) AND (VBL^.VERB <> THROW) THEN VBL^.OBJ := BIRD;
          IF HERE(CLAM) OR HERE(OYSTER) THEN VBL^.OBJ := VBL^.OBJ * 100 + CLAM;
          IF VBL^.OBJ > 100 THEN ASKWHATTODOITTO
        END
    END;
  IF VBL^.OBJ = BIRD THEN
    BEGIN
      SPK := 137;
      IF VBL^.CLOSED THEN LEAVE;
      DESTROY(BIRD);
      VARY^.PROP[BIRD] := 0;
      IF VARY^.PLACE[SNAKE] = ARY^.PLAC[SNAKE] THEN
        VBL^.TALLY2 := VBL^.TALLY2 + 1;
      SPK := 45
    END; 
  IF VBL^.OBJ = 0 THEN SPK := 44;
  IF (VBL^.OBJ = CLAM) OR (VBL^.OBJ = OYSTER) THEN SPK := 150;
  IF VBL^.OBJ = SNAKE THEN SPK := 46;
  IF VBL^.OBJ = DWARF THEN SPK := 49;
  IF (VBL^.OBJ = DWARF) AND VBL^.CLOSED THEN DISTURBDWARVES;
  IF VBL^.OBJ = DRAGON THEN SPK := 167;
  if (vbl^.obj = wizard) and (vary^.prop[wizard] = 0) then spk := 209;
  IF VBL^.OBJ = TROLL THEN SPK := 157;
  IF VBL^.OBJ = BEAR THEN SPK := 165 + (VARY^.PROP[BEAR] + 1) DIV 2;
  IF (VBL^.OBJ <> DRAGON) OR (VARY^.PROP[DRAGON] <> 0) THEN LEAVE;
  VBL^.VERB := 0;
  VBL^.OBJ := 0;
  IF NOT YES(49, 0, 0) THEN
    BEGIN
      RESTART := 2;
      SPK := 0;
      LEAVE
    END;
  PSPEAK(DRAGON, 1);
  VARY^.PROP[DRAGON] := 2;
  VARY^.PROP[RUG] := 0;
  K := (ARY^.PLAC[DRAGON] + VARY^.FIXED[DRAGON]) DIV 2;
  MOVE(DRAGON + 100, -1);
  MOVE(RUG + 100, 0);
  MOVE(DRAGON, K);
  MOVE(RUG, K);
  FOR I := 1 TO 100 DO
    IF (VARY^.PLACE[I] = ARY^.PLAC[DRAGON]) OR
      (VARY^.PLACE[I] = ARY^.FIXD[DRAGON]) THEN MOVE(I, K);
  VBL^.LOC := K;
  K := NULL;
  SET_NEW_LOC;
  EXIT(DOWHATHESAYS)
END;  { KILL_IT }


PROCEDURE POUR_IT;

BEGIN
  IF (VBL^.OBJ = BOTTLE) OR (VBL^.OBJ = 0) THEN VBL^.OBJ := LIQ;
  IF VBL^.OBJ = 0 THEN ASKWHATTODOITTO;
  IF NOT TOTING(VBL^.OBJ) THEN LEAVE;
  SPK := 78;
  IF (VBL^.OBJ <> WATER) AND (VBL^.OBJ <> OIL) THEN LEAVE;
  VARY^.PROP[BOTTLE] := 1;
  VARY^.PLACE[VBL^.OBJ] := 0;
  SPK := 77;
  IF NOT (AT(PLANT) OR AT(DOOR)) THEN LEAVE;
  IF AT(DOOR) THEN
    BEGIN
      IF VBL^.OBJ = OIL THEN
        BEGIN
          SPK := 114;
          VARY^.PROP[DOOR] := 1
        END
      ELSE
        BEGIN
          SPK := 113;
          VARY^.PROP[DOOR] := 0
        END;
      LEAVE
    END;
  SPK := 112;
  IF VBL^.OBJ <> WATER THEN LEAVE;
  PSPEAK(PLANT, VARY^.PROP[PLANT] + 1);
  VARY^.PROP[PLANT] := (VARY^.PROP[PLANT] + 2) MOD 6;
  VARY^.PROP[PLANT2] := VARY^.PROP[PLANT] DIV 2;
  K := NULL;
  SET_NEW_LOC;
  EXIT(DOWHATHESAYS)
END;  { POUR_IT }


PROCEDURE EAT_IT;

BEGIN
  IF VBL^.OBJ = FOOD THEN
    BEGIN
      DESTROY(FOOD);
      SPK := 72;
      LEAVE
    END;
  IF (VBL^.OBJ = BIRD) OR (VBL^.OBJ = SNAKE) OR (VBL^.OBJ = CLAM) OR
    (VBL^.OBJ = OYSTER) OR (VBL^.OBJ = DWARF) OR (VBL^.OBJ = DRAGON) OR
    ((vbl^.obj = wizard) and (vary^.prop[wizard] = 0)) or
    (VBL^.OBJ = TROLL) OR (VBL^.OBJ = BEAR) THEN SPK := 71;
  LEAVE
END;  { EAT_IT }


PROCEDURE DRINK_IT;

VAR
  I : INTEGER;

BEGIN { DRINK_IT }
  IF (VBL^.OBJ = 0) AND (LIQLOC(VBL^.LOC) <> WATER) AND ((LIQ <> WATER) OR
    NOT HERE(BOTTLE)) THEN ASKWHATTODOITTO;
  IF (VBL^.OBJ <> 0) AND (VBL^.OBJ <> WATER) THEN SPK := 110;
  IF (SPK = 110) OR (LIQ <> WATER) OR NOT HERE(BOTTLE) THEN LEAVE;
  VARY^.PROP[BOTTLE] := 1;
  VARY^.PLACE[WATER] := 0;
  SPK := 74;
  LEAVE
END;  { DRINK_IT }


PROCEDURE RUB_IT;

BEGIN
  IF VBL^.OBJ <> LAMP THEN SPK := 76;
  if (vbl^.obj = wizard) and (vary^.prop[wizard] = 0) then spk := 212;
  LEAVE
END;  { RUB_IT }


PROCEDURE FEED_IT;

BEGIN
  IF VBL^.OBJ = BIRD THEN
    BEGIN
      SPK := 100;
      LEAVE
    END;
  IF (VBL^.OBJ = SNAKE) OR (VBL^.OBJ = DRAGON) OR (VBL^.OBJ = TROLL) THEN
    BEGIN
      spk := 102;
      IF (VBL^.OBJ = DRAGON) AND (VARY^.PROP[DRAGON] <> 0) THEN SPK := 110; 
      IF VBL^.OBJ = TROLL THEN SPK := 182;
      IF (VBL^.OBJ <> SNAKE) OR VBL^.CLOSED OR NOT HERE(BIRD) THEN LEAVE;
      SPK := 101;
      DESTROY(BIRD);
      VARY^.PROP[BIRD] := 0;
      VBL^.TALLY2 := VBL^.TALLY2 + 1;
      LEAVE
    END;
  IF VBL^.OBJ = DWARF THEN
    BEGIN
      IF NOT HERE(FOOD) THEN LEAVE;
      SPK := 103;
      VBL^.DFLAG := VBL^.DFLAG + 1;
      LEAVE
    END;
  IF VBL^.OBJ = BEAR THEN
    BEGIN
      IF VARY^.PROP[BEAR] = 0 THEN SPK := 102;
      IF VARY^.PROP[BEAR] = 3 THEN SPK := 110;
      IF NOT HERE(FOOD) THEN LEAVE;
      DESTROY(FOOD);
      VARY^.PROP[BEAR] := 1;
      VARY^.FIXED[AXE] := 0;
      VARY^.PROP[AXE] := 0;
      SPK := 168;
      LEAVE
    END;
  if (vbl^.loc = 149) and (vary^.prop[wizard] <> 1) then
    begin
      spk := 208;
      leave
    end;
  SPK := 14;
  LEAVE
END;  { FEED_IT }


PROCEDURE TOSS_IT;

VAR
  I : INTEGER;


  PROCEDURE TOSS_IT_AWAY;

  BEGIN
    SPEAK(ARY^.RTEXT[SPK]);
    DROP(AXE, VBL^.LOC);
    K := NULL;
    SET_NEW_LOC;
    EXIT(DOWHATHESAYS)
  END;  { TOSS_IT_AWAY }


BEGIN { TOSS_IT } 
  IF TOTING(ROD2) AND (VBL^.OBJ = ROD) AND NOT TOTING(ROD) THEN
    VBL^.OBJ := ROD2;
  IF NOT TOTING(VBL^.OBJ) THEN LEAVE;
  IF (VBL^.OBJ >= 50) AND (VBL^.OBJ <= MAXTRS) AND AT(TROLL) THEN
    BEGIN
      SPK := 159;
      DROP(VBL^.OBJ, 0);
      MOVE(TROLL, 0);
      MOVE(TROLL + 100, 0);
      DROP(TROLL2, ARY^.PLAC[TROLL]);
      DROP(TROLL2 + 100, ARY^.FIXD[TROLL]);
      JUGGLE(CHASM);
      LEAVE
    END;
  IF (VBL^.OBJ = FOOD) AND HERE(BEAR) THEN
    BEGIN
      VBL^.OBJ := BEAR;
      FEED_IT
    END;
  if (vbl^.obj = ball) and (vbl^.loc = 149) and (vary^.prop[wizard] = 0) and
    toting(ball) then
    begin
      speak(ary^.rtext[207]);
      vary^.prop[wizard] := 1;
      destroy(ball);
      drop(jade,vbl^.loc);
      k := null;
      set_new_loc;
      exit(dowhathesays)
    end;
  IF VBL^.OBJ <> AXE THEN DROP_IT;
  FOR I := 1 TO 5 DO
    BEGIN
      IF VARY^.DLOC[I] = VBL^.LOC THEN
        BEGIN
          SPK := 48;
          IF RAN(3) <> 0 THEN
            BEGIN
              VARY^.DSEEN[I] := FALSE;
              VARY^.DLOC[I] := 0;
              SPK := 47;
              VBL^.DKILL := VBL^.DKILL + 1;
              IF VBL^.DKILL = 1 THEN SPK := 149
            END;
          TOSS_IT_AWAY
        END
    END;
  if (vbl^.loc = 149) and (vary^.prop[wizard] <> 1) then
    begin
      speak(ary^.rtext[213]);
      drop(axe,vbl^.loc);
      k := null;
      set_new_loc;
      exit(dowhathesays)
    end;
  SPK := 152;
  IF AT(DRAGON) AND (VARY^.PROP[DRAGON] = 0) THEN TOSS_IT_AWAY;
  SPK := 158;
  IF AT(TROLL) THEN TOSS_IT_AWAY;
  IF HERE(BEAR) AND (VARY^.PROP[BEAR] = 0) THEN
    BEGIN
      SPK := 164;
      DROP(AXE, VBL^.LOC);
      VARY^.FIXED[AXE] := -1;
      VARY^.PROP[AXE] := 1;
      JUGGLE(BEAR);
      LEAVE
    END;
  VBL^.OBJ := 0;
  KILL_IT
END;  { TOSS_IT }


PROCEDURE FIND_IT;

VAR
  I : INTEGER;

BEGIN { FIND_IT }
  IF AT(VBL^.OBJ) OR ((LIQ = VBL^.OBJ) AND AT(BOTTLE)) OR
    (K = LIQLOC(VBL^.LOC)) THEN SPK := 94;
  IF VBL^.OBJ = DWARF THEN
    FOR I := 1 TO 6 DO
      IF (VARY^.DLOC[I] = VBL^.LOC) AND (VBL^.DFLAG >= 2) THEN SPK := 94;
  IF VBL^.CLOSED THEN SPK := 138;
  IF TOTING(VBL^.OBJ) THEN SPK := 24;
  LEAVE
END;  { FIND_IT }


PROCEDURE BLAST_IT;

BEGIN
  IF (VARY^.PROP[ROD2] < 0) OR NOT VBL^.CLOSED THEN LEAVE;
  BONUS := 133;
  IF VBL^.LOC = 115 THEN BONUS := 134;
  IF HERE(ROD2) THEN BONUS := 135;
  SPEAK(ARY^.RTEXT[BONUS]);
  ALLDONE := TRUE;
  EXIT(DOWHATHESAYS)
END;  { BLAST_IT }


PROCEDURE READ_IT;

BEGIN
  IF DARK THEN
    BEGIN
      WRITELN('I see no ', WD1, WD1X, ' here.');
      SPK := 0;
      LEAVE
    END;
  IF VBL^.OBJ = MAGAZINE THEN SPK := 190;
  IF VBL^.OBJ = TABLET THEN SPK := 196;
  IF VBL^.OBJ = MESSAGE THEN SPK := 191;
  if vbl^.obj = scroll then spk := 214;
  IF (VBL^.OBJ = OYSTER) AND VARY^.HINTED[2] AND TOTING(OYSTER) THEN
    SPK := 194;
  IF (VBL^.OBJ <> OYSTER) OR VARY^.HINTED[2] OR NOT TOTING(OYSTER) OR
    NOT VBL^.CLOSED THEN LEAVE;
  VARY^.HINTED[2] := YES(192, 193, 54);
  SPK := 0;
  LEAVE
END;  { READ_IT }


PROCEDURE BREAK_IT;

BEGIN
  IF VBL^.OBJ = MIRROR THEN SPK := 148;
  IF (VBL^.OBJ = VASE) AND (VARY^.PROP[VASE] = 0) THEN
    BEGIN
      SPK := 198;
      IF TOTING(VASE) THEN DROP(VASE, VBL^.LOC);
      VARY^.PROP[VASE] := 2;
      VARY^.FIXED[VASE] := -1;
      LEAVE
    END
  ELSE
    BEGIN
      IF (VBL^.OBJ <> MIRROR) OR NOT VBL^.CLOSED THEN LEAVE;
      SPEAK(ARY^.RTEXT[197]);
      DISTURBDWARVES
    END
END;  { BREAK_IT }


PROCEDURE WAKE_IT;

BEGIN
  IF (VBL^.OBJ <> DWARF) OR NOT VBL^.CLOSED THEN LEAVE;
  SPEAK(ARY^.RTEXT[199]);
  DISTURBDWARVES
END;  { WAKE_IT }


PROCEDURE CARRY_SOMETHING;

VAR
  I : INTEGER;

BEGIN { CARRY_SOMETHING }
  IF (VARY^.ATLOC[VBL^.LOC] = 0) THEN ASKWHATTODOITTO;
  IF VARY^.LINK[VARY^.ATLOC[VBL^.LOC]] <> 0 THEN ASKWHATTODOITTO;
  FOR I := 1 TO 5 DO
    IF (VARY^.DLOC[I] = VBL^.LOC) AND (VBL^.DFLAG >= 2) THEN ASKWHATTODOITTO;
  VBL^.OBJ := VARY^.ATLOC[VBL^.LOC];
  CARRY_IT
END;  { CARRY_SOMETHING }


PROCEDURE L_U_SOMETHING;

BEGIN
  SPK := 28;
  IF HERE(CLAM) THEN VBL^.OBJ := CLAM;
  IF HERE(OYSTER) THEN VBL^.OBJ := OYSTER;
  IF AT(DOOR) THEN VBL^.OBJ := DOOR;
  if at(door2) then vbl^.obj := door2;
  IF AT(GRATE) THEN VBL^.OBJ := GRATE;
  IF (VBL^.OBJ <> 0) AND HERE(CHAIN) THEN ASKWHATTODOITTO;
  IF HERE(CHAIN) THEN VBL^.OBJ := CHAIN;
  IF VBL^.OBJ = 0 THEN LEAVE;
  L_U_IT
END;  { L_U_SOMETHING } 


PROCEDURE EAT_SOMETHING;

BEGIN
  IF NOT HERE(FOOD) THEN ASKWHATTODOITTO;
  VBL^.OBJ := FOOD;
  EAT_IT
END;  { EAT_SOMETHING }


PROCEDURE QUIT2;

BEGIN
  ALLDONE := GAVEUP;
  IF GAVEUP THEN EXIT(DOWHATHESAYS);
  SPK := 0;
  LEAVE
END;  { QUIT2 }


PROCEDURE QUIT;

BEGIN
  GAVEUP := YES(22, 54, 54);
  QUIT2
END;  { QUIT }


PROCEDURE REPORT;

VAR
  I : INTEGER;

BEGIN { REPORT - INVENTORY }
  SPK := 98;
  FOR I := 1 TO 100 DO
    IF (I <> BEAR) AND TOTING(I) THEN
      BEGIN
        IF SPK = 98 THEN SPEAK(ARY^.RTEXT[99]);
        PSPEAK(I, -1);
        SPK := 0
      END;
  IF TOTING(BEAR) THEN SPK := 141;
  LEAVE
END;  { REPORT }


PROCEDURE REPORT_SCORE;

BEGIN { REPORT_SCORE }
  SCORE := GETSCORE(TRUE);
  WRITE('If you were to quit now, you would score ');
  if termwidth < 64 then writeln;
  WRITELN(SCORE, ' out of a possible ', MAXSCORE, '.');
  GAVEUP := YES(143, 54, 54);
  QUIT2
END;  { REPORT_SCORE }


PROCEDURE WORD_FOO;

BEGIN
  K := VOCAB(WD1, 3);
  SPK := 42;
  IF VBL^.FOOBAR = 1 - K THEN
    BEGIN
      VBL^.FOOBAR := K;
      IF K <> 4 THEN
        BEGIN
          SPK := 54;
          LEAVE
        END;
      IF (VARY^.PLACE[EGGS] = ARY^.PLAC[EGGS]) OR (TOTING(EGGS) AND
        (VBL^.LOC = ARY^.PLAC[EGGS])) THEN LEAVE;
      IF (VARY^.PLACE[EGGS] = 0) AND (VARY^.PLACE[TROLL] = 0) AND
        (VARY^.PROP[TROLL] = 0) THEN VARY^.PROP[TROLL] := 1;
      K := 2;
      IF HERE(EGGS) THEN K := 1;
      IF VBL^.LOC = ARY^.PLAC[EGGS] THEN K := 0;
      MOVE(EGGS, ARY^.PLAC[EGGS]);
      PSPEAK(EGGS, K);
      SPK := 0;
      LEAVE
    END;
  IF VBL^.FOOBAR <> 0 THEN SPK := 151;
  LEAVE
END;  { WORD_FOO }


PROCEDURE SET_BRIEF;

BEGIN
  SPK := 156;
  VBL^.ABBNUM := 10000;
  VBL^.DETAIL := 3;
  LEAVE
END;  { SET_BRIEF }


PROCEDURE READ_SOMETHING;

BEGIN
  IF HERE(MAGAZINE) THEN VBL^.OBJ := MAGAZINE;
  IF HERE(TABLET) THEN VBL^.OBJ := VBL^.OBJ * 100 + TABLET;
  IF HERE(MESSAGE) THEN VBL^.OBJ := VBL^.OBJ * 100 + MESSAGE;
  IF VBL^.CLOSED AND TOTING(OYSTER) THEN VBL^.OBJ := OYSTER;
  IF (VBL^.OBJ > 100) OR (VBL^.OBJ = 0) OR DARK THEN ASKWHATTODOITTO;
  READ_IT
END;  { READ_SOMETHING }


PROCEDURE SUSPEND; 


  PROCEDURE SUSPEXIT;

  BEGIN
    WRITELN('Error suspending game.');
    CLOSE(INFILE);
    EXIT(SUSPEND)
  END;  { SUSPEXIT }


BEGIN { SUSPEND }
  NAMEANDPW;
  VBL^.PASSWORD := TESTPW;
  VBL^.VERSION := VERSION;
  REWRITE(INFILE, NAMEOFUSER);
  I := (SIZEOF(VARYS) + 511) DIV 512;
  IF I <> BLOCKWRITE(INFILE, VARY^.DBLK, I) THEN SUSPEXIT;
  I := (SIZEOF(VBLS) + 511) DIV 512;
  IF I <> BLOCKWRITE(INFILE, VBL^.DBLK, I) THEN SUSPEXIT;
  CLOSE(INFILE, LOCK);
  WRITELN;
  WRITE('Adventure game saved as ', NAMEOFUSER);
  EXIT(ADVENTURE)
END;  { SUSPEND }


PROCEDURE ANALANITVERB;

BEGIN
  CASE VBL^.VERB OF
    1 : CARRY_SOMETHING; { TAKE }
    2 : ASKWHATTODOITTO; { DROP }
    3 : ASKWHATTODOITTO; { SAY }
    4 : L_U_SOMETHING;   { OPEN }
    5 : SAY_OK;          { NOTHING }
    6 : L_U_SOMETHING;   { LOCK }
    7 : LAMP_ON;         { ON }
    8 : LAMP_OFF;        { OFF }
    9 : ASKWHATTODOITTO; { WAVE }
   10 : ASKWHATTODOITTO; { CALM }
   11 : LEAVE;           { WALK }
   12 : KILL_IT;         { KILL }
   13 : POUR_IT;         { POUR }
   14 : EAT_SOMETHING;   { EAT }
   15 : DRINK_IT;        { DRINK }
   16 : ASKWHATTODOITTO; { RUB }
   17 : ASKWHATTODOITTO; { TOSS }
   18 : QUIT;            { QUIT }
   19 : ASKWHATTODOITTO; { FIND }
   20 : REPORT;          { INVENTORY }
   21 : ASKWHATTODOITTO; { FEED }
   22 : FILL_IT;         { FILL }
   23 : BLAST_IT;        { BLAST }
   24 : REPORT_SCORE;    { SCORE }
   25 : WORD_FOO;        { FOO }
   26 : SET_BRIEF;       { BRIEF }
   27 : READ_SOMETHING;  { READ }
   28 : ASKWHATTODOITTO; { BREAK }
   29 : ASKWHATTODOITTO; { WAKE }
   30 : SUSPEND;         { SUSPEND }
  END;  { CASE }
  IF VBL^.VERB > 29 THEN ERRORHALT(23)
END;  { ANALANITVERB }


PROCEDURE ANALATVERB;

BEGIN
  CASE VBL^.VERB OF
    1 : CARRY_IT;  { TAKE }
    2 : DROP_IT;   { DROP }
    3 : SAY_IT;    { SAY }
    4 : L_U_IT;    { OPEN }
    5 : SAY_OK;    { NOTHING }
    6 : L_U_IT;    { LOCK }
    7 : LAMP_ON;   { ON }
    8 : LAMP_OFF;  { OFF }
    9 : WAVE_IT;   { WAVE }
   10 : LEAVE;     { CALM }
   11 : LEAVE;     { WALK }
   12 : KILL_IT;   { KILL }
   13 : POUR_IT;   { POUR }
   14 : EAT_IT;    { EAT }
   15 : DRINK_IT;  { DRINK }
   16 : RUB_IT;    { RUB }
   17 : TOSS_IT;   { TOSS }
   18 : LEAVE;     { QUIT }
   19 : FIND_IT;   { FIND }
   20 : FIND_IT;   { INVENTORY }
   21 : FEED_IT;   { FEED }
   22 : FILL_IT;   { FILL }
   23 : BLAST_IT;  { BLAST }
   24 : LEAVE;     { SCORE }
   25 : LEAVE;     { FOO }
   26 : LEAVE;     { BRIEF }
   27 : READ_IT;   { READ }
   28 : BREAK_IT;  { BREAK }
   29 : WAKE_IT;   { WAKE }
   30 : SUSPEND;   { SUSPEND }
  END;  { CASE }
  IF VBL^.VERB > 29 THEN ERRORHALT(24)
END;  { ANALATVERB }


========================================================================================
DOCUMENT :usus Folder:VOL24:vol24.doc.text
========================================================================================

                             USUS Library Volume 24
                      Adventure 500, the 500 point version

VOL24:
ADVX1.TEXT        48  A data file
ADVX2.TEXT         8 
ADVX3.TEXT        22 
ADVX4.TEXT        10 
ADVX5.TEXT        16 
ADVX6.TEXT        42 
ADVX7.TEXT         6 
ADVX8.TEXT         4 
ADVX9.TEXT         4 
ADVX10.TEXT        4 
ADVX11.TEXT        4  The last data file
ADVXCONS.TEXT      4  An include file of Adventure
ADVXINIT.TEXT     24  Creates the Adventure data file from the data source files
ADVXVERB.TEXT     44  An include file of Adventure
ADVXINIT4.CODE     8  A version 4 code file of ADVXINIT
ADVXINIT2.CODE     9  A version 2 code file if ADVXINIT
ADV.MISCINFO       4  Specifies screen size
ADVX4.CODE        45  A version 4 code file of ADVX
ADVX2.CODE        50  An un-linked version 2 code file of ADVX
ADVXSUBS.TEXT     20  An include file of Adventure
ADVXSEGS.TEXT     28  An include file of Adventure
ADVX.TEXT         38  The main program of Adventure
ADVX.DOC.TEXT     22  Documentation of Adventure
VOL24.DOC.TEXT     6  You're reading it.

Please transfer the text below to a disk label if you copy this volume.

    USUS Volume 24 -***- USUS Software Library
                         
   For not-for-profit use by USUS members only.
  May be used and distributed only according to 
      stated policy and the author's wishes.



This volume was assembled by George Schreyer from material collected by
the Library committee.

__________________________________________________________________________


========================================================================================
DOCUMENT :usus Folder:VOL25:readme.1st.text
========================================================================================

Some notes from the reviewer:

     I have made UDE marginally work.  I am not really very impressed
with the entire package, but it shows some interesting programming constructs
and is very possibly useful to somebody.  The documentation, although extensive
is unclear and hard to follow.  The example given in the last part of the
documentation has some errors, but after a couple of hours of playing around,
you too will figure it out.  

     The program requires that the code files reside on #4:.  You can easily
change this in UD.UDE.TEXT.  The program has the built in and annoying
tendency to chain back to itself, so you may find that it restarts when you
don't want it to.  Simply remove the last call to CHAIN in UD.UDE.TEXT and re-
compile it.

     There is some rather clever code in SH.INIT.TEXT to to obtain the
cursor control characters for the user's terminal.  Unfortunatly, it don't
work.  If your terminal uses two character control sequences for the arrow keys
you will have to go in and hard wire stuff.  The function SC_MAP_CRT_COMMAND
is kind of odd and can't really be used in the way shown with two character
sequences.  

     SC_MAP_CRT_COMMAND (in screenops) expects you to read characters from
the terminal and pass all of them through it.  If your terminal has two
character control sequences, some of the characters that you read will
be the prefix characters.  When SC_MAP_CRT_COMMAND is passed a prefix
character, IT GOES OUT AND READS THE TERMINAL, EXPECTING TO FIND ANOTHER
CHARACTER!!  If the next character is one of the ones for the special keys,
it will return the enumerated type of the special key and the value of the
character that it read.  This means that the method used in UDE hangs
whenever this procedure is called.  UNLESS THE CORRECT CHARACTERS ARE TYPED IN
THE CORRECT ORDER the program will not be able to determine the values of the 
arrow keys.  With one character command sequences, the method should work fine.

     The author has also done something which will cause a lot of users, 
especially those with APC's and PC's a lot of grief.  Most of the prompt 
lines are written to the screen with the 8th bit set.  This is probably
some special video attribute for his terminal, but many terminals use
the characters between 128 and 255 as graphics characters.  This means the
much of the prompting information will be displayed as graphic garbage.
This stuff is scattered throughout the program, and I didn't want to change
it.  If it causes you problems, you will have to go in and delete the
< +128 > expressions.

     Good luck  george w. schreyer

     p.s.  The submittor has requested that any changes, bug fixes, or
upgrades be submitted back to him.  If you improve on this program, other
than the items mentioned above, please contact me so that we can send
the upgrades back to him.

========================================================================================
DOCUMENT :usus Folder:VOL25:sd.define.text
========================================================================================

Program DEFINE;   {$L PRINTER:}

USES {$U SH/SCREEN.UNIT } SCREEN40;

 var MASK,NEWMASK: SCREEN_ARR;
     PPROMPTS,NEWPROMPTS: PROMPT_ARR;
     VERSION,FNAME,GETP,EDITP,SAVEP,QUITP,PRNTP,CLEARP,
     EDITP1,EDITP2,FILEPROMPT: String;
     BLNKREC: FIELD_DEFS;
     BLNKPROMPT: PROMPT_DEFS;
     NFLDS,NPFLDS: Integer;
     SAVED: Boolean;
     CH: Char;

Segment Procedure INITIALIZE;
  var I: Integer;
      
  Procedure LIGHT(var TEMP: String);
   var I: Integer;
   begin {LIGHT}
    for I:=1 to length(TEMP) do 
     if not(TEMP[I] in['A'..'Z'])then TEMP[I]:=chr(ord(TEMP[I])+128);
   end;
  
  Procedure SET_FILEMASK;
   begin {set FILEMASK}
    with MASK[1] do
      begin
       S_ROW:=0;  S_ID:='VOLUME';  S_LEN:=8;  S_JUS:='L';
      end;
     with MASK[2] do
      begin
       S_ROW:=1;  S_ID:='NAME';  S_LEN:=10;  S_JUS:='L';
      end;
     with MASK[3] do
      begin
       S_ROW:=2;  S_ID:='FTYPE';  S_LEN:=4;  
       S_JUS:='L';  S_DEF:='SCRN';   
      end;
     with PPROMPTS[1] do  P_FLD:='Volume :';
     with PPROMPTS[2] do
      begin
       P_ROW:=1;  P_FLD:='Name   :';
      end;
     with PPROMPTS[3] do
      begin
       P_ROW:=2;  P_FLD:='Type   :';
      end;
   end; {set MASK}
  
  Procedure SET_SMASK;
   begin
     for I:=4 to 13 do
      with MASK[I] do
       begin
        S_JUS:='L';  S_LEN:=1;  S_MIN:=1;  
       end; 
    with MASK[4] do
     begin
      S_ID:='IDNAME';  S_ROW:=7;  S_LEN:=8;  S_MIN:=0;  S_SKIP:=False;
     end;
    with MASK[5] do
     begin
       S_ID:='SKIP';  S_ROW:=7;  S_COL:=40;  S_FLD:='T';
       S_DEF:='T';  S_SKIP:=True;
     end;
    with MASK[6] do
     begin
      S_ID:='TYPE';  S_ROW:=8;  S_NA:='L';  S_DEF:='V';
      S_FLD:='V';    S_SKIP:=True;
     end;
    with MASK[7] do
     begin
      S_ID:='JUST';  S_ROW:=8;   S_COL:=40;  S_NA:='L';
      S_FLD:='N';   S_DEF:='N';  S_SKIP:=True;
     end;
    with MASK[8] do
     begin
      S_ID:='FROW';  S_ROW:=9;  S_NA:='N';  S_JUS:='R';  
      S_LEN:=2;      S_DEF:='0';
     end;
    with MASK[9] do
     begin
      S_ID:='FCOL';  S_ROW:=9;  S_COL:=5;  S_NA:='N';
      S_JUS:='R';    S_LEN:=2;  S_DEF:='0';
     end;
    with MASK[10] do
     begin
      S_ID:='ALFA';  S_ROW:=9;  S_COL:=40;  S_NA:='L';
      S_FLD:='A';  S_DEF:='A';  S_SKIP:=True;
     end;
    with MASK[11] do
     begin
      S_ID:='LEN';  S_ROW:=10;  S_NA:='N';  S_JUS:='R';
      S_LEN:=2;     S_DEF:='0';
     end;
    with MASK[12] do
     begin
      S_ID:='MIN';  S_ROW:=10;  S_COL:=40;  S_NA:='N';
      S_JUS:='R';   S_LEN:=2;   S_DEF:='0';
     end;
    with MASK[13] do
     begin
      S_ID:='DEFVAL';  S_ROW:=11;  S_MIN:=0;  S_JUS:='N';  S_LEN:=40;
     end;
    with PPROMPTS[4] do
     begin  P_ROW:=4;  P_COL:=29;  P_FLD:='DEFINE INPUT FIELD';  end;
    with PPROMPTS[5] do
     begin  P_ROW:=5;  P_COL:=29;  P_FLD:='------------------';  end;
    with PPROMPTS[6] do
     begin  P_ROW:=7;  P_FLD:='Field ID Name           :';  end;
    with PPROMPTS[7] do
     begin  P_ROW:=7;  P_COL:=40;  P_FLD:='Auto Skip (T/F)         :';  end;
    with PPROMPTS[8] do
     begin  P_ROW:=8;  P_FLD:='Field Type (C/D/I/V)    :';  end;
    with PPROMPTS[9] do
     begin  P_ROW:=8;  P_COL:=40;  P_FLD:='Justify (L/R/N)         :';  end;
    with PPROMPTS[10] do
     begin  P_ROW:=9;  P_FLD:='Row / Column Number     :    /';  end;
    with PPROMPTS[11] do
     begin  P_ROW:=9;  P_COL:=40;  P_FLD:='Alpha-Numeric (A/L/N/S) :';  end;
    with PPROMPTS[12] do
     begin  P_ROW:=10;  P_FLD:='Field Length            :';  end;
    with PPROMPTS[13] do
     begin  P_ROW:=10;  P_COL:=40;  P_FLD:='Minimum Input           :';  end;
    with PPROMPTS[14] do
     begin  P_ROW:=11;  P_FLD:='Default/Calculation     :';  end;
   end; {SET_SMASK}

  Procedure SET_PMASK;
   begin
    for I:=14 to 17 do
     begin
      with MASK[I] do
       begin
        S_ROW:=I+1;  S_COL:=16;  S_NA:='N';
        S_LEN:=2;  S_JUS:='R';  S_MIN:=1;  S_DEF:='0';
       end; {with}
      with PPROMPTS[I+3] do  P_ROW:=I+1;
     end; {for}
    MASK[14].S_ID:='INDEX';
    MASK[15].S_ID:='PROW';
    MASK[16].S_ID:='PCOL';
    with MASK[17] do
     begin
      S_ID:='PROMPT'; S_LEN:=40;  S_COL:=9;  S_DEF:='';
      S_JUS:='N';  S_NA:='S';
     end;
    with PPROMPTS[15] do
     begin
      P_FLD:='DEFINE PROMPT FIELD';  P_ROW:=12; P_COL:=29;
     end;
    with PPROMPTS[16] do
     begin
      P_FLD:='-------------------';  P_ROW:=13;  P_COL:=29;
     end;
    PPROMPTS[17].P_FLD:='Prompt Number :';
    PPROMPTS[18].P_FLD:='Row Number    :';
    PPROMPTS[19].P_FLD:='Column Number :';
    PPROMPTS[20].P_FLD:='Prompt :';
   end; {SET_PMASK}

  begin {INITIALIZE}
   with BLNKREC do
    begin
     S_ID :='';
     S_ROW:=END_SCREEN;
     S_COL:=0;
     S_LEN:=0;
     S_MIN:=0;
     S_TYP:='V';
     S_JUS:='N';
     S_NA :='S';
     S_SKIP:=False;
     S_DEF:='';
     S_FLD:='';
    end;
   with BLNKPROMPT do
    begin
     P_ROW:=END_SCREEN;
     P_COL:=0;
     P_FLD:='';
    end;
   for I:=1 to SCREEN_FIELDS do
    begin
     NEWMASK[I]:=BLNKREC;
     MASK[I]:=BLNKREC;
     NEWPROMPTS[I]:=BLNKPROMPT;
     PPROMPTS[I]:=BLNKPROMPT;  PPROMPTS[I].P_ROW:=0;
    end;
   NPFLDS:=0;  NFLDS:=0;  FNAME:='';
   SET_FILEMASK;
   SET_SMASK;
   SET_PMASK;
   VERSION:='Version IV.0';
   for I:=1 to length(VERSION) do
     VERSION[I]:=chr(ord(VERSION[I])+128);
   FILEPROMPT:='<ENTER> to execute,<ESC> to abort';  LIGHT(FILEPROMPT); 
   EDITP1:='Upper Field  Add    Back Examine Test';  LIGHT(EDITP1);
   EDITP2:='Lower Prompt Delete Next Change  Quit:';  LIGHT(EDITP2);
   CLEARP:='Clear current screen defintion'; LIGHT(CLEARP);
   GETP:='Get old screen definition file'; LIGHT(GETP);
   EDITP:='Edit screen definition file'; LIGHT(EDITP);
   SAVEP:='Save current screen definition file'; LIGHT(SAVEP);
   PRNTP:='Print screen definition file'; LIGHT(PRNTP);
   QUITP:='Quit';  LIGHT(QUITP);
  end; {initialize}
  
Procedure SORTRECS(var A: SCREEN_ARR; var R: Integer);  forward;
 
Procedure SORTP(var A: PROMPT_ARR; var R: Integer);  forward;
 
Function IVAL(NUMBER: String): Integer;  forward;

Segment Procedure FILE_IO(OPT: Char);
 var VOLNAME,FILENAME,FILETYPE: String;
     RESULT: Integer;
     F_EXIT,CH: Char;
  
 Procedure PRINT_FILE;
  const UL3 = '=== === ===';
        UL40 = '========================================';
  var LP: Text;
      IOCOL,EDGE,I: Integer;
      WIDTH: String;
      EXXIT: Char;
      
  Procedure PRINTPROMPTS;
   begin {Print prompts}
    if (EDGE=80) and ((NFLDS*2)+NPFLDS>50) then writeln(LP,FORM_FEED)
     else for I:=1 to 3 do writeln(LP); 
    writeln(LP,' ':(EDGE-25) div 2,'SCREEN PROMPT DEFINITIONS');
    writeln(LP);
    writeln(LP,'NO. ROW COL          PROMPT ');
    writeln(LP,UL3,' ',UL40);
    for I:=1 to NPFLDS do
      with NEWPROMPTS[I] do
       writeln(LP,I:2, P_ROW:4, P_COL:4,'  ',P_FLD);
    writeln(LP,FORM_FEED);
   end; {print prompts}
   
  begin {PRINT_FILE}
   rewrite(LP,'PRINTER:');
   gotoxy(0,MAXROW);  write('Printer width (80/132):');
   IOCOL:=25;    WIDTH:='132';   EDGE:=0;
   while not(EDGE in[80,132]) do
    begin
     FIELD(MAX_ROW,IOCOL,MAX_ROW,MAX_COL-40,3,1,EXXIT,'L','N',WIDTH,False);
     EDGE:=IVAL(WIDTH);
     if (EDGE=0) or (EXXIT=ESC_KEY) then exit(PRINT_FILE);
    end;
   if FNAME='' then writeln(LP)
     else writeln(LP,'Current Screen Definition file is "',FNAME,'"');
   writeln(LP);
   writeln(LP,' ':(EDGE-24) div 2,'SCREEN FIELD DEFINITIONS');
   writeln(LP);
   write(LP,'NO. ROW COL  IDNAME  TYP SKIP  LEN MIN JUS N/A');
   if EDGE=80 then 
    begin
     writeln(LP);
     writeln(LP,UL3,' ======== === ===== ===== ',UL3);
    end;
   writeln(LP,' ':14,'CURRENT VALUE',' ':27,'DEFAULT VALUE');
   if EDGE=132 then write(LP,UL3,' ======== === ===== === ',UL3,' ');
   writeln(LP,UL40,' ',UL40);
   for I:=1 to NFLDS do
     with NEWMASK[I] do
      begin
       write(LP,I:2, S_ROW:4, S_COL:4,'  ',S_ID,' ':9-length(S_ID),S_TYP:2,'  ');
       if S_SKIP then write(LP,'TRUE  ') else write(LP,'FALSE ');
       write(LP,S_LEN:2, S_MIN:4, S_JUS:4, S_NA:4);
       if EDGE=80 then writeln(LP) else write(LP,'  ');
       writeln(LP,S_FLD,' ':41-length(S_FLD),S_DEF,' ':41-length(S_DEF));
      end; {with/for}
   PRINTPROMPTS;
  end; {PRINT_FILE}

 Procedure OPEN_FILE;
    var RESULT: Integer;

    begin {OPEN_FILE}
     GET_FILE(FNAME,NEWMASK,NEWPROMPTS,RESULT);
     gotoxy(MAX_COL-40,MAX_ROW);
     if RESULT<>0 then
       write('STATUS: No File Loaded - ERROR ',RESULT,ALARM_BELL)
      else
       begin
        write('STATUS: File Loaded.');
        NFLDS:=SCREEN_FIELDS;
        SORTRECS(NEWMASK,NFLDS);
        NPFLDS:=SCREEN_FIELDS;
        SORTP(NEWPROMPTS,NPFLDS);
        SAVED:=True;
        with NEWMASK[1] do
         begin
          str(S_ROW,MASK[FIND('FROW',MASK)].S_FLD);
          str(S_COL,MASK[FIND('FCOL',MASK)].S_FLD);
          MASK[FIND('IDNAME',MASK)].S_FLD :=S_ID ;
          str(S_LEN,MASK[FIND('LEN',MASK)].S_FLD);
          str(S_MIN,MASK[FIND('MIN',MASK)].S_FLD);
          if S_SKIP then MASK[FIND('SKIP',MASK)].S_FLD:='T'
             else MASK[FIND('SKIP',MASK)].S_FLD:='F';
          MASK[FIND('DEFVAL',MASK)].S_FLD :=S_DEF;
          MASK[FIND('TYPE',MASK)].S_FLD[1]:=S_TYP;
          MASK[FIND('JUST',MASK)].S_FLD[1]:=S_JUS;
          MASK[FIND('ALFA',MASK)].S_FLD[1]:=S_NA ;
         end;
        with NEWPROMPTS[1] do
         begin
          MASK[FIND('INDEX',MASK)].S_FLD:='1';
          str(P_ROW,MASK[FIND('PROW',MASK)].S_FLD);
          str(P_COL,MASK[FIND('PCOL',MASK)].S_FLD);
          MASK[FIND('PROMPT',MASK)].S_FLD :=P_FLD;
         end;
        exit(FILE_IO);
      end;
    end; {OPEN_FILE}
  
   Procedure SAVE;
    var FILE_TO_SAVE: File of SCREEN_REC;
        SIZE,RESULT,I: Integer;

    begin {SAVE}
     SAVE_FILE(FNAME,NEWMASK,NEWPROMPTS,RESULT);
     if RESULT<>0 then
       begin
        gotoxy(MAX_COL-40,MAX_ROW);
        write(ALARM_BELL,'STATUS: File not saved.','ERROR ',RESULT,ALARM_BELL);
       end
      else
        begin
         SIZE:=0;
         gotoxy(0,MAX_ROW);
         for I:=1 to NFLDS do SIZE:=SIZE+NEWMASK[I].S_LEN;
         write('STATUS: File saved. Total length : ',SIZE,'.');
         SAVED:=True;
         write('  Press <RETURN> to continue.');
         repeat 
           read(Keyboard,CH);
         until eoln(Keyboard);
         exit(FILE_IO);
        end; {save}
    end; {SAVE}

   begin {FILE_IO}
    case OPT of
     'G': begin {get prompt}
           CLEAR_HOME ;
           writeln(' ':28,'GET SCREEN DEFINITION');
           writeln(' ':28,'=====================');
          end;
     'P': begin {print}
           PRINT_FILE;
           exit(FILE_IO);
          end; {print}
     'S': begin {save prompt}
           CLEAR_HOME ;
           writeln(' ':28,'SAVE SCREEN DEFINITION');
           writeln(' ':28,'======================');
          end;
     end; {case}
    DISPLAY_PROMPTS(PPROMPTS,8,10,0,2);
    DISPLAY_SCREEN(MASK,8,20,0,2);
    gotoxy(0,MAX_ROW-1); write(FILEPROMPT);
    repeat 
     SCREEN(MASK,True,1,8,20,0,2,MAX_ROW,MAX_COL-40,F_EXIT);
     if F_EXIT=ESC_KEY then exit(FILE_IO)
       else 
        begin {execute}
         VOLNAME:=MASK[1].S_FLD;
         FILENAME:=MASK[2].S_FLD;
         FILETYPE:=MASK[3].S_FLD;
         EATSPR(VOLNAME);  EATSPR(FILENAME);  EATSPR(FILETYPE);
         FNAME:=concat(VOLNAME,':',FILENAME,'.',FILETYPE);
         case OPT of
           'G': OPEN_FILE;
           'S': SAVE;
          end; {case}
        end; {execute}
     until False;
   end; {FILE_IO}
   
Segment Procedure EDIT_FILE;
  var F_EXIT,CH: Char;
      X,R_OFF,I: Integer;
      OLDVAL: Packed array[1..14] of STRINGFL;
      TNAME: STR_ID;
      P_MODE: Boolean;

  Procedure E_MSG(MSG: String);
   begin {E_MSG}
    ERASE_EOL(MAX_COL-40,MAX_ROW); write(ALARM_BELL);
    write('ERROR: ',MSG,ALARM_BELL);
   end; {E_MSG}
   
  Procedure DISPLAY;
   begin {DISPLAY}
    if P_MODE then 
     begin {prompt screen}
      DISPLAY_PROMPTS(NEWPROMPTS,0,0,((MAX_ROW+1)div 2)-R_OFF,MAX_ROW-R_OFF);
      DISPLAY_PROMPTS(PPROMPTS,R_OFF-12,0,12,18);
      DISPLAY_SCREEN(NEWMASK,0,0,((MAX_ROW+1) div 2)-R_OFF,MAX_ROW-R_OFF);
      DISPLAY_SCREEN(MASK,R_OFF-12,0,12,18);
     end {prompt screen}
     else begin {data field screen}
      DISPLAY_PROMPTS(NEWPROMPTS,0,0,((MAX_ROW+1) div 2)-R_OFF,MAX_ROW-R_OFF);
      DISPLAY_PROMPTS(PPROMPTS,R_OFF-4,0,4,11);
      DISPLAY_SCREEN(NEWMASK,0,0,((MAX_ROW+1) div 2)-R_OFF,MAX_ROW-R_OFF);
      DISPLAY_SCREEN(MASK,R_OFF-4,26,4,11);
     end; {data field screen}
    gotoxy(0,10+R_OFF); writeln(EDITP1); write(EDITP2);
   end;

  Procedure EXAMINE;
   begin {Examine}
    if PMODE then 
      begin {examine prompt}
       X:=IVAL(MASK[FIND('INDEX',MASK)].S_FLD);
       if X<1 then X:=1 else if X>NPFLDS then X:=NPFLDS;
       with NEWPROMPTS[X] do
        begin
         str(P_ROW,MASK[FIND('PROW',MASK)].S_FLD);
         str(P_COL,MASK[FIND('PCOL',MASK)].S_FLD);
         MASK[FIND('PROMPT',MASK)].S_FLD:=P_FLD;
        end; {with}
       DISPLAY_SCREEN(MASK,R_OFF-12,0,12,18);
      end {examine prompt}
     else
      begin {examine field}
        TNAME:=MASK[FIND('IDNAME',MASK)].S_FLD;  EATSPR(TNAME);
        X:=FIND(TNAME,NEWMASK);
        if X=0 then E_MSG('Invalid ID Name.')
        else
         begin
          with NEWMASK[X] do
           begin
            MASK[FIND('IDNAME',MASK)].S_FLD :=S_ID ;
            str(S_ROW,MASK[FIND('FROW',MASK)].S_FLD);
            str(S_COL,MASK[FIND('FCOL',MASK)].S_FLD);
            str(S_LEN,MASK[FIND('LEN',MASK)].S_FLD);
            str(S_MIN,MASK[FIND('MIN',MASK)].S_FLD);
            MASK[FIND('DEFVAL',MASK)].S_FLD:=S_DEF;
            if S_SKIP then MASK[FIND('SKIP',MASK)].S_FLD :='T'
               else MASK[FIND('SKIP',MASK)].S_FLD :='F';
            MASK[FIND('TYPE',MASK)].S_FLD[1]:=S_TYP;
            MASK[FIND('JUST',MASK)].S_FLD[1]:=S_JUS;
            MASK[FIND('ALFA',MASK)].S_FLD[1]:=S_NA ;
           end; {with}
         DISPLAY_SCREEN(MASK,R_OFF-4,26,4,11);
        end; {else}
    end; {examine field}
   end; {examine}
  
  Procedure ADD;
   var TEMPID: STR_ID;
       TEMPINT: Integer;

   Procedure WARN(MSG: String);
    begin {WARN}
     gotoxy(MAX_COL-40,MAX_ROW);
     write(ALARM_BELL,'WARNING: ',MSG);
    end; {WARN}
    
   Procedure ADD_ERROR(MSG,FIELD: String);
    begin {ADD_ERROR}
      E_MSG(MSG);
      if P_MODE
       then SCREEN(MASK,True,FIND(FIELD,MASK),R_OFF-12,0,12,18,MAX_ROW,MAX_COL-40,F_EXIT)
       else
        begin
         NEWMASK[NFLDS+1]:=BLNKREC;
         SCREEN(MASK,True,FIND(FIELD,MASK),R_OFF-4,26,4,11,MAX_ROW,MAX_COL-40,F_EXIT);
        end; {else}
     exit(ADD);
    end; {ADD_ERROR}

    Procedure EXPR(TEXTLINE: String);
  var CURRENT_CHAR: Char;
      CHARCLASS,NPAREN,LASTOKEN,CH_COUNT,TOKENTYPE: Integer;
      
  
  Procedure ERROR(OPT: Integer);
   begin {error}
    case OPT of 
      0: ADD_ERROR('Illegal character in expression.','DEFVAL');
      1: ADD_ERROR('Missing right parenthesis.','DEFVAL');
      2: ADD_ERROR('Illegal operator, number expected.','DEFVAL');
      3: ADD_ERROR('Unexpected end of expression, number expected.','DEFVAL');
      4: ADD_ERROR('Missing operator in expression.','DEFVAL');
      5: ADD_ERROR('Too many right parenthesis.','DEFVAL');
     end; {case}
    exit(EXPR);
   end; {error}
    
  Procedure SCAN;
   
  (* The following table lists the integer returned for the token listed:
            
           1)   +             6)   (
           2)   -             7)   )
           3)   *             8)   <real>
           4)   /             9)   <integer>
           5)   ^            10)   <variable>
     
                                                                            *)
                                                                            
   var FINAL_STATE: Boolean;
       STATE: Integer;
   
   Procedure GETCHAR;
    
    { Function : GETCHAR pops the next character from TEXTLINE and returns it or
                      an end-of-line marker.
      Input : None (TEXTLINE is global)
      Output: A the next character in TEXTLINE.
      Local Variables : None.
                                                                             }
                                                                             
    begin {GETCHAR}
     if CH_COUNT=length(TEXTLINE) then CURRENT_CHAR:=''
      else 
       begin   {return next character and bump character count}
        CH_COUNT:=CH_COUNT+1;
        CURRENT_CHAR:=TEXTLINE[CH_COUNT];
       end;  {else}
     if CURRENT_CHAR in['a'..'z','A'..'Z'] then CHARCLASS:=10 
        else if CURRENT_CHAR in['0'..'9'] then CHARCLASS:=9
        else if CURRENT_CHAR='.' then CHARCLASS:=8
        else if CURRENT_CHAR=')' then CHARCLASS:=7
        else if CURRENT_CHAR='(' then CHARCLASS:=6
        else if CURRENT_CHAR='^' then CHARCLASS:=5
        else if CURRENT_CHAR='/' then CHARCLASS:=4
        else if CURRENT_CHAR='*' then CHARCLASS:=3
        else if CURRENT_CHAR='-' then CHARCLASS:=2
        else if CURRENT_CHAR='+' then CHARCLASS:=1
        else if CURRENT_CHAR='' then CHARCLASS:=11
        else if CURRENT_CHAR=' ' then CHARCLASS:=0
        else ERROR(0);
     end; {GETCHAR}
    
   begin {SCAN}
    STATE:=0;
    {Start state - Initialize everybody}
    FINAL_STATE:=False;
    while CURRENT_CHAR=' ' do GETCHAR;   {eat spaces}
    if CHARCLASS<8 then STATE:=CHARCLASS else STATE:=CHARCLASS+3;
    repeat
     case STATE of
        0,1,2,3,4,5,6,7: begin GETCHAR;  FINALSTATE:=True;  end;
        8,9,10,14: FINALSTATE:=True;
        11: begin {real no}
             GETCHAR;
             if CHARCLASS<>9 then ERROR(2)      {real no must have digit}
               else STATE:=15;
            end; {real no}
        12: begin {integer}
             GETCHAR;
             if CHARCLASS=8 then STATE:=15
               else if CHARCLASS<>9 then STATE:=9;
            end;  {integer}
        13: begin {var}
             GETCHAR;
             if (CHARCLASS<>10) and (CHARCLASS<>9)  then STATE:=10;
            end;  {var}
        15: begin {real no}
             GETCHAR;
             if CHARCLASS<>9 then STATE:=8;
            end; {real no}
      end {case}
    until FINAL_STATE;
    TOKENTYPE:=STATE;
   end; {SCAN}
   
  
   begin {EXPR}
    CURRENT_CHAR:=' ';   {Initialize input buffer}
    CH_COUNT:=0;
    LASTOKEN:=0;
    NPAREN:=0;
    SCAN;
    repeat
      case TOKENTYPE of
        1,2: {plus minus}
              if LASTOKEN=12 then ERROR(2)
                else if LASTOKEN in[1,2,3,4,5] then TOKENTYPE:=12;
        3,4,5:if LASTOKEN<6 then ERROR(2);  {multiply,divide,exponent}
        6: if LASTOKEN in[7,8,9,10] then ERROR(4)
              else NPAREN:=NPAREN+1;  {left paren}
        7: if LASTOKEN=6 then ERROR(4)
             else if LASTOKEN<6 then ERROR(2)
             else if NPAREN=0 then ERROR(5) else NPAREN:=NPAREN-1; {right paren}
        8,9,10: if LASTOKEN in[7,8,9,10] then ERROR(4);   {number}
        14: ERROR(3);
       end; {case}
      LASTOKEN:=TOKENTYPE;
      SCAN;
    until TOKENTYPE=14; {while}
    if NPAREN>0 then ERROR(1) else if LASTOKEN<7 then ERROR(3);
   end; {EXPR}
   
   Procedure TESTPROMPT;
    begin {TESTPROMPT}
     NPFLDS:=NPFLDS+1;
     with NEWPROMPTS[NPFLDS] do
      begin {test prompt info}
       P_ROW:=IVAL(MASK[FIND('PROW',MASK)].S_FLD);
       if (P_ROW<0) or (P_ROW>MAX_ROW) then
         ADD_ERROR('Illegal row number.','PROW');
       if P_ROW=MAX_ROW then WARN('Prompt defined on last row.');
       P_COL:=IVAL(MASK[FIND('PCOL',MASK)].S_FLD);
       if (P_COL<0) or (P_COL>MAX_COL) then
         ADD_ERROR('Illegal column number.','PCOL');
       P_FLD:=MASK[FIND('PROMPT',MASK)].S_FLD;
       EATSPR(P_FLD);
       if P_COL+length(P_FLD)>MAX_COL then WARN('Prompt defined past EOL.');
       DISPLAY;
       SORTP(NEWPROMPTS,NPFLDS);
       EXAMINE;
      end; {test info}
    end; {TESTPROMPT}
    
   begin {Add}
    if P_MODE then if NPFLDS=SCREEN_FIELDS
      then E_MSG('Maximum number of prompts reached.')
      else TESTPROMPT
    else if NFLDS=SCREEN_FIELDS
       then E_MSG('Maximum Number of Fields Reached.')
        else with NEWMASK[NFLDS+1] do
          begin
           TEMPID:=MASK[FIND('IDNAME',MASK)].S_FLD;  EATSPR(TEMPID);
           if FIND(TEMPID,NEWMASK)<>0
              then ADD_ERROR('Duplicate ID Name.','IDNAME');
           if TEMPID='' then ADD_ERROR('Invalid ID Name.','IDNAME')
              else S_ID :=TEMPID;
           if MASK[FIND('SKIP',MASK)].S_FLD[1] in['T','F','f','t'] 
             then S_SKIP:=(MASK[FIND('SKIP',MASK)].S_FLD[1]='T') 
                                   or
                          (MASK[FIND('SKIP',MASK)].S_FLD[1]='t')
               else ADD_ERROR('Auto Skip must be T or F.','SKIP');
           S_TYP:=MASK[FIND('TYPE',MASK)].S_FLD[1];
           if S_TYP in['c','d','i','v'] then S_TYP:=chr(ord(S_TYP)-32)
             else if not (S_TYP in['C','D','I','V'])
             then ADD_ERROR('Illegal field type.','TYPE');
           S_ROW:=IVAL(MASK[FIND('FROW',MASK)].S_FLD);
           if not (S_ROW in[0..MAX_ROW])
             then ADD_ERROR('Illegal row number.','FROW');
           if S_ROW=MAX_ROW then WARN('Field defined on last row.');
           S_JUS:=MASK[FIND('JUST',MASK)].S_FLD[1];
           if S_JUS in['l','r','n'] then S_JUS:=chr(ord(S_TYP)-32)
             else if not (S_JUS in ['L','R','N'])
             then ADD_ERROR('Illegal justification type.','JUST');
           S_COL:=IVAL(MASK[FIND('FCOL',MASK)].S_FLD);
           if not (S_COL in[0..MAX_COL])
             then ADD_ERROR('Illegal column number.','FCOL');
           S_NA :=MASK[FIND('ALFA',MASK)].S_FLD[1];
           if S_NA in['a','l','n','s'] then S_NA:=chr(ord(S_NA)-32)
             else if not (S_NA in['A','L','N','S'])
             then ADD_ERROR('Illegal input type.','ALFA');
           S_LEN:=IVAL(MASK[FIND('LEN',MASK)].S_FLD);
           if not (S_LEN in[0..MAX_FLEN])
             then ADD_ERROR('Illegal field length.','LEN');
           if S_COL+S_LEN>MAX_COL then WARN('Field defined past EOL.');
           S_MIN:=IVAL(MASK[FIND('MIN',MASK)].S_FLD);
           if not (S_MIN in[0..S_LEN])
             then ADD_ERROR('Illegal field minimum.','MIN');
           S_DEF:=MASK[FIND('DEFVAL',MASK)].S_FLD;  
           EATSPR(S_DEF);
           if S_TYP='C'
             then EXPR(S_DEF)
             else if length(S_DEF)>0 
               then if S_DEF[1]='['
                then 
                 begin
                  TEMPID:=copy(S_DEF,2,length(S_DEF)-2);
                  if length(TEMPID)<=LEN_ID then TEMPINT:=FIND(TEMPID,NEWMASK)
                     else TEMPINT:=-1;
                  if (TEMPINT=-1) or (S_DEF[length(S_DEF)]<>']')
                   then ADD_ERROR('Illegal default field.','DEFVAL')
                   else if TEMPINT=0
                     then WARN('Default field undefined.')
                     else S_FLD:=NEWMASK[TEMPINT].S_FLD;
                 end
               else if length(S_DEF)>S_LEN
                then ADD_ERROR('Literal default > field length.','DEFVAL')
                else S_FLD:=S_DEF
             else S_FLD:='';
          NFLDS:=NFLDS+1;
          SORTRECS(NEWMASK,NFLDS);
          DISPLAY;
         end; {else}
   end; {Add}
  
 Procedure NEXT(OP: Integer);
  begin {next}
   if P_MODE then 
      begin {next prompt}
       X:=IVAL(MASK[FIND('INDEX',MASK)].S_FLD)+OP;
       if NPFLDS=0 then E_MSG('No prompts defined.')
        else if X>NPFLDS then E_MSG('End of prompt definitions.')
        else if X<1 then E_MSG('Begining of prompt definitions.')
        else
         begin
          str(X,MASK[FIND('INDEX',MASK)].S_FLD);
          EXAMINE;
         end;
      end {next prompt}
   else 
     begin {Next Field}
      TNAME:=MASK[FIND('IDNAME',MASK)].S_FLD;  EATSPR(TNAME);
      X:=FIND(TNAME,NEWMASK)+OP;
      if NFLDS=0 then E_MSG('No fields defined.')
        else if X>NFLDS then E_MSG('End of field definitions.')
        else if X<1 then E_MSG('Begining of field definitions.')
        else
         begin
          MASK[FIND('IDNAME',MASK)].S_FLD:=NEWMASK[X].S_ID;
          EXAMINE;
         end;
     end; {Next field}
  end; {NEXT}
 
 Procedure ERASEIT(R,C,LEN: Integer);
  begin {ERASEIT}
   if ((R_OFF=0) and (R>=MAX_ROW div 2)) or ((R_OFF>0) and (R<R_OFF))
     then 
      begin
       gotoxy(C,R);
       write(' ':LEN);
      end;
  end; {ERASEIT}
  
  begin {EDIT_FILE}
   CH:='L'; X:=1;  P_MODE:=False; SAVED:=False;
   while (CH<>'q') and (CH<>'Q') do
    begin
     case CH of
       'l','L': begin {Lower}
                 CLEAR_HOME ;
                 R_OFF:=0;
                 DISPLAY;
                end; {Lower}
       'u','U': begin {Upper}
                 CLEAR_HOME ;
                 R_OFF:=(MAX_ROW+1) div 2;
                 DISPLAY;
                end; {Upper}
       'a','A': ADD;
       'b','B': NEXT(-1);
       'c','C': begin {change}
                 for I:=4 to 17 do OLDVAL[I-3]:=MASK[I].S_FLD;
                 if P_MODE
                  then SCREEN(MASK,True,1,R_OFF-12,0,12,18,MAX_ROW,MAX_COL-40,F_EXIT)
                   else SCREEN(MASK,True,1,R_OFF-4,26,4,11,MAX_ROW,MAX_COL-40,F_EXIT);
                 if F_EXIT=ESC_KEY then  
                   begin
                    for I:=4 to 17 do MASK[I].S_FLD:=OLDVAL[I-3];
                    EXAMINE;
                   end;
                end; {change}
       'd','D': if P_MODE then 
                   begin {delete prompt}
                    X:=IVAL(MASK[FIND('INDEX',MASK)].S_FLD);
                    if (X<1) or (X>NPFLDS)
                      then E_MSG('Illegal prompt number.')
                      else 
                       begin
                        with NEWPROMPTS[X] do ERASEIT(P_ROW,P_COL,length(P_FLD));
                        NEWPROMPTS[X]:=BLNKPROMPT;
                        SORTP(NEWPROMPTS,NPFLDS);
                        DISPLAY;
                       end;
                   end {delete prompt}
                  else
                   begin {Delete field}
                    if MASK[FIND('IDNAME',MASK)].S_FLD='' then
                      E_MSG('Invalid ID Name.')
                     else
                      begin
                       TNAME:=MASK[FIND('IDNAME',MASK)].S_FLD;  EATSPR(TNAME);
                       X:=FIND(TNAME,NEWMASK);
                       if X=0 then E_MSG('ID Name does not exist.')
                       else
                        begin
                         with NEWMASK[X] do ERASEIT(S_ROW,S_COL,S_LEN);
                         NEWMASK[X]:=BLNKREC;
                         SORTRECS(NEWMASK,NFLDS);
                         DISPLAY;
                        end;
                      end;
                   end; {delete field}
       'e','E': EXAMINE;
       'f','F': if P_MODE then 
                 begin  
                  ERASE_PROMPTS(PPROMPTS,R_OFF-12,0,12,18);
                  ERASE_SCREEN(MASK,R_OFF-12,0,12,18);
                  P_MODE:=False;
                  DISPLAY;
                 end;
      'n','N': NEXT(1);
      'p','P': if not P_MODE then
                begin
                 ERASE_PROMPTS(PPROMPTS,R_OFF-4,0,4,11);
                 ERASE_SCREEN(MASK,R_OFF-4,26,4,11);
                 P_MODE:=True;
                 DISPLAY;
                end;
      't','T': begin {Test}
                 if NFLDS=0 then E_MSG('Invalid screen file.')
                  else
                   begin
                    SORTRECS(NEWMASK,NFLDS);
                    CLEAR_HOME ;
                    DISPLAY_PROMPTS(NEWPROMPTS,0,0,0,MAX_ROW);
                    DISPLAY_SCREEN(NEWMASK,0,0,0,MAX_ROW);
                    SCREEN(NEWMASK,True,1,0,0,0,MAX_ROW,MAX_ROW,MAX_COL-40,F_EXIT);
                    CLEAR_HOME ;
                    DISPLAY;
                   end;
                end; {Test}
      end; {case}
     gotoxy(38,11+R_OFF);  read(Keyboard,CH);
     if CH in['A'..'Z','a'..'z'] 
       then 
         begin
         ERASE_EOL(38,11+R_OFF) ;
         write(CH) ;
         end
       else 
         write(ALARM_BELL);
    end; {While}
   for I:=1 to NFLDS do
      with NEWMASK[I] do
        begin
         EATSPR(S_FLD);
         for X:=1 to length(S_FLD) do  if S_FLD[X]=ULINE then S_FLD[X]:=' ';
        end;
   SORTRECS(NEWMASK,NFLDS);
   SORTP(NEWPROMPTS,NPFLDS);
  end; {EDIT_FILE}
  
 Function IVAL (* NUMBER: String): Integer *) ;
  var SUM,I,J,X: Integer;
      CH: Char;
  
   Procedure ERR;
    begin {ERR}
      write(ALARM_BELL);
      IVAL:=0 ;
      exit(IVAL);
    end; {ERR}

  begin {IVAL}
    SUM:=0;  X:=1;
    EATSPR(NUMBER);  EATSPL(NUMBER);
    for I:=1 to length(NUMBER) do
     begin
      CH:=NUMBER[I];
      if CH in['0'..'9'] then SUM:=10*SUM+ord(CH)-ord('0')
       else if (CH='-') and (I=1) then X:=-1
       else if (CH='+') and (I=1) then X:=1
       else ERR; 
      end; {for I}
     IVAL:=SUM*X;  
  end; {IVAL}

 Procedure SORTRECS; (* var A: SCREEN_ARR; var R: Integer*)
  var TREC: FIELD_DEFS;
      J,K,L: Integer;
      CONT: Boolean;
  begin {SORTRECS}
   L:=2;  K:=R;
   repeat  {shaker sort}
    for J:=R downto L do
      if (A[J-1].S_ROW+(A[J-1].S_COL/100))>(A[J].S_ROW+(A[J].S_COL/100)) then
       begin
        TREC:=A[J-1];  A[J-1]:=A[J];  A[J]:=TREC;  K:=J;
       end;
      L:=K+1;
      for J:=L to R do
       if (A[J-1].S_ROW+(A[J-1].S_COL/100))>(A[J].S_ROW+(A[J].S_COL/100)) then
        begin
         TREC:=A[J-1];  A[J-1]:=A[J];  A[J]:=TREC;  K:=J;
        end;
      R:=K-1;
    until L>R; {shaker sort}
    R:=0;  CONT:=True; 
    while CONT do  if R=SCREEN_FIELDS then CONT:=False
      else if A[R+1].S_ROW=END_SCREEN then CONT:=False 
      else R:=R+1;
  end; {SORTRECS}
 
 Procedure SORTP; (* var A: PROMPT_ARR; var R: Integer*)
  var TREC: PROMPT_DEFS;
      J,K,L: Integer;
      CONT: Boolean;
  begin {SORTP}
   L:=2;  K:=R;
   repeat  {shaker sort}
    for J:=R downto L do
      if (A[J-1].P_ROW+(A[J-1].P_COL/100))>(A[J].P_ROW+(A[J].P_COL/100)) then
       begin
        TREC:=A[J-1];  A[J-1]:=A[J];  A[J]:=TREC;  K:=J;
       end;
      L:=K+1;
      for J:=L to R do
       if (A[J-1].P_ROW+(A[J-1].P_COL/100))>(A[J].P_ROW+(A[J].P_COL/100)) then
        begin
         TREC:=A[J-1];  A[J-1]:=A[J];  A[J]:=TREC;  K:=J;
        end;
      R:=K-1;
    until L>R; {shaker sort}
    R:=0;  CONT:=True; 
    while CONT do  if R=SCREEN_FIELDS then CONT:=False
      else if A[R+1].P_ROW=END_SCREEN then CONT:=False 
      else R:=R+1;
  end; {SORTP}
 
 begin {DEFINE}
  INITIALIZE;  SAVED:=True;  CH:='C';
  while (CH<>'Q') and (CH<>'q') do
   begin {while}
    if CH in['c','C','e','E','g','G','p','P','q','Q','s','S'] then
     begin 
      CLEAR_HOME ;
      writeln(RETURN_KEY,' ':30,'SCREEN DEFINITION');
      writeln(' ':30,'=================');
      writeln(' ':30,VERSION);
      gotoxy(26,8);  writeln(CLEARP);
      writeln(' ':26,EDITP);
      writeln(' ':26,GETP);
      writeln(' ':26,PRNTP);
      writeln(' ':26,QUITP);
      writeln(' ':26,SAVEP);
      gotoxy(0,MAX_ROW);  write('SELECTION : _');
     end;
    gotoxy(12,MAX_ROW); read(Keyboard,CH);
    if CH in['a'..'z'] then CH:=chr(ord(CH)+ord('A')-ord('a'));
    if not(CH in['C','E','G','P','Q','S'])
     then write(CURSOR_LEFT,ALARM_BELL)
     else write(CH);
    case CH of
       'C': INITIALIZE;
       'E': EDIT_FILE;
       'G': FILE_IO('G');
       'P': if NFLDS+NPFLDS=0
             then
               begin
                write(ALARM_BELL,'  No prompt or field definitions.');
                read(Keyboard,CH);
               end
              else FILE_IO('P');
       'Q': if not SAVED then
                begin
                 write(ALARM_BELL,
                      '  Do you want to save the current definition file?');
                 while not(CH in['n','y','N','Y']) do read(Keyboard,CH);
                 write(CH);
                 if (CH='n') or (CH='N') then CH:='Q' 
                   else 
                    begin
                     CH:='S';
                     FILE_IO('S');
                    end; {else}
                end;
       'S': if NFLDS+NPFLDS=0
             then
               begin
                write(ALARM_BELL,'  No prompt or field definitions.');
                read(Keyboard,CH);
               end
              else FILE_IO('S');
     end; {case}
   end; {while}
 end. {DEFINE}



========================================================================================
DOCUMENT :usus Folder:VOL25:sh.calc.text
========================================================================================

Function EVAL  (* NUMBER: String): Real  *) ;
 var SUM: Real;
     RIGHT,I,J,X: Integer;
     CH: Char;
 
 begin {EVAL}
   SUM:=0;  X:=1;  EATSPR(NUMBER);  EATSPL(NUMBER);
   for I:=1 to length(NUMBER) do
    begin
     CH:=NUMBER[I];    
     if CH in['0'..'9'] then SUM:=10*SUM+(ord(CH)-48)
      else 
       begin
        if (CH='-') and (I=1) then X:=-1
         else if (CH='+') and (I=1) then X:=1
          else if (CH='.') then   {Decimal part}
           begin
            RIGHT:=10;
            for J:=I+1 to length(NUMBER) do
             begin
              CH:=NUMBER[J];
              if CH in['0'..'9'] then
               begin
                SUM:=SUM + ((ord(CH)-48) / RIGHT);
                RIGHT:=RIGHT*10;
               end {then}
              else write(ALARM_BELL);
             end; {for J}
            EVAL:=SUM*X;  exit(EVAL);
           end {Decimal part}
        else write(ALARM_BELL);
       end; {else}
     end; {for I}
    EVAL:=SUM*X;  exit(EVAL);
 end; {EVAL}

Procedure CALC(var CALC_SCREEN: SCREEN_ARR; 
               FLD,R_OFF,C_OFF: Integer;
               var EFLAG: Boolean);
  var DPART,INDEX,J: Integer; {Integer pointers and temporary storage}
      OP: Char;               {Algebraic operator}
      DPSTR,TEMP: String;     {Temporary string storage}
      OPERAND,ANS: Real;      {Answer returned and temporary operand}
 
 Procedure ERR(OP: Integer);
  { Inform the user he has entered an illegal expression }
  
  begin {ERROR}
   with CALC_SCREEN[FLD] do
    begin
     if OP=1 then S_FLD:='Division by zero.'
      else if OP=2 then S_FLD:='Illegal numeric constant.'
      else if OP=3 then S_FLD:='Result overflow.'
      else S_FLD:='Illegal expression.';
     end; {with}
   EFLAG:=True;
   exit(CALC);    { Return directly to main program }
  end; {ERROR}
  
 begin {CALC}
  with CALC_SCREEN[FLD] do
   begin
    if S_FLD[length(S_FLD)]<>'=' then S_FLD:=concat(S_FLD,'=');
    INDEX:=1;  OP:=' ';  OPERAND:=0;  EFLAG:=False;
    while INDEX<=length(S_FLD) do
     begin
      if S_FLD[INDEX] in['0'..'9','.','-'] then
       begin {Evaluate number string}
        J:=1; TEMP:='                    ';
        while S_FLD[INDEX] in['0'..'9','.'] do
         begin
          TEMP[J]:=S_FLD[INDEX]; INDEX:=INDEX+1;  J:=J+1;
         end; {while}
        OPERAND:=EVAL(TEMP);
       end
      else
       begin
        J:=1;  TEMP:='        ';
        while not(S_FLD[INDEX] in['+','-','*','/','=']) and (J<=8) do
         begin
          TEMP[J]:=S_FLD[INDEX]; INDEX:=INDEX+1;  J:=J+1;
         end; {while}
        EATSPR(TEMP);
        J:=FIND(TEMP,CALC_SCREEN);
        if J=0 then OPERAND:=0 else OPERAND:=EVAL(CALC_SCREEN[J].S_FLD);
       end;
      case OP of
        ' ': ANS:=OPERAND;
        '+': ANS:=ANS + OPERAND;
        '-': ANS:=ANS - OPERAND;
        '*': ANS:=ANS * OPERAND;
        '/': if OPERAND=0 then ERR(4) else ANS:=ANS / OPERAND;
       end; {case}
      if INDEX<=length(S_FLD) then if S_FLD[INDEX] in['+','-','*','/','='] 
       then 
        begin   { Check for operator }
         OP:=S_FLD[INDEX];  
         if OP='=' then INDEX:=length(S_FLD)+1 else INDEX:=INDEX+1;
        end;
     end; {while}
    DPART:=trunc( ABS(ANS-trunc(ANS)) *10000);
    str(trunc(ANS),TEMP);   str(DPART,DPSTR);
    DPSTR:=copy(concat(DPSTR,'00000'),1,S_MIN);
    if length(TEMP)+length(DPSTR)>=40 then ERR(3)
     else S_FLD:=concat(TEMP,'.',DPSTR);
    gotoxy(S_COL+C_OFF,S_ROW+R_OFF);
    if S_JUS='R' then while length(S_FLD)<S_LEN do insert(' ',S_FLD,1);
    write(copy(concat(S_FLD,'          '),1,S_LEN));
   end; {with}
 end; {CALC}
 


========================================================================================
DOCUMENT :usus Folder:VOL25:sh.display.text
========================================================================================

Procedure DISPLAY_SCREEN; (* var SHOW_SCREEN: SCREEN_ARR;
                             ROW_OFFSET,COL_OFFSET,
                             START_ROW,END_ROW:Integer *)
 var INDEX,I:Integer;
     ERRORFLAG: Boolean;

 begin {DISPLAY_SCREEN}
  for INDEX:=1 to SCREEN_FIELDS do
   with SHOW_SCREEN[INDEX] do
    if S_ROW=END_SCREEN then exit(DISPLAY_SCREEN)
     else 
      if (S_ROW+ROW_OFFSET in[0..MAX_ROW]) and
         (S_ROW in[START_ROW..END_ROW]) and
         (S_COL+COL_OFFSET in[0..MAX_COL]) then
        begin
          gotoxy(S_COL+COL_OFFSET,S_ROW+ROW_OFFSET);
          EATSPR(S_DEF);   EATSPR(S_FLD);
          if (length(S_FLD)=0) and (length(S_DEF)>0) and (S_TYP<>'C')
            then if (S_DEF[1]='[') and (S_DEF[length(S_DEF)]=']')
                   then if FIND(copy(S_DEF,2,length(S_DEF)-2),SHOW_SCREEN)>0
                     then S_FLD:=SHOW_SCREEN[FIND(copy(S_DEF,2,length(S_DEF)-2)
                                                 ,SHOW_SCREEN)].S_FLD
                     else S_FLD:=S_DEF
                   else S_FLD:=S_DEF;
          S_FLD:=copy(concat(S_FLD,UNDERLINE),1,S_LEN);
          for I:=1 to length(S_FLD) do
            if S_FLD[I]=' ' then S_FLD[I]:=ULINE;
          write(S_FLD);
         end;
  end;  {DISPLAY_SCREEN}
          
 Procedure DISPLAY_PROMPTS; (* var P_ARRAY: PROMPT_ARR;
                              ROW_OFFSET,COL_OFFSET,
                              START_ROW,END_ROW:Integer *)
  var INDEX: Integer;
  
  begin {DISPLAY_PROMPTS}
   for INDEX:=1 to PROMPT_FIELDS do
    with P_ARRAY[INDEX] do
      if (P_ROW+ROW_OFFSET in[0..MAX_ROW]) and 
         (P_ROW in[START_ROW..END_ROW]) and
         (P_COL+COL_OFFSET in[0..MAX_COL]) then 
           begin
             gotoxy(P_COL+COL_OFFSET,P_ROW+ROW_OFFSET);
             write(P_FLD); 
            end
        else if P_ROW=END_SCREEN then exit(DISPLAY_PROMPTS);
  end; {DISPLAY_PROMPTS}
           
 Procedure ERASE_SCREEN; (* var E_SCREEN:SCREEN_ARR;
                            ROW_OFFSET,COL_OFFSET,
                            START_ROW,END_ROW:Integer *)
  var INDEX,LEN:Integer;
    
  begin {ERASE_SCREEN}
   for INDEX:=1 to SCREEN_FIELDS do
    with E_SCREEN[INDEX] do
      if (S_ROW+ROW_OFFSET in[0..MAX_ROW]) and
         (S_ROW in[START_ROW..END_ROW]) and
         (S_COL+COL_OFFSET in [0..MAX_COL]) then
        begin
         gotoxy(S_COL+COL_OFFSET,S_ROW+ROW_OFFSET);
         for LEN:=1 to S_LEN do write(' ');
        end
       else if S_ROW=END_SCREEN then exit(ERASE_SCREEN);
  end; {ERASE_SCREEN}
    
 Procedure ERASE_PROMPTS; (* var P_ARRAY:PROMPT_ARR;
                            ERASE_OFFSET,START_ROW,END_ROW:Integer *)
  var INDEX,LEN: Integer;
    
  begin {ERASE_PROMPTS}
   for INDEX:=1 to PROMPT_FIELDS do
    with P_ARRAY[INDEX] do
      if (P_ROW+ROW_OFFSET in[0..MAX_ROW]) and
         (P_ROW in[START_ROW..END_ROW]) and
         (P_COL+COL_OFFSET in [0..MAX_COL]) then 
           begin
             gotoxy(P_COL+COL_OFFSET,P_ROW+ROW_OFFSET);
             for LEN:=1 to length(P_FLD) do write(' ');
           end
       else if P_ROW=END_SCREEN then exit(ERASE_PROMPTS);
  end; {ERASE_PROMPTS}


========================================================================================
DOCUMENT :usus Folder:VOL25:sh.field.text
========================================================================================

  Procedure EATSPL;   (* var F_FLD: STRING *)
   { Local procedure that removes all spaces on the left end of string F_FLD. }

    begin {EATSPL}
      repeat
       if length(F_FLD)=0 then exit(EATSPL)
        else if (F_FLD[1]=' ') or (F_FLD[1]=ULINE) then delete(F_FLD,1,1)
        else exit(EATSPL);
      until False;
    end; {EATSPL}

  Procedure EATSPR; (* var F_FLD: STRING *)
  { Local procdeure that removes all spaces on the right side of string F_FLD.}
   
     begin {EATSPR}
       repeat
        if length(F_FLD)=0 then exit(EATSPR)
         else if (F_FLD[length(F_FLD)]=' ') or (F_FLD[length(F_FLD)]=ULINE)
            then delete(F_FLD,length(F_FLD),1)
          else exit(EATSPR);
       until False;
     end;  {EATSPR}
       
  Procedure FIELD;
   var CHAR_POSITION,TEMP_CHAR,MAX_CHAR,CHAR_INDEX,CHAR_COUNT: Integer;
       F_ERROR,EXIT_FLAG: Boolean;
       ULCHAR: String[1];
       F_INPUT: Char;
  
  Procedure INIT_FIELD(var F_FLD:STRINGFL;
                       F_LEN,F_E_COL,F_E_ROW:Integer;
                       F_JUS:Char);
    {Local procedure that initilizes the data field and some other variables}
   
   begin {INIT}
    if (F_E_ROW<0) or (F_E_ROW>MAX_ROW) then F_E_ROW:=MAX_ROW;
    if (F_E_COL<0) or (F_E_COL>MAX_COL) then F_E_COL:=MAX_COL-40;
    if (F_JUS='L') or (F_AN='N')  then
      begin
       EATSPL(F_FLD);
       F_FLD:=copy(concat(F_FLD,UNDERLINE),1,F_LEN);
      end
     else if F_JUS='R' then
      begin
       EATSPR(F_FLD);
       while length(F_FLD)<F_LEN do insert(ULCHAR,F_FLD,1);
      end
     else F_FLD:=copy(concat(F_FLD,UNDERLINE),1,F_LEN);     
    for CHAR_POSITION:=1 to F_LEN do
       if F_FLD[CHAR_POSITION]=' ' then F_FLD[CHAR_POSITION]:=ULINE;
    MAX_CHAR:=F_LEN;
   end;  {INIT}
  
  Procedure UPDATE(var F_FLD: STRINGFL;
                     F_SKIP: Boolean;
                     F_LEN,F_E_COL,F_E_ROW: Integer;
                     F_AN: Char);
              
    begin {UPDATE}
     if CHAR_POSITION=F_LEN then 
       begin
        write(ALARM_BELL);
        CHAR_POSITION:=CHAR_POSITION-1;
       end;
     if F_INPUT=' ' then F_INPUT:=ULINE;
     F_ERROR:=False;
     if (F_INPUT=ULINE)  or
        ((F_INPUT in['0'..'9','+','-','.']) and (F_AN='N'))
                       or
        ((F_INPUT in['A'..'Z','a'..'z','-','.']) and (F_AN='L'))
                       or
        ((F_INPUT in['A'..'Z','a'..'z','-','.','+','0'..'9']) and (F_AN='A'))
                       or
        ((F_INPUT in[' '..'~']) and (F_AN='S'))
       then
         begin
          gotoxy(F_COL+CHAR_POSITION,F_ROW);
          write(F_INPUT);
          F_FLD[CHAR_POSITION+1]:=F_INPUT;
          CHAR_POSITION:=CHAR_POSITION+1;
          if (F_SKIP) and (CHAR_POSITION>=F_LEN) then F_INPUT:=CURSOR_RIGHT;
         end
       else 
         begin
           F_ERROR:=True;
           gotoxy(F_E_COL,F_E_ROW);
           write(ALARM_BELL,'ERROR: ');
           if not (F_AN in['A','L','N','S']) then F_AN:='S';
           case F_AN of 
             'A' : write('Alphanumeric character required.');
             'L' : write('Alphabetic letter required.');
             'N' : write('Numeric character required.');
             'S' : write('Illegal character.');
            end; {case}
        end; {else}
   end; {UPDATE}

   begin {FIELD}
    ULCHAR:=' ';  ULCHAR[1]:=ULINE;
    INIT_FIELD(F_FLD,F_LEN,F_E_COL,F_E_ROW,F_JUS);
    CHAR_POSITION:=0;
    gotoxy(F_COL,F_ROW);  write(F_FLD);
    gotoxy(F_COL,F_ROW);
    F_ERROR:=True;
    repeat
      EXIT_FLAG:=False;
      repeat
        if CHAR_POSITION<F_LEN then gotoxy(F_COL+CHAR_POSITION,F_ROW)
           else gotoxy(F_COL+CHAR_POSITION-1,F_ROW);
        read(Keyboard,F_INPUT);
        if eoln(Keyboard) then F_INPUT:=RETURN_KEY;
        if F_ERROR then 
          begin
            ERASE_EOL(F_E_COL,F_E_ROW);
            F_ERROR:=False;
           end;
        if F_INPUT in[' '..'~']
          then UPDATE(F_FLD,F_SKIP,F_LEN,F_E_COL,F_E_ROW,F_AN);
       {case F_INPUT of }
        if F_INPUT=CURSOR_LEFT then 
           if CHAR_POSITION>0 then CHAR_POSITION:=CHAR_POSITION-1
            else EXIT_FLAG:=True
         else if F_INPUT=CURSOR_RIGHT then
            if CHAR_POSITION+1<F_LEN then CHAR_POSITION:=CHAR_POSITION+1
              else EXIT_FLAG:=True
         else if F_INPUT=DEL_KEY then 
           begin
            delete(F_FLD,CHAR_POSITION+1,1);
            F_FLD:=concat(F_FLD,ULCHAR);
           end
         else if F_INPUT=INS_KEY then 
           begin
            F_FLD:=copy(F_FLD,1,length(F_FLD)-1);
            insert(ULCHAR,F_FLD,CHAR_POSITION+1);
            MAX_CHAR:=MAX_CHAR+1;
           end
         else if F_INPUT in[C_CLEAR_HOME,C_HOME,ENTER_KEY,TAB_LEFT,TAB_SKIP,
                            TAB_RIGHT,CURSOR_UP,ERASE_INPUT,CURSOR_DOWN,
                            RETURN_KEY]
                     then EXIT_FLAG:=True
         else if F_INPUT=ESC_KEY then
           begin
            F_EXIT:=F_INPUT;
            F_FLD:='';
            exit(FIELD);
           end       
         else if F_INPUT=ERASE_FIELD then 
           begin
            F_FLD:=UNDERLINE;
            CHAR_POSITION:=0;
           end;
        if CHAR_POSITION>MAX_CHAR then MAX_CHAR:=CHAR_POSITION;
        if MAX_CHAR>F_LEN then MAX_CHAR:=F_LEN;
        gotoxy(F_COL,F_ROW);
        write(copy(concat(F_FLD,UNDERLINE),1,MAX_CHAR));
      until EXIT_FLAG=True;
     CHAR_COUNT:=0;
     for CHAR_INDEX:=1 to F_LEN do
       if F_FLD[CHAR_INDEX]<>ULINE then CHAR_COUNT:=CHAR_COUNT+1;
     if CHAR_COUNT<F_MIN then 
        begin
         F_ERROR:=True;
         gotoxy(F_E_COL,F_E_ROW);
         write(ALARM_BELL,'ERROR: Minimun input is ',F_MIN);
        end
       else F_ERROR:=False;
    until F_ERROR=False;
    if F_JUS='L' then 
      begin
       EATSPL(F_FLD);
       F_FLD:=copy(concat(F_FLD,UNDERLINE),1,F_LEN);
      end
     else if F_JUS='R' then 
      begin
       EATSPR(F_FLD);
       while length(F_FLD)<F_LEN do insert(ULCHAR,F_FLD,1);
      end
     else F_FLD:=copy(concat(F_FLD,UNDERLINE),1,F_LEN);
   gotoxy(F_COL,F_ROW);
   write(copy(F_FLD,1,F_LEN));
   for CHAR_POSITION:=1 to F_LEN do
     if F_FLD[CHAR_POSITION]=ULINE then F_FLD[CHAR_POSITION] := ' ';
   F_FLD:=copy(F_FLD,1,F_LEN);
   F_EXIT:=F_INPUT;
 end; {FIELD}



========================================================================================
DOCUMENT :usus Folder:VOL25:sh.init.text
========================================================================================

begin { One time initialization and termination code. }
   
   { Look up the values for standard keys. }
   CURSOR_RIGHT     := chr(0) ;
   CURSOR_LEFT      := chr(0) ;
   CURSOR_DOWN      := chr(0) ;
   CURSOR_UP        := chr(0) ;
   ESC_KEY          := chr(0) ;
   ERASE_INPUT      := chr(0) ;
   ENTER_KEY        := chr(0) ;
   for C := chr(0) to chr(255) do
     begin
     ch := c ;
     case sc_map_crt_command( ch ) of
       sc_right_key      : CURSOR_RIGHT      := ch ;
       sc_backspace_key,
       sc_left_key       : CURSOR_LEFT       := ch ;
       sc_down_key       : CURSOR_DOWN       := ch ;
       sc_up_key         : CURSOR_UP         := ch ;
       sc_escape_key     : ESC_KEY           := ch ;
       sc_del_key        : ERASE_INPUT       := ch ;
       sc_etx_key        : ENTER_KEY         := ch ;
       sc_not_legal      :  { Null statement }     ;
       end ; { case sc_map_crt_command( ch ) of }
     end ; { for C in [chr(0)..chr(255)] do }
   
   sc_use_info( sc_get, info_rec ) ;
   with info_rec do
     begin
     THE_DATE := sc_date ;
     with misc_info do
       begin
       MAX_COL := width;
       MAX_ROW := height;
       end ; { with misc_info do }
     end ; { with info_rec do }


{ The following characters are standard ASCII. }
  ALARM_BELL   :=chr(7);
  FORM_FEED    :=chr(12);
  LINE_KEY     :=chr(10);
  RETURN_KEY   :=chr(13);
  TAB_SKIP     :=chr(9);
  
  { The following characters are (possibly) unique to the TI-911. }
  C_CLEAR_HOME :=chr(12);
  C_HOME       :=chr(130);
  DEL_KEY      :=chr(132);
  ERASE_FIELD  :=chr(128);
  INS_KEY      :=chr(134);
  TAB_LEFT     :=chr(135);
  TAB_RIGHT    :=chr(140);
  
(*
  { Enter the values for standard keys since we can't fetch them properly. }
   CURSOR_RIGHT     := chr(0) ;
   CURSOR_LEFT      := chr(0) ;
   CURSOR_DOWN      := chr(0) ;
   CURSOR_UP        := chr(0) ;
   ESC_KEY          := chr(0) ;
   ERASE_INPUT      := chr(0) ;
   ENTER_KEY        := chr(0) ;
*)
   
  if (MAX_COL=79) and (MAX_ROW=23) then ULINE:=chr(223) else ULINE:='_';
 {$R-}
  UNDERLINE[0]:=chr(MAX_FLEN);
  fillchar(UNDERLINE[1],MAX_FLEN,ULINE);
 {$R+}
 
 ***; { End of unit initialization. }
 
 

========================================================================================
DOCUMENT :usus Folder:VOL25:sh.save.text
========================================================================================

Segment Procedure SAVE_PHILE( SAVE_NAME    : String;
                          var SAVE_SCREEN  : SCREEN_ARR;
                          var SAVE_PROMPTS : PROMPT_ARR;
                          var SAVE_RESULT  : Integer ) ;
 var INDEX: Integer;

 begin {SAVE_PHILE}
  {$I-}
  rewrite(FILE_TO_GET,SAVE_NAME);
  SAVE_RESULT:=IO_RESULT;
  {$I+}
  if SAVE_RESULT=0 then
    begin {save}
     seek(FILE_TO_GET,0); get(FILE_TO_GET);
     INDEX:=1;
     while INDEX<=SCREEN_FIELDS do  {Sep 23 to correct for 40 fields}
       IF SAVE_PROMPTS[INDEX].P_ROW=END_SCREEN THEN INDEX:=SCREEN_FIELDS+1
       ELSE BEGIN
         FILE_TO_GET^.TAG:=True;
         FILE_TO_GET^.P[1]:=SAVE_PROMPTS[INDEX];
         INDEX:=INDEX+1;
         FILE_TO_GET^.P[2]:=SAVE_PROMPTS[INDEX];
         INDEX:=INDEX+1;
         put(FILE_TO_GET);
       end;
     INDEX:=1;
     while INDEX<=SCREEN_FIELDS do  {Sep 23 to correct for 40 fields}
      IF SAVE_SCREEN[INDEX].S_ROW=END_SCREEN THEN INDEX:=SCREEN_FIELDS+1
      ELSE begin
       FILE_TO_GET^.TAG:=False;
       FILE_TO_GET^.S:=SAVE_SCREEN[INDEX];
       INDEX:=INDEX+1;
       put(FILE_TO_GET);
      end; {while}
     close(FILE_TO_GET,lock);
    end; {save}
 end; {SAVE_PHILE}
{xL-}


========================================================================================
DOCUMENT :usus Folder:VOL25:sh.screen.text
========================================================================================

UNIT SCREEN40;{$l printer:}

INTERFACE
{ Screen handler compilation unit version II.2.B.40 }


{ THIS VERSION FOR UCSD PASCAL VERSION IV.0 }


const END_SCREEN    = 9999;      { Signals end of a screen file }
      MAX_FLEN      = 40;        { Maximum length of prompt or data field }
      LEN_ID        = 8;         { Maximum length of an ID Name }
      SCREEN_FIELDS = 40;        { Maximum number of screen fields }
      PROMPT_FIELDS = 40;        { Maximum number of prompt fields }
 
type STRINGFL = STRING[MAX_FLEN];
     STR_ID = STRING[LEN_ID];
     FIELD_DEFS = Packed Record
         S_ID : STR_ID;
         S_ROW,S_COL,S_LEN,S_MIN: Integer;
         S_TYP,S_JUS,S_NA : Char;
         S_SKIP: Boolean;
         S_DEF,S_FLD: STRINGFL;
       end;
     PROMPT_DEFS = Packed Record
         P_ROW,P_COL : Integer;
         P_FLD : STRINGFL;
       end;
     SCREEN_ARR = Packed Array[1..SCREEN_FIELDS] of FIELD_DEFS;
     PROMPT_ARR = Packed Array[1..PROMPT_FIELDS] of PROMPT_DEFS;
     SCREEN_REC = Packed record case TAG: Boolean of
                     False : (S:FIELD_DEFS);
                     True  : (P:Packed array[1..2] of PROMPT_DEFS)
                   end;
     T_THE_DATE = Packed Record
       month    : 0..12 ;
       day      : 0..31 ;
       year     : 0..99 ;
       end ;

var 
  ALARM_BELL   : Char;
  CURSOR_DOWN  : Char;
  CURSOR_LEFT  : Char;
  CURSOR_RIGHT : Char;
  CURSOR_UP    : Char;
  DEL_KEY      : Char;
  ENTER_KEY    : Char;
  ERASE_FIELD  : Char;
  ERASE_INPUT  : Char;
  ESC_KEY      : Char;
  FORM_FEED    : Char;
  INS_KEY      : Char;
  LINE_KEY     : Char;
  RETURN_KEY   : Char;
  TAB_LEFT     : Char;
  TAB_RIGHT    : Char;
  TAB_SKIP     : Char;
  ULINE        : Char;
  
  FILE_TO_GET  : File of SCREEN_REC;
  MAX_ROW      : Integer;
  MAX_COL      : Integer;
  THE_DATE     : T_THE_DATE ;
  UNDERLINE    : STRINGFL;
    
      
      
Function FIND(FIELD_ID: STR_ID;                     { Field ID to find }
              var FIND_SCREEN: SCREEN_ARR           { Screen array to search }
              ): Integer;                           { Zero returned if field
                                                       not found }

Procedure EATSPL(var F_FLD: String);  { String to shorten }

Procedure EATSPR(var F_FLD: String);  { String to shorten }

Procedure FIELD(    F_ROW :Integer;   { Field row }
                var F_COL :Integer;   { Field column }
                    F_E_ROW,          { Field error row }
                    F_E_COL,          { Field error column }
                    F_LEN,            { Field length }
                    F_MIN :Integer;   { Minimum field length }
                var F_EXIT:Char;      { Exit character }
                    F_JUS,            { Justify, L)eft, R)ight or N)one }
                    F_AN: Char;       { L)etter, N)umeric, A)lpha, S)pecial }
                var F_FLD:STRINGFL;   { Input and output string }
                    F_SKIP:Boolean);  { Exit at end of field flag }
                
Procedure GET_FILE(    GET_NAME: String;          { File name to get }
                   var GET_SCREEN: SCREEN_ARR;    { Screen to load }
                   var GET_PROMPTS: PROMPT_ARR;   { Prompts to load }
                   var GET_RESULT: Integer);      { IO return code }

Procedure SAVE_FILE(    SAVE_NAME: String;          { File name to save }
                    var SAVE_SCREEN: SCREEN_ARR;    { Screen to save }
                    var SAVE_PROMPTS: PROMPT_ARR;   { Prompts to save }
                    var SAVE_RESULT: Integer);      { IO return code }

Procedure SCREEN(var RUNING_SCREEN: SCREEN_ARR;{ Screen to run }
                     WRAP: Boolean;            { Wrapping option On or Off }
                     START_FIELD,              { Field to position cursor }
                     ROW_OFFSET,               { Row offset }
                     COL_OFFSET,               { Column offset }
                     START_ROW,                { Starting data field row }
                     END_ROW,                  { Ending data field row }
                     ERROR_ROW,                { Error row }
                     ERROR_COL: Integer;       { Error column }
                 var F_EXIT: Char);            { Key pressed to exit }

Procedure DISPLAY_SCREEN(var SHOW_SCREEN: SCREEN_ARR;  { Screen to display }
                         ROW_OFFSET,               { Row offset }
                         COL_OFFSET,               { Column offset }
                         START_ROW,                { Starting data field row }
                         END_ROW: Integer);        { Ending data field row }

Procedure DISPLAY_PROMPTS(var P_ARRAY: PROMPT_ARR;     { Prompts to display }
                          ROW_OFFSET,              { Row offset }
                          COL_OFFSET,              { Column offset }
                          START_ROW,               { Starting prompt row }
                          END_ROW: Integer);       { Ending prompt row }

Procedure ERASE_SCREEN(var E_SCREEN: SCREEN_ARR;    { Screen to erase }
                           ROW_OFFSET,          { Row offset }
                           COL_OFFSET,          { Column offset }
                           START_ROW,           { First data field row to erase}
                           END_ROW: Integer);   { Last data field row to erase }

Procedure ERASE_PROMPTS(var P_ARRAY: PROMPT_ARR;   { Prompts to erase }
                            ROW_OFFSET,            { Row offset }
                            COL_OFFSET,            { Column offset }
                            START_ROW,             { First prompt row to erase }
                            END_ROW: Integer);     { Last prompt row to erase }

Procedure CLEAR_HOME ;
Procedure ERASE_EOL( X:integer ; Y:integer ) ;
Procedure ERASE_EOS( X:integer ; Y:integer ) ;
Procedure HOME ;


IMPLEMENTATION

USES {$U SCREENOPS.CODE } SCREENOPS ;

var
  C            : Char ;
  C_CLEAR_HOME : Char ;
  C_HOME       : Char ;
  CH           : Char ;
  INFO_REC     : sc_info_type ;

{$I SH.SAVE.TEXT}


Segment Procedure GET_PHILE(    
                       GET_NAME: String;          { File name to get }
                   var GET_SCREEN: SCREEN_ARR;    { Screen to load }
                   var GET_PROMPTS: PROMPT_ARR;   { Prompts to load }
                   var GET_RESULT: Integer);      { IO return code }

  var I,NFLDS,NP: Integer;

  begin {GET_PHILE}
   {$I-}
    reset(FILE_TO_GET,GET_NAME);
    GET_RESULT:=IO_RESULT;
    if GET_RESULT <> 0 then
      begin {open error}
       close(FILE_TO_GET);
       exit(GET_PHILE);
      end;{open error}
    seek(FILE_TO_GET,0);  get(FILE_TO_GET);
    GET_RESULT:=IO_RESULT;
    NFLDS:=0;  NP:=0;
    while not eof(FILE_TO_GET) do
     begin
      if IO_RESULT<>0 then
        begin {wierd error}
          GET_RESULT:=IO_RESULT;
          close(FILE_TO_GET);
          exit(GET_PHILE);
        end; {wierd error}
      if FILE_TO_GET^.TAG then
        begin {read prompt data}
          if NP=PROMPT_FIELDS then
            begin
              GET_RESULT:=15;  exit(GET_PHILE);
            end;
          NP:=NP+1; GET_PROMPTS[NP]:=FILE_TO_GET^.P[1];
          EATSPR(GET_PROMPTS[NP].P_FLD);
          NP:=NP+1; GET_PROMPTS[NP]:=FILE_TO_GET^.P[2];
          EATSPR(GET_PROMPTS[NP].P_FLD);
         end {read prompt data}
       else
          begin {read field data}
            if NFLDS=SCREEN_FIELDS then
               begin
                 GET_RESULT:=15;  exit(GET_PHILE);
               end;
            NFLDS:=NFLDS+1;
            GET_SCREEN[NFLDS]:=FILE_TO_GET^.S;
          end; {read field data}
      get(FILE_TO_GET);
      GET_RESULT:=IO_RESULT;
    end; {while}
    for I:=NFLDS+1 to SCREEN_FIELDS do GET_SCREEN[I].S_ROW:=END_SCREEN;
    for I:=NP+1 to PROMPT_FIELDS do GET_PROMPTS[I].P_ROW:=END_SCREEN;
    close(FILE_TO_GET);
   {$I+}
  end; {GET_PHILE}

Procedure GET_FILE(*
                       GET_NAME: String;          { File name to get }
                   var GET_SCREEN: SCREEN_ARR;    { Screen to load }
                   var GET_PROMPTS: PROMPT_ARR;   { Prompts to load }
                   var GET_RESULT: Integer*);     { IO return code }
BEGIN
                   
  GET_PHILE( GET_NAME,    { File name to get }
             GET_SCREEN,  { Screen to load }
             GET_PROMPTS, { Prompts to load }
             GET_RESULT );{ IO return code }

END ; { GET_FILE }


Procedure SAVE_FILE(*   SAVE_NAME: String;          { File name to save }
                    var SAVE_SCREEN: SCREEN_ARR;    { Screen to save }
                    var SAVE_PROMPTS: PROMPT_ARR;   { Prompts to save }
                    var SAVE_RESULT: Integer*);     { IO return code }
begin

  SAVE_PHILE(   SAVE_NAME,      { File name to save }
                SAVE_SCREEN,    { Screen to save }
                SAVE_PROMPTS,   { Prompts to save }
                SAVE_RESULT ) ; { IO return code }

end ;

Function FIND; (* FIELD_ID: STR_ID; var FIND_SCREEN:SCREEN_ARR): Integer *)
 var FIND_INDEX: Integer;
 
 begin {FIND}
  FIND_INDEX:=1;  FIND:=0;
  while FIND_SCREEN[FIND_INDEX].S_ROW<>END_SCREEN do
   begin {while}
    if FIELD_ID=FIND_SCREEN[FIND_INDEX].S_ID
     then
      begin
       FIND:=FIND_INDEX; exit(FIND);
      end;
    if FIND_INDEX=SCREEN_FIELDS then exit(FIND) else FIND_INDEX:=FIND_INDEX+1;
   end; {while}
 end; {FIND}

{$I SH.FIELD.TEXT}

{$I SH.DISPLAY.TEXT} 
 
 Procedure SCREEN; (* var RUNING_SCREEN: SCREEN_ARR;
                      ROW_OFFSET,COL_OFFSET,START_ROW,END_ROW,
                      ERROR_COL,ERROR_ROW: Integer;    
                  var F_EXIT: Integer *)
  var FLD1,FLD2,RTEMP_COL,RTEMP_ROW,R_T_COL,RUN_INDEX: Integer;
      FIELD_ERROR,EXIT_RUN: Boolean;
  

  Procedure COUNT_FIELDS(var COUNT_SCREEN:SCREEN_ARR; 
                         var TOP_ROW,END_ROW,START_FLD,END_FLD:Integer);
  
   begin {COUNT}
     START_FLD:=1;  
     while COUNT_SCREEN[START_FLD].S_ROW<TOP_ROW do
       if (START_FLD=SCREEN_FIELDS)
       or (COUNT_SCREEN[START_FLD].S_ROW=END_SCREEN)
        then exit(SCREEN) else START_FLD:=START_FLD+1;
     END_FLD:=START_FLD;
     while COUNT_SCREEN[END_FLD].S_ROW<=END_ROW do
       if (END_FLD=SCREEN_FIELDS)
           or (COUNT_SCREEN[END_FLD].S_ROW=END_SCREEN)
         then exit(COUNT_FIELDS) else END_FLD:=END_FLD+1;
     if END_FLD>1 then END_FLD:=END_FLD-1 else exit(SCREEN);
   end; {COUNT}

  Procedure CHECK_INPUT(var CHECK_SCREEN:SCREEN_ARR; {Screen being checked }
                        var CHECK_START,
                            CHECK_END,
                            CHECK_E_COL,             {Error message column }
                            CHECK_E_ROW:Integer;     {Error message row }
                        var CHECK_ERROR:Boolean;     {Set true if error found }
                        var CHECK_INDEX:Integer);    {Index of field with error }
  
   var NUM_CHAR,CHAR_INDEX: Integer;
       KEY_IN:Char;
   
   begin {CHECK INPUT}
    CHECK_INDEX:=CHECK_START;
    CHECK_ERROR:=False;
    while (not CHECK_ERROR) and (CHECK_INDEX<=CHECK_END) do
     begin
      with CHECK_SCREEN[CHECK_INDEX] do
       begin
        if S_TYP<>'C' then
          begin
            NUM_CHAR:=0;
            for CHAR_INDEX:=1 to length(S_FLD) do
              if S_FLD[CHAR_INDEX]=ULINE then S_FLD[CHAR_INDEX]:=' ' 
                else NUM_CHAR:=NUM_CHAR+1;
            if (NUM_CHAR<S_MIN) then
              begin
               CHECK_ERROR := True;
               gotoxy(CHECK_E_COL,CHECK_E_ROW);
               write(ALARM_BELL,'ERROR: Minimum input is ',S_MIN,' Character(s)')
              end
             else CHECK_ERROR:=False;
          end; {if S_LEN}
       end; {with}
      CHECK_INDEX:=CHECK_INDEX+1;
     end; {while}
    CHECK_INDEX:=CHECK_INDEX-1;
   end; {CHECK INPUT}
  
  Procedure NEXTFIELD(var FIELDNO: Integer;  DIRECTION: Integer);
   begin {NEXTFIELD}
    repeat 
     FIELDNO:=FIELDNO+DIRECTION;
     if FIELDNO>FLD2 then 
         begin
           FIELDNO:=FLD1;
           if not WRAP then EXIT_RUN:=True;
         end
       else if FIELDNO<FLD1 
             then
              begin
                FIELDNO:=FLD2;
                if not WRAP then EXIT_RUN:=True;
              end;
    until RUNING_SCREEN[FIELDNO].S_TYP<>'C';
   end; {NEXTFIELD}
   
  begin {SCREEN}
   if END_ROW+ROW_OFFSET>MAX_ROW then END_ROW:=MAX_ROW-ROW_OFFSET;
   if START_ROW+ROW_OFFSET<0 then START_ROW:=-ROW_OFFSET;
   COUNT_FIELDS(RUNING_SCREEN,START_ROW,END_ROW,FLD1,FLD2);
   if FLD1>START_FIELD then START_FIELD:=FLD1;
   RUN_INDEX:=START_FIELD;
   FIELD_ERROR:=False;
   repeat
    EXIT_RUN:=False;
    repeat
     with RUNING_SCREEN[RUN_INDEX] do
      begin
       R_T_COL:=S_COL+COL_OFFSET;
       if S_TYP='C' then F_EXIT:=TAB_SKIP
        else 
         begin
           EATSPR(S_FLD);  
           if (S_FLD='') and (S_DEF>'') and (S_TYP<>'C')
             then if (S_DEF[1]='[') and (length(S_DEF)<=LEN_ID+2)
               then S_FLD:=RUNING_SCREEN[FIND(copy(S_DEF,2,length(S_DEF)-2),RUNING_SCREEN)].S_FLD
                else S_FLD:=S_DEF;
           FIELD(S_ROW+ROW_OFFSET,R_T_COL,ERROR_ROW,ERROR_COL,S_LEN,S_MIN,
                 F_EXIT,S_JUS,S_NA,S_FLD,S_SKIP);
         end; {else}
      end; {with}
     if FIELD_ERROR=True
       then 
         ERASE_EOL(ERROR_COL,ERROR_ROW);
     {case F_EXIT of }
     if F_EXIT in[TAB_SKIP,CURSOR_RIGHT,TAB_RIGHT] then NEXTFIELD(RUN_INDEX,1)
      else if F_EXIT in[TAB_LEFT,CURSOR_LEFT] then NEXTFIELD(RUN_INDEX,-1)
      else if F_EXIT=CURSOR_DOWN then
         begin
          with RUNING_SCREEN[RUN_INDEX] do
           begin
            RTEMP_ROW:=S_ROW;
            RTEMP_COL:=S_COL;
           end;
          repeat
           NEXTFIELD(RUN_INDEX,1);
           if RUN_INDEX=FLD1 then RTEMP_ROW:=-1;
          until (RUNING_SCREEN[RUN_INDEX].S_ROW>RTEMP_ROW)
                           and
                 (RUNING_SCREEN[RUN_INDEX].S_COL>=RTEMP_COL);
         end
      else if F_EXIT=CURSOR_UP then
          begin
           with RUNING_SCREEN[RUN_INDEX] do
            begin
             RTEMP_ROW:=S_ROW;
             RTEMP_COL:=S_COL;
            end;
           repeat
            NEXTFIELD(RUN_INDEX,-1);
            if RUN_INDEX=FLD2 then RTEMP_ROW:=MAX_ROW+1;
           until (RUNING_SCREEN[RUN_INDEX].S_ROW<RTEMP_ROW)
                           and
                 (RUNING_SCREEN[RUN_INDEX].S_COL<=RTEMP_COL);
          end
       else if F_EXIT=RETURN_KEY then 
          begin
           RTEMP_ROW:=RUNING_SCREEN[RUN_INDEX].S_ROW;
           repeat
            NEXTFIELD(RUN_INDEX,1);
            if RUN_INDEX=FLD1 then RTEMP_ROW:=0;
           until (RUNING_SCREEN[RUN_INDEX].S_ROW>RTEMP_ROW);
          end
       else if F_EXIT=ERASE_INPUT then 
          begin
           for RUN_INDEX:=FLD1 to FLD2 do
            with RUNING_SCREEN[RUN_INDEX] do if S_TYP<>'C' then S_FLD:='';
           DISPLAY_SCREEN(RUNING_SCREEN,ROW_OFFSET,COL_OFFSET,START_ROW,END_ROW);
           RUN_INDEX:=START_FIELD;
          end
       else if F_EXIT=C_HOME then RUN_INDEX:=FLD1
       else if F_EXIT=ENTER_KEY then EXIT_RUN:=True
       else if F_EXIT=ESC_KEY   then exit(SCREEN)
       else write(ALARM_BELL);
    until EXIT_RUN=True;
    CHECK_INPUT(RUNING_SCREEN,FLD1,FLD2,ERROR_COL,ERROR_ROW,FIELD_ERROR,RUN_INDEX);
   until FIELD_ERROR=False;
  end; {SCREEN}

Procedure CLEAR_HOME ;
begin
  sc_home ;
  sc_clr_screen ;
end ;

Procedure ERASE_EOL{ X:integer ; Y:integer } ;
begin
  sc_erase_to_eol( x, y ) ;
end ;

Procedure ERASE_EOS{ X:integer ; Y:integer } ;
begin
  sc_eras_eos( x, y ) ;
end ;

Procedure HOME ;
begin
  sc_home ;
end ;


{$I SH.INIT.TEXT}

end. {UNIT}



========================================================================================
DOCUMENT :usus Folder:VOL25:ud.copy.text
========================================================================================

{xL #5:CPYLST.TEXT }

PROGRAM COPY_DATA_FILE;

{ Author       : Mike Smith
  Date written : July 23, 1981
  Revision     :

  This program copies records from one data file to another

  Files required: UDE SCRN and TEXT files to copy from and
                  SCRN and TEXT files to copy to. The program
                  will create the TEXT file to copy to if it does
                  not already exist.

  Method: After opening the required files, the program prompts the
          the user for information regarding which records of the
          "from" data file are to be copied. The program then does the
          following in a loop until the end of either data file is reached.
          A record is read from the "from" data file and the fields
          of that record are loaded into OLD_FIELDS. If it is decided
          that that record is to be copied, the proper fields are
          copied from OLD_FIELDS to NEW_FIELDS. The NEW_FIELDS are
          put in the proper format and written out to a buffer to be
          written to disk when full.                                       }

USES {$U SH.SCREEN.UNIT} SCREEN40;

CONST
  SCREEN_TESTS = 13;
  MAX_TESTS    = 52;
  MAX_INT      = 32767;
  MAX_REC_LEN  = 255;

TYPE
  MAP_REC  = RECORD
               OLD_FLD_NO : INTEGER;
               SET_TYPE   : CHAR;
             END;
  OPS      = (LT,GT,EQ,LE,GE,NE);
  TEST_REC =  PACKED RECORD
                FIELD_LOC  : 0..SCREEN_FIELDS;
                OPERATOR   : OPS;
                VALUE      : STRINGFL;
              END;
  GENFILE = FILE OF PACKED RECORD
    CASE INTEGER OF
    0:(NFLDS,RSIZE,NRECS,LIM : INTEGER);
    1:(DATA : STRING[MAX_REC_LEN]);
    END;
  MAP_DEF = ARRAY[1..SCREEN_FIELDS] OF MAP_REC;
  TEST_DEF = ARRAY[1..MAX_TESTS] OF TEST_REC;
  STRING2   = STRING[2];
  STRING5   = STRING[5];
  STRING23  = STRING[23];
  STRING40  = STRING[40];
  STRING255 = STRING[255];
  THREEWORDINT = INTEGER[8];
  BUF_DEF      = PACKED ARRAY[0..511] OF 0..255;

VAR
  OLD_FIELDS,NEW_FIELDS : SCREEN_ARR;
  MAP_ARRAY   : MAP_DEF;
  TEST_ARRAY  : TEST_DEF;
  DATA_RESULTS,         { 0 If data file exists }
  DEFI_RESULTS,         { 0 If data file definition exists }
  GET_RESULTS,          { 0 If 'GET.SCRN' loaded }
  RESULTS,INDEX,NUM_OLD_FLDS,NUM_NEW_FLDS,NEW_REC_NO,NUM_FLDS,
  FIELD_ROW,FIELD_COL,FIELD_LEN,FIELD_MIN,OLD_BLOCK,NEW_BLOCK,MAX_RECORDS,
  NUM_OLD_RECS,I,II,OLD_REC_NO,OLD_REC_LEN,NEW_REC_LEN,
  NUM_REC,ERRCOL,ERROW : INTEGER;
  EXIT_KEY,FIELD_JUS,FIELD_NA,CH : CHAR;
  FIELD_FLD : STRINGFL;
  DIGITSET : SET OF CHAR;
  VOLUME    : STRING[7];   { Data file volume }
  NAME      : STRING[10];  { Data file name }
  DB_NAME   : STRING[18];  { Volume + Data file name }
  O_DEFI_NAME : STRING[23];{ Data File Definition Name }
  N_DATA_NAME : STRING[23];{ Data File Name }
  STR_RECNO : STRING[5];
  OLD_FILE,NEW_FILE : FILE;
  OLD_GEN_FILE : GENFILE;
  TRUNC_FLDS_OK,ALL_TESTS,FIELD_SKIP,COPY_BLNKS,COPY_ALL_FLDS,COPY_ALL_RECS,
  DB_IS_NEW,CLEAR_FILE,APPEND_FILE,UDE_FILE,REC_IS_BLANK : BOOLEAN;

Procedure MESSAGE(M_ROW,M_COL :Integer; MSG :String; DING: Boolean);
  FORWARD;

Procedure EAT_SPACES(var TEMP :String; LEFT_EAT,RIGHT_EAT :Boolean);
  FORWARD;

PROCEDURE LEAVE(MSG : STRING);
  FORWARD;

SEGMENT PROCEDURE INITIALIZE;
  BEGIN
    FOR I := 1 TO SCREEN_FIELDS DO
      WITH OLD_FIELDS[I] DO
        BEGIN
          S_ID := ''; S_ROW := END_SCREEN; S_COL := 0; S_LEN := 0;
          S_MIN := 0; S_TYP := 'V'; S_JUS := 'L'; S_NA := 'A';
          S_SKIP := TRUE; S_DEF := ''; S_FLD := '';
        END;
    FOR I := 1 TO SCREEN_FIELDS DO
      WITH NEW_FIELDS[I] DO
        BEGIN
          S_ID := ''; S_ROW := END_SCREEN; S_COL := 0; S_LEN := 0;
          S_MIN := 0; S_TYP := 'V'; S_JUS := 'L'; S_NA := 'A';
          S_SKIP := TRUE; S_DEF := ''; S_FLD := '';
        END;
    FOR I := 1 TO MAX_TESTS DO
      WITH TEST_ARRAY[I] DO
        BEGIN
          FIELD_LOC := 0; VALUE := '';
        END;
    WITH OLD_FIELDS[1] DO
      BEGIN
        S_ID := 'OLDVOL'; S_NA := 'S'; S_ROW := 7; S_COL := 15; S_LEN := 7;
      END;
    WITH OLD_FIELDS[2] DO
      BEGIN
        S_ID := 'OLDNAME'; S_ROW := 9; S_COL := 15; S_LEN := 10;
      END;
    WITH OLD_FIELDS[3] DO
      BEGIN
        S_ID := 'NEWVOL'; S_NA := 'S'; S_ROW := 16; S_COL := 15; S_LEN := 7;
      END;
    WITH OLD_FIELDS[4] DO
      BEGIN
        S_ID := 'NEWNAME'; S_ROW := 18; S_COL := 15; S_LEN := 10;
      END;
    ERASE_EOS(0,0);
    GOTOXY(27,0);
    WRITE('COPY A DATA FILE');
    GOTOXY(27,1);
    WRITE('================');
    GOTOXY(27,2);
    WRITE('Version IV.0');
    GOTOXY(0,5);
    WRITE('DATA FILE TO COPY FROM');
    GOTOXY(0,7);
    WRITE('Volume    :');
    GOTOXY(0,9);
    WRITE('Name      :');
    GOTOXY(0,11);
    WRITE('Type      :    SCRN and either TEXT or GEN');
    GOTOXY(0,14);
    WRITE('DATA FILE TO COPY TO');
    GOTOXY(0,16);
    WRITE('Volume    :');
    GOTOXY(0,18);
    WRITE('Name      :');
    GOTOXY(0,20);
    WRITE('Type      :    SCRN and TEXT');
    OLD_BLOCK := -1;  NEW_BLOCK := -1;
    DIGITSET := ['0'..'9'];
    FIELD_LEN := 5; FIELD_MIN := 0;
    ERRCOL := 40; ERROW := 23;
    FIELD_JUS := 'L'; FIELD_NA := 'N';
    FIELD_FLD := '0'; FIELD_SKIP := FALSE;
  END;

SEGMENT PROCEDURE GET_FILES;

  { Gets the "from" and "to" data files }

LABEL
  1;

VAR
  DATA_FILE : FILE;
  O_DATA_NAME,N_DEFI_NAME : STRING[23];
  GET_PROMPTS : PROMPT_ARR;

 SEGMENT Procedure GET_DATA_FILE;
{ Procedure checks for data file data file.  If no data file exist
         then the operator can create one. }
 var
   RIGHT: BOOLEAN;

 function INTVALUE(S: STRING; var NUM: INTEGER): boolean;
   var
     I: integer;
     NUML : THREEWORDINT;
   begin
     INTVALUE:=false;
     I:=1;
     NUML:=0;
     EATSPL(S); EATSPR(S);
     if length(S)=0 then exit(INTVALUE);
     for I:=1 to length(S) do
       if S[I] in DIGITSET then
         NUML:=10*NUML+ord(S[I])-ord('0')
       else exit(INTVALUE);
     if NUML>MAX_INT then exit(INTVALUE);
     NUM := TRUNC(NUML);
     INTVALUE:=true;
   end;  { INTVALUE }

Procedure CREATE(var CREATE_NAME:STRING23;
                   var CREATE_LENGTH,NUMBER_RECORDS,CREATE_RESULTS:Integer);
  { Procedure creates and initilizes a file to hold data file records. }

   var NO_BLOCKS : Integer;
       buffer: packed array[0..1023] of 0..255;
       off_set: integer;
       IO_REC : PACKED RECORD
                  CASE INTEGER OF
                    1: (A: PACKED ARRAY[0..255] OF 0..255);
                    2: (B: STRING[255]);
                  END;
       check: integer;

   begin {CREATE}
    CREATE_RESULTS:=1;
    fillchar(IO_REC.A[0],sizeof(IO_REC),chr(00));
    NO_BLOCKS:=NUMBER_RECORDS div (1024 div CREATE_LENGTH)+1;
    (*$i-*)
    rewrite(data_file,CREATE_NAME);
    if IO_RESULT<>0 then exit(create);
    fillchar(IO_REC.A[4],CREATE_LENGTH-5,' ');
    IO_REC.A[0]:=CREATE_LENGTH;
    IO_REC.A[1]:=16;
    IO_REC.A[2]:=32;
    IO_REC.A[3]:=126;
    IO_REC.A[CREATE_LENGTH-1]:=42;
    IO_REC.A[CREATE_LENGTH]:=13;
    fillchar(buffer[0],sizeof(buffer),chr(00));
    check:=blockwrite(data_file,buffer,2); (* text file prefix *)
    if CHECK<>2 then begin
      close(data_file);
      exit(create);
    end;
    off_set:=0;
    while off_set+create_length <= 1023 do begin
      moveleft(io_rec.a[1],buffer[off_set],create_length);
      off_set:=off_set+create_length;
    end;
    index:=1;
    while index <= no_blocks do begin
      check:=blockwrite(data_file,buffer,2);
      if check<>2 then begin
        close(data_file);
        exit(create);
      end;
      index:=index+1;
    end;  (* while *)
    (*$i+*)
    close(data_file,LOCK);
    CREATE_RESULTS:=0;
   end; {CREATE}

 begin {GET_DATA_FILE}
 {$I-}
  DB_IS_NEW := FALSE;
  reset(DATA_FILE,N_DATA_NAME);
 {$I+}
  if IO_RESULTS <> 0
    then
     begin
      ERASE_EOL(0,MAX_ROW);
      write('Create new data file Y/N ? Y');
      gotoxy(27,MAX_ROW);
      read(Keyboard,CH);
      if CH in [' ','Y','y']
        then
         begin {make the file}
          DB_IS_NEW := TRUE;
          ERASE_EOL(0,MAX_ROW);
          write('Maximum number of records ?');
          REPEAT
            FIELD_ROW:=MAX_ROW; FIELD_COL:=29;
            FIELD_FLD:='0'; FIELD_SKIP:=FALSE;
            FIELD(FIELD_ROW,FIELD_COL,ERROW,ERRCOL,FIELD_LEN,FIELD_MIN,
              EXIT_KEY,FIELD_JUS,FIELD_NA,FIELD_FLD,FIELD_SKIP);
            RIGHT:=INTVALUE(FIELD_FLD,MAX_RECORDS); { MAR 11 }
            IF NOT RIGHT THEN
              MESSAGE(MAX_ROW,40,'ERROR: Incorrect number of records',TRUE);
          UNTIL RIGHT;
          MESSAGE(MAX_ROW,40,'STATUS: Creating Data File',False);
          CREATE(N_DATA_NAME,NEW_REC_LEN,MAX_RECORDS,RESULTS);
          if RESULTS<>0
            then
             begin
              MESSAGE(MAX_ROW,40,'ERROR: Unable to create text data file',
                True);
              DATA_RESULTS:=1;
             end
           else DATA_RESULTS:=0;
          end
         else DATA_RESULTS:=1;
       end
     else
       begin
        close(DATA_FILE);
        DATA_RESULTS:=0;
       end;
end; {GET DATA FILE}

SEGMENT Procedure RECORD_LENGTH(var S_ARRAY :SCREEN_ARR;
                       var REC_LEN:integer; var NUM_FIELDS: integer);
{ Function to find the length of the record defined by the data file
     definition.}
 var
   DONE: boolean; { Jan 5 To correct end_screen problem }

 begin {RECORD LENGTH}
  REC_LEN:=0;
  DONE:=false; { Jan 5 }
  INDEX:=1;
  while not DONE do
    if S_ARRAY[INDEX].S_ROW=END_SCREEN then DONE:=true
    else begin
      REC_LEN:=REC_LEN+S_ARRAY[INDEX].S_LEN;
      DONE := INDEX = SCREEN_FIELDS;
      INDEX:=INDEX+1;
    end;
  REC_LEN:=REC_LEN+5;
  NUM_FIELDS:=INDEX-1;  { Jan 5/Mar 12 }
 end; {RECORD LENGTH}

BEGIN {GET_FILES}
  1: DISPLAY_SCREEN(OLD_FIELDS,0,0,0,23);
     MESSAGE(MAX_ROW,0,'<ENTER> to execute, <ESC> to abort',false);
     SCREEN(OLD_FIELDS,TRUE,0,0,0,0,23,MAX_ROW,40,EXIT_KEY);
     IF EXIT_KEY = ESC_KEY THEN EXIT(COPY_DATA_FILE);
     VOLUME := OLD_FIELDS[FIND('NEWVOL',OLD_FIELDS)].S_FLD;
     EATSPR(VOLUME);
     NAME := OLD_FIELDS[FIND('NEWNAME',OLD_FIELDS)].S_FLD;
     EAT_SPACES(NAME,TRUE,TRUE);
     DB_NAME := CONCAT(VOLUME,':',NAME);
     N_DEFI_NAME := CONCAT(DB_NAME,'.SCRN');
     N_DATA_NAME := CONCAT(DB_NAME,'.TEXT');
     GET_FILE(N_DEFI_NAME,NEW_FIELDS,GET_PROMPTS,RESULTS);
     IF RESULTS <> 0
       THEN 
         BEGIN
           MESSAGE(MAX_ROW,40,'ERROR: Unknown "to" data file',TRUE);
           GOTO 1;
         END;
     RECORD_LENGTH(NEW_FIELDS,NEW_REC_LEN,NUM_NEW_FLDS);
     IF NEW_REC_LEN > 255
       THEN 
         BEGIN
           MESSAGE(MAX_ROW,40,'ERROR: Defined screen is too long',TRUE);
           GOTO 1;
         END;
     VOLUME := OLD_FIELDS[FIND('OLDVOL',OLD_FIELDS)].S_FLD;
     EATSPR(VOLUME);
     NAME := OLD_FIELDS[FIND('OLDNAME',OLD_FIELDS)].S_FLD;
     EAT_SPACES(NAME,TRUE,TRUE);
     DB_NAME := CONCAT(VOLUME,':',NAME);
     O_DEFI_NAME := CONCAT(DB_NAME,'.SCRN');
     O_DATA_NAME := CONCAT(DB_NAME,'.TEXT');
     DATA_RESULTS := 0;
     GET_FILE(O_DEFI_NAME,OLD_FIELDS,GET_PROMPTS,RESULTS);
     IF RESULTS <> 0
       THEN 
         BEGIN
           MESSAGE(MAX_ROW,40,'ERROR: Unknown "from" data file',TRUE);
           GOTO 1;
         END;
     RECORD_LENGTH(OLD_FIELDS,OLD_REC_LEN,NUM_OLD_FLDS);
     IF OLD_REC_LEN > 255
       THEN 
         BEGIN
           MESSAGE(MAX_ROW,40,'ERROR: Defined screen is too long',TRUE);
           GOTO 1;
         END;
     UDE_FILE := TRUE;
   {$I-}
     RESET(OLD_FILE,O_DATA_NAME);
     IF IO_RESULT <> 0
       THEN
         BEGIN
           UDE_FILE := FALSE;        { Copying from a GENLIST file }
           O_DATA_NAME := CONCAT(VOLUME,':',NAME,'.GEN');
           RESET(OLD_GEN_FILE,O_DATA_NAME);
           IF IO_RESULTS <> 0
             THEN 
               BEGIN
                 MESSAGE(MAX_ROW,40,
                  'ERROR: Found no TEXT or GEN file to copy from',TRUE);
                 GOTO 1;
               END;
   {$I+}
           SEEK(OLD_GEN_FILE,0);
           GET(OLD_GEN_FILE);
           NUM_OLD_FLDS := OLD_GEN_FILE^.NFLDS;
           OLD_REC_LEN  := OLD_GEN_FILE^.RSIZE;
           NUM_OLD_RECS := OLD_GEN_FILE^.NRECS;
         END;
     GET_DATA_FILE;
     FOR I := 1 TO SCREEN_FIELDS DO
       BEGIN
         EAT_SPACES(NEW_FIELDS[I].S_ID,TRUE,TRUE);
         EAT_SPACES(OLD_FIELDS[I].S_ID,TRUE,TRUE);
       END;
END;

SEGMENT PROCEDURE CREATE_MAP_ARRAY;

  { Creates an array that determines the mapping of the fields of
      the from data file to the fields of the to data file. There
      is a one to one correspondance between elements of MAP_ARRAY
      and elements of NEW_FIELDS. For example, the subscript of the
      field in OLD_FIELDS to be copied to NEW_FIELDS[3].S_FLD may be
      found in MAP_ARRAY[3].OLD_FLD_NO. A 0 in OLD_FLD_NO indicates
      that there is no corresponding field in OLD_FIELDS. MAP_ARRAY
      may be modified by the GET_COPY_INFO procedure depending
      on the type of copy being executed. The SET_TYPE field of
      MAP_ARRAY indicates what type of data is to be accepted into
      the new field.                                                 }

  VAR 
    NO_GOOD  : BOOLEAN;
    NUM_FLDS : INTEGER;
  BEGIN
    NO_GOOD := FALSE;
    FOR I := 1 TO SCREEN_FIELDS DO
      WITH MAP_ARRAY[I] DO
        BEGIN
          OLD_FLD_NO := FIND(NEW_FIELDS[I].S_ID,OLD_FIELDS);
          SET_TYPE := '-';             { Indicates any data is acceptable }
          IF OLD_FLD_NO > 0
            THEN CASE OLD_FIELDS[OLD_FLD_NO].S_NA OF
                   'A': CASE NEW_FIELDS[I].S_NA OF
                          'N': SET_TYPE := 'N';  { Only numeric data }
                          'L': SET_TYPE := 'L';  { Only alphabetic data }
                        END;
                   'N': IF NEW_FIELDS[I].S_NA = 'L'  { Conflict of data }
                          THEN NO_GOOD := TRUE;
                   'L': IF NEW_FIELDS[I].S_NA = 'N'  { Conflict of data }
                          THEN NO_GOOD := TRUE;
                   'S': CASE NEW_FIELDS[I].S_NA OF
                          'A': SET_TYPE := 'A';
                          'N': SET_TYPE := 'N';
                          'L': SET_TYPE := 'L';
                        END;
                 END;
        END;
    IF NO_GOOD
      THEN LEAVE('ERROR: Data files have incompatible field types');
    I := 1;
    NUM_FLDS := 0;
    WHILE ((I <= SCREEN_FIELDS) AND (NUM_FLDS = 0)) DO
      IF MAP_ARRAY[I].OLD_FLD_NO <> 0
        THEN NUM_FLDS := 1
        ELSE I := I + 1;
    IF NUM_FLDS = 0
      THEN LEAVE('ERROR: Data files have no fields in common');
  END;

SEGMENT PROCEDURE GET_COPY_INFO;
  
  { Determines which records and fields of the from data file are to be
      copied to the to data file.                                        }
  
  VAR
    X,Y,Q_ROW : INTEGER;
    GOOD      : BOOLEAN;
    S,MSG : STRING;

  SEGMENT PROCEDURE FIELDS_YN;

    { Prompts the user to indicate which fields are to be copied. }
    { This is the only procedure other than CREATE_MAP_ARRAY that }
    { modifies MAP_ARRAY.                                         }
    
    VAR
      NUM_FLDS : INTEGER;
    
    BEGIN
      ERASE_EOS(0,0);
      WRITELN('The following fields are common to both data files.',
                                                           ' Indicate');
      WRITELN('those fields whose information is to be copied (Y/N)');
      MESSAGE(MAX_ROW,0,'<ENTER> to execute, <ESC> to abort',false);
      FOR I := 1 TO SCREEN_FIELDS DO
        WITH OLD_FIELDS[I] DO
          BEGIN
            S_ROW := END_SCREEN; S_COL := 0; S_MIN := 0; S_TYP := 'V';
            S_JUS := 'L'; S_NA := 'L'; S_DEF := ''; S_FLD := '';
            S_SKIP := TRUE; S_ID := ''; S_LEN := 0;
          END;
      NUM_FLDS := 0;
      FOR I := 1 TO SCREEN_FIELDS DO
        IF MAP_ARRAY[I].OLD_FLD_NO <> 0
          THEN NUM_FLDS := NUM_FLDS + 1;
      X := 0;
      Y := 3;
      FOR I := 1 TO SCREEN_FIELDS DO
        BEGIN
          IF MAP_ARRAY[I].OLD_FLD_NO <> 0
            THEN
              BEGIN
                GOTOXY(X,Y);
                WRITE(NEW_FIELDS[I].S_ID);
                WITH OLD_FIELDS[I] DO
                  BEGIN
                    S_COL := X + 9; S_ROW := Y; S_NA := 'L';
                    S_SKIP := TRUE; S_DEF := 'Y'; S_LEN := 1;
                  END;
              END;
          IF NUM_FLDS <= 20            { If there are 20 or less common }
            THEN Y := Y + 1            { fields they are written out in }
            ELSE                       { a single column. Otherwise they}
              IF X = 20                { are written out alternating    }
                THEN                   { between two columns.           }
                  BEGIN
                    Y := Y + 1;
                    X := 0;
                  END
                ELSE X := 20;
        END;
      REPEAT
        DISPLAY_SCREEN(OLD_FIELDS,0,0,0,23);
        SCREEN(OLD_FIELDS,TRUE,0,0,0,0,23,MAX_ROW,40,EXIT_KEY);
        IF EXIT_KEY = ESC_KEY THEN EXIT(COPY_DATA_FILE);
        NUM_FLDS := 0;
        I := 1;
        
    { Check to see that at least one field is to be copied. For any field 
      that is not to be copied, set its OLD_FLD_NO to 0.                  }

        WHILE ((I <= SCREEN_FIELDS) AND (NUM_FLDS = 0)) DO
          BEGIN
            IF ((OLD_FIELDS[I].S_FLD = 'Y') OR (OLD_FIELDS[I].S_FLD = 'y'))
              THEN IF MAP_ARRAY[I].OLD_FLD_NO > 0
                     THEN NUM_FLDS := NUM_FLDS + 1;
            I := I + 1;
          END;
        IF NUM_FLDS = 0
          THEN MESSAGE(MAX_ROW,40,'ERROR: Must respond Y to at least one',
                                                                     TRUE)
          ELSE FOR I := 1 TO SCREEN_FIELDS DO
            IF (NOT((OLD_FIELDS[I].S_FLD = 'Y') OR 
                                          (OLD_FIELDS[I].S_FLD = 'y')))
              THEN MAP_ARRAY[I].OLD_FLD_NO := 0;
      UNTIL NUM_FLDS > 0;
    END;

SEGMENT PROCEDURE GET_TEST_ARRAY;

  { Gets the tests to be made on each record of the "from" data file
      before it is copied to the "to" data file. Only a limited no.
      of these tests are displayed on the screen at any one time
      (limited by the no. of possible fields in OLD_FIELDS).       }

  VAR
    FIRST_TEST,NUM_TESTS  : INTEGER;
    ERROR : BOOLEAN;
    PROMPT : STRING[50];
    
SEGMENT PROCEDURE USER_TESTS;
  VAR
    NUM_FIELDS,ROW,ID_COL,ID_ROW : INTEGER;
  BEGIN
    ERASE_EOS(0,0);
    WRITE('Comparison tests to be made on fields of each record:');
    GOTOXY(62,0);
    WRITE('Choose from the');
    GOTOXY(62,1);
    WRITE('following fields:');
    GOTOXY(0,18);
    WRITE('Valid operators are:  < , > , = , <= , >= , or <>');
    GOTOXY(0,20);
    WRITE('Currently viewing tests 1 - 13');
    GOTOXY(0,22);
    PROMPT := 'Get, Save tests, Change, Next, Back, Quit:';
    FOR I := 1 TO LENGTH(PROMPT) DO
      IF NOT(PROMPT[I] IN ['A'..'Z'])
        THEN PROMPT[I] := CHR(ORD(PROMPT[I])+128);
    WRITE(PROMPT);
    I := 1;
    ROW := 4;
    WHILE I < SCREEN_FIELDS-1 DO
      BEGIN
        WITH OLD_FIELDS[I] DO          { Field }
          BEGIN
            S_ROW := ROW; S_COL := 0; S_LEN := 8; S_MIN := 0;
            S_JUS := 'L'; S_NA := 'S'; S_SKIP := TRUE;
            S_DEF := ''; S_FLD := ''; S_TYP := 'V';
          END;
        WITH OLD_FIELDS[I+1] DO        { Operator }
          BEGIN
            S_ROW := ROW; S_COL := 12; S_LEN := 2; S_MIN := 0;
            S_JUS := 'L'; S_NA := 'S'; S_SKIP := TRUE;
            S_DEF := ''; S_FLD := ''; S_TYP := 'V';
          END;
        WITH OLD_FIELDS[I+2] DO        { Value }
          BEGIN
            S_ROW := ROW; S_COL := 18; S_LEN := 40; S_MIN := 0;
            S_JUS := 'L'; S_NA := 'S'; S_SKIP := TRUE;
            S_DEF := ''; S_FLD := ''; S_TYP := 'V';
          END;
        ROW := ROW + 1;
        I := I + 3;
      END;
    WITH OLD_FIELDS[SCREEN_FIELDS] DO
      BEGIN
        S_ROW := END_SCREEN; S_LEN := 0; S_FLD := '';
      END;
    DISPLAY_SCREEN(OLD_FIELDS,0,0,0,23);
    GOTOXY(0,2);
    WRITE('FIELD ID  OPERATOR                 VALUE');
    NUM_FIELDS := 0;
    FOR I := 1 TO SCREEN_FIELDS DO
      IF MAP_ARRAY[I].OLD_FLD_NO <> 0
        THEN NUM_FIELDS := NUM_FIELDS + 1;

    { The following code writes out the ids the user may choose from
      in testing the fields to be copied. If there are less than 20,
      they are written out in a single column, otherwise they are
      written out alternating between two columns.                   }

    IF NUM_FIELDS <= 20
      THEN ID_COL := 66    { Center a single column }
      ELSE ID_COL := 62;   { Center double columns  }
    ID_ROW := 3;
    I := 1;
    WHILE I <= SCREEN_FIELDS DO
      BEGIN
        IF MAP_ARRAY[I].OLD_FLD_NO <> 0
          THEN
            BEGIN
              GOTOXY(ID_COL,ID_ROW);
              WRITE(NEW_FIELDS[I].S_ID);
              IF ID_COL = 62
                THEN          { Alternate ids between 1st and 2nd cols }
                  ID_COL := 72
                ELSE
                  IF ID_COL = 66
                    THEN ID_ROW := ID_ROW + 1
                    ELSE IF ID_COL = 72
                           THEN
                             BEGIN
                               ID_COL := 62;
                               ID_ROW := ID_ROW + 1;
                             END;
            END;
        I := I + 1;
      END;
  END; {USER_TESTS}

SEGMENT PROCEDURE DISPLAY_TESTS(TEST_NO : INTEGER);
  
  { Transfers the appropriate section of TEST_ARRAY tests to OLD_FIELDS
      for display.                                                      }
  
  VAR
    FOUND : BOOLEAN;
  BEGIN
    FOR I := 1 TO SCREEN_FIELDS DO
      OLD_FIELDS[I].S_FLD := '';
    I := 1;
    WHILE I < SCREEN_TESTS*3 DO
      WITH TEST_ARRAY[TEST_NO +(I DIV 3)] DO
        BEGIN
          II := 1;
          FOUND := FALSE;
          WHILE NOT FOUND DO
            BEGIN
              IF MAP_ARRAY[II].OLD_FLD_NO <> FIELD_LOC
                THEN II := II + 1
                ELSE FOUND := TRUE;
              IF II > SCREEN_FIELDS
                THEN
                  BEGIN
                    II := 0;
                    FOUND := TRUE;
                  END;
            END;
          IF ((FIELD_LOC = 0) OR (II = 0))
            THEN
              BEGIN
                OLD_FIELDS[I].S_FLD := '';
                OLD_FIELDS[I+1].S_FLD := '';
                OLD_FIELDS[I+2].S_FLD := '';
              END
            ELSE
              BEGIN
                OLD_FIELDS[I].S_FLD := NEW_FIELDS[II].S_ID;
                WITH OLD_FIELDS[I+1] DO
                  CASE OPERATOR OF
                    LT: S_FLD := '<';
                    GT: S_FLD := '>';
                    EQ: S_FLD := '=';
                    LE: S_FLD := '<=';
                    GE: S_FLD := '>=';
                    NE: S_FLD := '<>';
                  END;
                OLD_FIELDS[I+2].S_FLD := VALUE;
              END;
          I := I + 3;
        END;
    DISPLAY_SCREEN(OLD_FIELDS,0,0,0,23);
  END;

SEGMENT PROCEDURE UPDATE_TEST_ARRAY(TEST_NO : INTEGER);

  { Checks the tests in OLD_FIELDS for validity and transfers them
    to the appropriate section of TEST_ARRAY.                      }

  VAR
    OP : OPS;
    FLD_LEN,I,K,LOCATION : INTEGER;
    BLANK_FIELD,BLANK_OP,BLANK_VALUE : BOOLEAN;

  PROCEDURE CHK_FIELD(VAR FIELD      : STRING;
                    VAR LOC        : INTEGER;
                    VAR IS_BLANK   : BOOLEAN;
                    VAR FLD_LENGTH : INTEGER);
  { Determines if the field name of the test is valid. Passes back the
      length of the fields value field so that CHK_VALUE may determine
      if the length of value of the test is within the maximum allowable. }

  VAR
    FOUND : BOOLEAN;

  BEGIN
    EAT_SPACES(FIELD,TRUE,TRUE);
    IF LENGTH(FIELD) = 0
      THEN IS_BLANK := TRUE
      ELSE IS_BLANK := FALSE;
    FLD_LENGTH := 0;
    IF NOT IS_BLANK
      THEN
        BEGIN
          FOUND := FALSE;
          II := FIND(FIELD,NEW_FIELDS);
          IF II <> 0
            THEN IF MAP_ARRAY[II].OLD_FLD_NO <> 0
              THEN
                BEGIN
                  LOC := MAP_ARRAY[II].OLD_FLD_NO;
                  FOUND := TRUE;
                  FLD_LENGTH := NEW_FIELDS[II].S_LEN;
                END;
          IF NOT FOUND
            THEN
              BEGIN
                MESSAGE(MAX_ROW,40,CONCAT('ERROR: ',FIELD,
                                            ' is an invalid field name'),
                                                                   TRUE);
                ERROR := TRUE;
                EXIT(UPDATE_TEST_ARRAY);
              END;
        END;
  END;

PROCEDURE CHK_OP(VAR OP_STRING : STRING;
                 VAR OPRATR    : OPS;
                 VAR IS_BLANK  : BOOLEAN);

  { Determine if the operator of the test is valid. Valid operators
      are: "<", ">", "<=", ">=", "<>", and "=".                      }

  VAR
    GOOD : BOOLEAN;
  BEGIN
    EAT_SPACES(OP_STRING,TRUE,TRUE);
    GOOD := TRUE;
    IS_BLANK := FALSE;
    IF LENGTH(OP_STRING) = 0
      THEN IS_BLANK := TRUE
      ELSE
        IF OP_STRING = '<'
          THEN OPRATR := LT
        ELSE IF OP_STRING = '>'
          THEN OPRATR := GT
        ELSE IF OP_STRING = '='
          THEN OPRATR := EQ
        ELSE IF OP_STRING = '<='
          THEN OPRATR := LE
        ELSE IF OP_STRING = '>='
          THEN OPRATR := GE
        ELSE IF OP_STRING = '<>'
          THEN OPRATR := NE
        ELSE GOOD := FALSE;
    IF NOT GOOD
      THEN
        BEGIN
          MESSAGE(MAX_ROW,40,CONCAT('ERROR: ',OP_STRING,' is an invalid ',
                                                           'operator'),TRUE);
          ERROR := TRUE;
          EXIT(UPDATE_TEST_ARRAY);
        END;
  END;

PROCEDURE CHK_VALUE(VAR VALUE: STRING; IS_BLANK: BOOLEAN; FLD_LENGTH: INTEGER);

  { Determines if the length of the value of the test is within the maximum. }

  VAR
    COL : INTEGER;
  BEGIN
    IF FLD_LENGTH > 0
      THEN
        BEGIN
          EAT_SPACES(VALUE,TRUE,TRUE);
          IF LENGTH(VALUE) > FLD_LENGTH
            THEN
              BEGIN
                STR(FLD_LENGTH,MSG);
                MSG := CONCAT('ERROR: Value "',VALUE,'" exceeds max length',
                                          ' of ',MSG);
                COL := 80-LENGTH(MSG);
                IF COL > 40 THEN COL := 40;
                MESSAGE(MAX_ROW,COL,MSG,TRUE);
                ERROR := TRUE;
                EXIT(UPDATE_TEST_ARRAY);
              END
            ELSE
              IF LENGTH(VALUE) = 0
                THEN IS_BLANK := TRUE
                ELSE IS_BLANK := FALSE;
        END;
  END;

BEGIN {UPDATE_TEST_ARRAY}
    ERASE_EOL(0,MAX_ROW);
    ERROR := FALSE;
    I := 1;
    WHILE I < 3*SCREEN_TESTS DO
      BEGIN
        CHK_FIELD(OLD_FIELDS[I].S_FLD,LOCATION,BLANK_FIELD,FLD_LEN);
        CHK_OP(OLD_FIELDS[I+1].S_FLD,OP,BLANK_OP);
        CHK_VALUE(OLD_FIELDS[I+2].S_FLD,BLANK_VALUE,FLD_LEN);
        IF ((BLANK_OP) AND (NOT BLANK_FIELD))
          THEN
            BEGIN
              MESSAGE(MAX_ROW,40,'ERROR: Missing operator',true);
              ERROR := TRUE;
              EXIT(UPDATE_TEST_ARRAY);
            END;
        IF ((BLANK_FIELD) OR (BLANK_OP))
          THEN TEST_ARRAY[TEST_NO + (I DIV 3)].FIELD_LOC := 0
          ELSE
            WITH TEST_ARRAY[TEST_NO+(I DIV 3)] DO
              BEGIN
                FIELD_LOC := LOCATION;
                OPERATOR := OP;
                VALUE := OLD_FIELDS[I+2].S_FLD;
              END;
        I := I + 3;
      END;
  END;   {UPDATE_TEST_ARRAY}

PROCEDURE GET_SAVE(COMMAND : CHAR);
    VAR
      GOOD      : BOOLEAN;
      FILE_NAME : STRING[23];
      TEST_FILE : FILE OF TEST_REC;
  
    BEGIN
      FOR II := 1 TO SCREEN_FIELDS DO
        WITH OLD_FIELDS[II] DO
          BEGIN
            S_ROW := END_SCREEN; S_COL := 14; S_MIN := 0; S_TYP := 'V';
            S_JUS := 'L'; S_NA := 'S'; S_DEF := ''; S_FLD := '';
          END;
      WITH OLD_FIELDS[1] DO
        BEGIN
          S_ID := 'VOL'; S_ROW := 6; S_LEN := 7;
        END;
      WITH OLD_FIELDS[2] DO
        BEGIN
          S_ID := 'NAME'; S_ROW := 8; S_LEN := 10;
        END;
      ERASE_EOS(0,0);
      GOTOXY(25,0);
      IF COMMAND = 'G'
        THEN WRITE('GET COMPARISON TESTS')
        ELSE WRITE('SAVE COMPARISON TESTS');
      GOTOXY(25,1);
      IF COMMAND = 'G'
        THEN WRITE('====================')
        ELSE WRITE('=====================');
      GOTOXY(0,6);
      WRITELN('Volume    :');
      WRITELN;
      WRITELN('Name      :');
      WRITELN;
      WRITELN('Type      :   Cmpr');
      MESSAGE(MAX_ROW,0,'<ENTER> to execute, <ESC> to abort',false);
      DISPLAY_SCREEN(OLD_FIELDS,0,0,0,23);
      REPEAT
        GOOD := TRUE;
        SCREEN(OLD_FIELDS,TRUE,0,0,0,0,23,MAX_ROW,40,EXIT_KEY);
        IF EXIT_KEY = ESC_KEY THEN EXIT(GET_SAVE);
        VOLUME := OLD_FIELDS[1].S_FLD;
        NAME := OLD_FIELDS[2].S_FLD;
        EAT_SPACES(VOLUME,TRUE,TRUE);
        EAT_SPACES(NAME,TRUE,TRUE);
        FILE_NAME := CONCAT(VOLUME,':',NAME,'.CMPR');
     {$I-}
        IF COMMAND = 'G'
          THEN
            BEGIN
              RESET(TEST_FILE,FILE_NAME);
              IF IO_RESULT = 0
                THEN
                  BEGIN
                    FOR I := 1 TO MAX_TESTS DO
                      BEGIN
                       TEST_ARRAY[I].FIELD_LOC := TEST_FILE^.FIELD_LOC;
                       TEST_ARRAY[I].OPERATOR  := TEST_FILE^.OPERATOR;
                       TEST_ARRAY[I].VALUE     := TEST_FILE^.VALUE;
                       IF I <> MAX_TESTS THEN GET(TEST_FILE);
                       IF IO_RESULT <> 0 THEN GOOD := FALSE;
                      END;
                    CLOSE(TEST_FILE,LOCK);
                  END
                ELSE GOOD := FALSE;
            END
          ELSE
            BEGIN
              REWRITE(TEST_FILE,FILE_NAME);
              IF IO_RESULT = 0
                THEN
                  BEGIN
                    FOR I := 1 TO MAX_TESTS DO
                      BEGIN
                        TEST_FILE^.FIELD_LOC := TEST_ARRAY[I].FIELD_LOC;
                        TEST_FILE^.OPERATOR  := TEST_ARRAY[I].OPERATOR;
                        TEST_FILE^.VALUE     := TEST_ARRAY[I].VALUE;
                        PUT(TEST_FILE);
                        IF IO_RESULT <> 0 THEN GOOD := FALSE;
                      END;
                    CLOSE(TEST_FILE,LOCK);
                  END
                ELSE GOOD := FALSE;
            END;
        IF NOT GOOD
          THEN MESSAGE(MAX_ROW,40,'ERROR: Invalid file specification',true);
      UNTIL GOOD;
     {$I+}
    END; {GET_SAVE}

  BEGIN {GET_TEST_ARRAY}
  USER_TESTS;
  FIRST_TEST := 1;
  ERROR := FALSE;
  REPEAT
    IF ERROR
      THEN CH := 'C'
      ELSE 
        BEGIN
          GOTOXY(43,MAX_ROW-1);
          READ(KEYBOARD,CH);
          IF CH = ESC_KEY THEN EXIT(PROGRAM);
          ERASE_EOL(0,MAX_ROW);
        END;
    CASE CH OF
      'C','c': BEGIN
                 SCREEN(OLD_FIELDS,TRUE,0,0,0,0,23,MAX_ROW,40,EXIT_KEY);
                 IF EXIT_KEY = ESC_KEY THEN EXIT(COPY_DATA_FILE);
                 UPDATE_TEST_ARRAY(FIRST_TEST);
               END;
      'B','b': BEGIN
                 IF ERROR
                   THEN WRITE(ALARM_BELL)
                   ELSE
                     BEGIN
                       IF FIRST_TEST <> 1
                         THEN FIRST_TEST := FIRST_TEST - SCREEN_TESTS
                         ELSE FIRST_TEST := MAX_TESTS-SCREEN_TESTS+1;
                       STR(FIRST_TEST,S);
                       STR(FIRST_TEST+12,MSG);
                       MSG := CONCAT('Currently viewing tests ',S,' - ',
                                                                 MSG,' ');
                       MESSAGE(20,0,MSG,FALSE);
                       DISPLAY_TESTS(FIRST_TEST);
                     END;
               END;
      'G','g': BEGIN
                 GET_SAVE('G');
                 USER_TESTS;
                 FIRST_TEST := 1;
                 DISPLAY_TESTS(FIRST_TEST);
               END;
      'S','s': BEGIN
                 IF ERROR
                   THEN WRITE(ALARM_BELL)
                   ELSE
                     BEGIN
                       GET_SAVE('S');
                       USER_TESTS;
                       FIRST_TEST := 1;
                       DISPLAY_TESTS(FIRST_TEST);
                     END;
               END;
      'N','n': BEGIN
                 IF ERROR
                   THEN WRITE(ALARM_BELL)
                   ELSE
                     BEGIN
                       IF FIRST_TEST < MAX_TESTS-SCREEN_TESTS+1
                         THEN FIRST_TEST := FIRST_TEST + SCREEN_TESTS
                         ELSE FIRST_TEST := 1;
                       STR(FIRST_TEST,S);
                       STR(FIRST_TEST+12,MSG);
                       MSG := CONCAT('Currently viewing tests ',S,' - ',
                                                                  MSG,' ');
                       MESSAGE(20,0,MSG,FALSE);
                       DISPLAY_TESTS(FIRST_TEST);
                     END;
               END;
      'Q','q': IF ERROR
                 THEN
                   BEGIN
                     WRITE(ALARM_BELL);
                     CH := ' ';
                   END;
      END;
  UNTIL ((CH = 'Q') OR (CH = 'q'));
  II := 1;
  NUM_TESTS := 0;
  WHILE ((II <= MAX_TESTS) AND (NUM_TESTS < 2)) DO
    BEGIN
      IF TEST_ARRAY[II].FIELD_LOC > 0
        THEN NUM_TESTS := NUM_TESTS + 1;
      II := II + 1;
    END;
  ALL_TESTS := TRUE;
  IF NUM_TESTS > 1
    THEN
      BEGIN
        ERASE_EOS(0,0);
        WRITE('Copy each record if :');
        GOTOXY(0,2);
        WRITE('1) All of the above tests have been met');
        GOTOXY(0,4);
        WRITE('2) Any of the above tests has been met');
        GOTOXY(0,6);
        WRITE('Enter 1 or 2 :');
        REPEAT
          ERASE_EOL(15,6);
          READ(KEYBOARD,CH);
          IF CH = ESC_KEY THEN EXIT(PROGRAM);
        UNTIL ((CH = '1') OR (CH = '2'));
        WRITE(CH);
        IF CH = '2'
          THEN ALL_TESTS := FALSE;
      END;
END; {GET_TEST_ARRAY}

BEGIN {GET_COPY_INFO}
  ERASE_EOS(0,0);
  GOTOXY(0,0);
  WRITE('Please answer the following questions:');
  Q_ROW := 3;
  CLEAR_FILE := FALSE;
  APPEND_FILE := FALSE;
  IF NOT DB_IS_NEW         {DB_IS_NEW flag is set in procedure GET_COPY_INFO}
    THEN
      BEGIN
        Q_ROW := 6;
        GOTOXY(0,3);
        WRITELN('Data file being copied to has existing records. ',
              'Do you wish');
        WRITELN('to delete them? (Y/N): Y');
        GOTOXY(23,4);
        REPEAT
          READ(KEYBOARD,CH);
          IF CH = ESC_KEY THEN EXIT(PROGRAM);
        UNTIL CH IN [' ','Y','y','N','n'];
        IF CH <> ' ' THEN WRITE(CH);
        CLEAR_FILE := (CH IN [' ','Y','y']);
        IF NOT CLEAR_FILE
          THEN
            BEGIN
              Q_ROW := 8;
              GOTOXY(0,6);
              WRITELN('Do you wish to add the new records at ',
                                       'the end of the data file? (Y/N): Y');
              GOTOXY(71,6);
              REPEAT
                READ(KEYBOARD,CH);
                IF CH = ESC_KEY THEN EXIT(PROGRAM);
              UNTIL CH IN [' ','Y','y','N','n'];
              IF CH <> ' ' THEN WRITE(CH);
              APPEND_FILE := (CH IN [' ','Y','y']);
              IF NOT APPEND_FILE
                THEN
                  BEGIN
                    Q_ROW := 11;
                    GOTOXY(0,8);
                    WRITELN('NOTE: Any fields of the existing ',
                         'data file that are not copied to will');
                    WRITELN('be left intact. Do you wish to proceed?',
                               ' (Y/N): Y');
                    GOTOXY(47,9);
                    REPEAT
                      READ(KEYBOARD,CH);
                      IF CH = ESC_KEY THEN EXIT(PROGRAM);
                    UNTIL CH IN [' ','Y','y','N','n'];
                    IF (NOT(CH IN [' ','Y','y'])) THEN EXIT(PROGRAM);
                  END;
            END;
      END;
  GOTOXY(0,Q_ROW);
  WRITE('Do you wish to copy all fields common to both data files? (Y/N): Y');
  REPEAT
    GOTOXY(65,Q_ROW);
    READ(KEYBOARD,CH);
    IF CH = ESC_KEY THEN EXIT(PROGRAM);
  UNTIL CH IN [' ','Y','y','N','n'];
  IF CH <> ' ' THEN WRITE(CH);
  COPY_ALL_FLDS := (CH IN [' ','Y','y']);
  IF NOT COPY_ALL_FLDS
    THEN 
      BEGIN
        FIELDS_YN;
        Q_ROW := 3;
        ERASE_EOS(0,0);
      END
    ELSE Q_ROW := Q_ROW + 2;
  IF Q_ROW = 3 
    THEN
      BEGIN
        GOTOXY(0,0);
        WRITE('Please answer the following questions:');
      END;
  GOTOXY(0,Q_ROW);
  WRITELN('Are fields to be tested for certain values before record');
  WRITELN('is copied? (Y/N): N');
  Q_ROW := Q_ROW + 1;
  REPEAT
    GOTOXY(18,Q_ROW);
    READ(KEYBOARD,CH);
    IF CH = ESC_KEY THEN EXIT(PROGRAM);
  UNTIL CH IN [' ','Y','y','N','n'];
  IF CH <> ' ' THEN WRITE(CH);
  COPY_ALL_RECS := (CH IN [' ','N','n']);
  IF NOT COPY_ALL_RECS
    THEN
      BEGIN
        GET_TEST_ARRAY;
        ERASE_EOS(0,0);
        Q_ROW := 3;
      END
    ELSE Q_ROW := Q_ROW + 2;
  IF Q_ROW = 3 
    THEN
      BEGIN
        GOTOXY(0,0);
        WRITE('Please answer the following questions:');
      END;
  GOTOXY(0,Q_ROW);
  WRITE('Copy blank records? (Y/N): N');
  REPEAT
    GOTOXY(27,Q_ROW);
    READ(KEYBOARD,CH);
    IF CH = ESC_KEY THEN EXIT(PROGRAM);
  UNTIL CH IN [' ','Y','y','N','n'];
  IF CH <> ' ' THEN WRITE(CH);
  COPY_BLNKS := (CH IN ['Y','y']);
END;

SEGMENT PROCEDURE READ_TEST_COPY;

 VAR
   S,MSG : STRING;
   OFFSET_RECS  : INTEGER;
   END_NEW_FILE : BOOLEAN;
   IO_REC       : PACKED RECORD
                    CASE INTEGER OF
                      1: (A: PACKED ARRAY[0..255] OF 0..255);
                      2: (B: STRING[255]);
                    END;
   GET_PROMPTS  : PROMPT_ARR;
   OLD_BUF,NEW_BUF : BUF_DEF;

 SEGMENT Procedure READ_WRITE(    RW_COMMAND,
                          WHICH_FILE      :Char;
                      var REC_NO,
                          REC_LEN         :Integer;
                      var BUFFER          :BUF_DEF;
                      var CURRENT_BLOCK,
                          IO_RET_CODE     :Integer);

  var IO_BLOCKS,START_POSITION,TWO_BLOCK,START_REC,BYTE_TWO_BLOCK,
      BLOCK_NO,REC_NUM,FIRST_MOV_LEN,CHAR_OFFSET: Integer;

  begin {READ_WRITE}
 {$I-}
   IO_RET_CODE:=-1;
   REC_NUM:=REC_NO-1;
   if REC_NUM<0 then REC_NUM:=0;
   TWO_BLOCK:=REC_NUM div (1023 div REC_LEN);  (* 1024 correction Dec 5 1980 *)
   START_REC:=TWO_BLOCK*(1023 div REC_LEN);    (* 1024 correction Dec 5 1980 *)
   BYTE_TWO_BLOCK:=(REC_NUM-START_REC)*REC_LEN;
   BLOCK_NO:=(TWO_BLOCK*2)+2;
   if BYTE_TWO_BLOCK>=512  (* = correction Dec 5 1980 *)
     then
      begin
       BLOCK_NO:=BLOCK_NO+1;
       CHAR_OFFSET:=BYTE_TWO_BLOCK-512;
      end
     else CHAR_OFFSET:=BYTE_TWO_BLOCK;
   if CHAR_OFFSET+REC_LEN>512
     then
      begin
       if CURRENT_BLOCK<>BLOCK_NO
         then
          begin
           IF WHICH_FILE = 'O'
             THEN IO_BLOCKS:=blockread(OLD_FILE,BUFFER,1,BLOCK_NO)
             ELSE IO_BLOCKS:=blockread(NEW_FILE,BUFFER,1,BLOCK_NO);
           IF IO_BLOCKS=0 then exit(READ_WRITE);
          end;
       FIRST_MOV_LEN:=512-CHAR_OFFSET;
       if RW_COMMAND='W'
         then
           begin
            moveleft(IO_REC.A[1],BUFFER[CHAR_OFFSET],FIRST_MOV_LEN);
            IF WHICH_FILE = 'O'
             THEN IO_BLOCKS:=blockwrite(OLD_FILE,BUFFER,1,BLOCK_NO)
             ELSE IO_BLOCKS:=blockwrite(NEW_FILE,BUFFER,1,BLOCK_NO);
            IF IO_BLOCKS=0 then exit(READ_WRITE);
           end
         else moveleft(BUFFER[CHAR_OFFSET],IO_REC.A[1],FIRST_MOV_LEN);
       BLOCK_NO:=BLOCK_NO+1;
       IF WHICH_FILE = 'O'
         THEN IO_BLOCKS:=blockread(OLD_FILE,BUFFER,1,BLOCK_NO)
         ELSE IO_BLOCKS:=blockread(NEW_FILE,BUFFER,1,BLOCK_NO);
       IF IO_BLOCKS=0 then exit(READ_WRITE);
       if RW_COMMAND='W'
         then
          begin
           moveleft(IO_REC.A[FIRST_MOV_LEN+1],BUFFER[0],REC_LEN-FIRST_MOV_LEN);
           IF WHICH_FILE = 'O'
             THEN IO_BLOCKS:=blockwrite(OLD_FILE,BUFFER,1,BLOCK_NO)
             ELSE IO_BLOCKS:=blockwrite(NEW_FILE,BUFFER,1,BLOCK_NO);
           IF IO_BLOCKS=0 then exit(READ_WRITE);
          end
        else moveleft(BUFFER[0],IO_REC.A[FIRST_MOV_LEN+1],
                                            REC_LEN-FIRST_MOV_LEN);
      end
    else
     begin
      if ((RW_COMMAND='R') AND (CURRENT_BLOCK<>BLOCK_NO))
        then
         begin
           IF WHICH_FILE = 'O'
             THEN IO_BLOCKS:=blockread(OLD_FILE,BUFFER,1,BLOCK_NO)
             ELSE IO_BLOCKS:=blockread(NEW_FILE,BUFFER,1,BLOCK_NO);
           IF IO_BLOCKS=0 then exit(READ_WRITE);
         end;
      if RW_COMMAND='W'
         then
          begin
           moveleft(IO_REC.A[1],BUFFER[CHAR_OFFSET],REC_LEN);
           IF ((CURRENT_BLOCK<>BLOCK_NO) OR (CHAR_OFFSET+(2*REC_LEN)>=512))
             THEN                        { WRITE BUFFER; NEXT READ WOULD  }
               BEGIN                     { CUASE NEW BUFFER TO BE READ IN }
                 IF WHICH_FILE = 'O'
                   THEN IO_BLOCKS:=blockwrite(OLD_FILE,BUFFER,1,BLOCK_NO)
                   ELSE IO_BLOCKS:=blockwrite(NEW_FILE,BUFFER,1,BLOCK_NO);
                 IF IO_BLOCKS=0 then exit(READ_WRITE);
               END;
          end
         else moveleft(BUFFER[CHAR_OFFSET],IO_REC.A[1],REC_LEN);
     end;
    CURRENT_BLOCK:=BLOCK_NO;
    if IO_REC.A[3]=0 then exit(READ_WRITE);
    IO_RET_CODE:=0;
    IO_REC.A[0]:=REC_LEN;
  {$I+}
  end;  {READ_WRITE}

SEGMENT Procedure LOAD_SCREEN(LOAD_COMMAND :Char; var S_ARRAY: SCREEN_ARR;
                    NUMBER_FLDS:INTEGER; var RECORD_STRING: STRING255);
  { Procedure load the screen array from a record obtained from the disk  }
  { file.                                                                 }

   var LOAD_INDEX,T_INDEX,COPY_INDEX,COPY_LENGTH : Integer;

   begin {LOAD_SCREEN}
    COPY_INDEX := 4;
    LOAD_INDEX:=1;
    while LOAD_INDEX <= NUMBER_FLDS  do
     with S_ARRAY[LOAD_INDEX] do
      begin
       COPY_LENGTH:=S_LEN;
       if (LOAD_COMMAND = 'A') or
          ((LOAD_COMMAND = 'D') and (S_ID = COPY(S_DEF,2,LENGTH(S_DEF)-2)))
         then
           S_FLD:=copy(RECORD_STRING,COPY_INDEX,COPY_LENGTH)
         else
          begin
            IF (S_DEF = '') OR (S_DEF = COPY(UNDERLINE,1,1))
              THEN
               BEGIN
                 S_FLD := ' ';
                 FOR T_INDEX := 1 TO S_LEN-1 DO INSERT(' ',S_FLD,T_INDEX);
               END
              ELSE  { s_def<>''  Mar 12 }
                if s_def[1]<>'[' then begin
                  s_fld:=' ';
                  FOR T_INDEX := 1 TO S_LEN-1 DO INSERT(' ',S_FLD,T_INDEX)
                end
                else begin { s_def[1]='[' }
                  t_index:=find(copy(s_def,2,length(s_def)-2),S_ARRAY);
                  if t_index=0 then s_fld:=s_def
                    else s_fld:=S_ARRAY[t_index].s_fld;
                end;
          end;
        COPY_INDEX:=COPY_INDEX + COPY_LENGTH;
        LOAD_INDEX:=LOAD_INDEX + 1;
      end; {with/while}
   end; {LOAD SCREEN}

SEGMENT Procedure BUILD_RECORD;
  { Procedure builds records to be placed on the disk. }

   begin {BUILD RECORD}
    IO_REC.A[0]:=3;
    for INDEX:=1 to NUM_NEW_FLDS do  { Jan 5 To correct value range error }
       IO_REC.B:=concat(IO_REC.B,NEW_FIELDS[INDEX].S_FLD);
    (*get rid of leftover low-intensity underscores *)
    for index:=1 to length(io_rec.b) do
      if io_rec.a[index]=223 then io_rec.a[index]:=32;  (* blank *)
    IO_REC.A[0]:=NEW_REC_LEN;
    IO_REC.A[1]:=16; (* dle *)
    IO_REC.A[2]:=32; (* space *)
    IO_REC.A[3]:=42; (* * *)
    IO_REC.A[NEW_REC_LEN-1]:=42;
    IO_REC.A[NEW_REC_LEN]:=13; (* carriage return *)
   end; {BUILD RECORD}

 SEGMENT FUNCTION COPY_RECORD : BOOLEAN;
  
  { Determines whether a record is to be copied or not. }

  VAR
    BLANK,PASSED : BOOLEAN;
    F : STRINGFL;

  FUNCTION COMPARE(TEST : TEST_REC): BOOLEAN;

    { Function is true if test passes, false if not. }

    VAR
      OLD_VAL : STRINGFL;
      NUM1,NUM2 : REAL;
     
     function STR_TO_REAL(var S: STRING; var NUM: REAL): boolean;
      
      { Returns a value of true and the real value in NUM if
        string can be converted to real, is set to false otherwise }
      
      var
        I : integer;
        FACTOR : REAL;
        D_PT : BOOLEAN;
      begin
        STR_TO_REAL:=false;
        I:=1;
        D_PT := FALSE;
        NUM:=0;
        EATSPL(S); EATSPR(S);
        if length(S)=0 then exit(STR_TO_REAL);
        WHILE ((I <= LENGTH(S)) AND (NOT D_PT)) DO
          BEGIN
            if S[I] in DIGITSET then
              NUM:=10*NUM+ord(S[I])-ord('0')
            ELSE IF S[I] = '.' THEN D_PT := TRUE
            else exit(STR_TO_REAL);
            I := I + 1;
          END;
        IF D_PT
          THEN
            BEGIN
              FACTOR := 10;
              WHILE I <= LENGTH(S) DO
                IF S[I] IN DIGITSET
                  THEN
                    BEGIN
                      NUM := NUM + ((ord(S[I])-ord('0'))/FACTOR);
                      FACTOR := FACTOR * 10;
                      I := I + 1;
                    END
                  ELSE EXIT(STR_TO_REAL);
            END;
        STR_TO_REAL:=true;
      end;  { STR_TO_REAL }
      
    BEGIN   { COMPARE }
      COMPARE := FALSE;
      OLD_VAL := OLD_FIELDS[TEST.FIELD_LOC].S_FLD;
      EAT_SPACES(OLD_VAL,TRUE,TRUE);
      WITH TEST DO
        IF ((STR_TO_REAL(OLD_VAL,NUM1)) AND (STR_TO_REAL(VALUE,NUM2)))
          THEN     { Compare as reals if possible }
            CASE TEST.OPERATOR OF
              LT: COMPARE := NUM1 < NUM2;
              GT: COMPARE := NUM1 > NUM2;
              EQ: COMPARE := NUM1 = NUM2;
              LE: COMPARE := NUM1 <= NUM2;
              GE: COMPARE := NUM1 >= NUM2;
              NE: COMPARE := NUM1 <> NUM2;
            END
          ELSE     { Otherwise compare as strings }
            CASE TEST.OPERATOR OF
              LT: COMPARE := OLD_VAL < VALUE;
              GT: COMPARE := OLD_VAL > VALUE;
              EQ: COMPARE := OLD_VAL = VALUE;
              LE: COMPARE := OLD_VAL <= VALUE;
              GE: COMPARE := OLD_VAL >= VALUE;
              NE: COMPARE := OLD_VAL <> VALUE;
            END;
    END; {COMPARE}

  BEGIN {COPY_RECORD}
    COPY_RECORD := TRUE;
    IF NOT COPY_ALL_RECS      { Then see if record meets the user's tests }
     THEN
      BEGIN
       IF ALL_TESTS          { COPY_RECORD set to true if all tests pass }
         THEN
           BEGIN
             I := 1;
             PASSED := TRUE;
             WHILE ((I <= MAX_TESTS) AND (PASSED)) DO
               BEGIN
                 IF TEST_ARRAY[I].FIELD_LOC > 0
                   THEN PASSED := COMPARE(TEST_ARRAY[I]);
                 I := I + 1;
               END;
             COPY_RECORD := PASSED;
           END
         ELSE
           BEGIN            {COPY_RECORD set to true if any test passes}
             I := 1;
             PASSED := FALSE;
             WHILE ((I <= MAX_TESTS) AND (NOT PASSED)) DO
               BEGIN
                 IF TEST_ARRAY[I].FIELD_LOC > 0
                   THEN PASSED := COMPARE(TEST_ARRAY[I]);
                 I := I + 1;
               END;
             COPY_RECORD := PASSED;
           END;
      END;
  END; {COPY_RECORD}

SEGMENT PROCEDURE READ_OLD_RECORD(VAR IS_BLANK : BOOLEAN;
                                  VAR READ_RESULTS : INTEGER);

{ This procedure determines whether the "from" data file is a UDE file
  or a GENLIST file and reads a record from it.
  NOTE: In a UDE file a blank record is defined to be one where
        IO_REC.A[3] = 126. In a GENLIST file a blank record is defined
        be one where OLD_GEN_FILE^.DATA[1] = chr(127). Any other records
        are assumed to be non-blank, even if all of their fields are
        blank.                                                            }

BEGIN
  READ_RESULTS := 0;
  IS_BLANK := FALSE;
  IF UDE_FILE
    THEN
      BEGIN
        READ_WRITE('R','O',OLD_REC_NO,OLD_REC_LEN,OLD_BUF,
                                                OLD_BLOCK,READ_RESULTS);
        IF READ_RESULTS = 0
          THEN
            BEGIN
              IF IO_REC.A[3] = 126
                THEN IS_BLANK := TRUE
                ELSE LOAD_SCREEN('A',OLD_FIELDS,NUM_OLD_FLDS,IO_REC.B);
            END;
      END
    ELSE
      BEGIN
        IF OLD_REC_NO <= NUM_OLD_RECS
          THEN
            BEGIN
              SEEK(OLD_GEN_FILE,OLD_REC_NO);
              GET(OLD_GEN_FILE);
              IF OLD_GEN_FILE^.DATA[1] = CHR(127)
                THEN IS_BLANK := TRUE 
                ELSE
                  BEGIN
                    INDEX := 1;
                    FOR II := 1 TO NUM_OLD_FLDS DO
                      IF OLD_FIELDS[II].S_LEN > 0
                        THEN
                          BEGIN
                            OLD_FIELDS[II].S_FLD := COPY(OLD_GEN_FILE^.DATA,
                                                  INDEX,OLD_FIELDS[II].S_LEN);
                            INDEX := INDEX + OLD_FIELDS[II].S_LEN;
                          END;
                  END;
            END
          ELSE READ_RESULTS := -1;
      END;
END; {READ_OLD_RECORD}

SEGMENT PROCEDURE COPY_FIELDS;

  { Copies the fields of the current "from" record to the current "to"
      record.                                                          }

  VAR
    I,CHAR_INDEX : INTEGER;
    ONE_CHAR     : CHAR;
    TOO_LONG     : BOOLEAN;

  FUNCTION CHR_IN_SET(CHR,SET_TYPE : CHAR) : BOOLEAN;

    { CHR_IN_SET is set to true if chr is in the indicated set. }

    BEGIN
      CHR_IN_SET := FALSE;
      CASE SET_TYPE OF
        'A': IF CHR IN ['A'..'Z','a'..'z','''','.','0'..'9','+','-',' ']
               THEN CHR_IN_SET := TRUE;
        'N': IF CHR IN ['0'..'9','.','+','-',' ']
               THEN CHR_IN_SET := TRUE;
        'L': IF CHR IN ['A'..'Z','a'..'z','''','.',' ']
               THEN CHR_IN_SET := TRUE;
        '-': CHR_IN_SET := TRUE;
      END;
    END;

  BEGIN  {COPY_FIELDS}
    GOTOXY(0,19);
    FOR I := 1 TO SCREEN_FIELDS DO
      BEGIN
        IF MAP_ARRAY[I].OLD_FLD_NO <> 0
          THEN
            WITH OLD_FIELDS[MAP_ARRAY[I].OLD_FLD_NO] DO
              BEGIN
                CHAR_INDEX := 1;
                WHILE ((CHAR_INDEX <= LENGTH(S_FLD)) AND (CHAR_INDEX <=
                                                   NEW_FIELDS[I].S_LEN)) DO
                  BEGIN
                    ONE_CHAR := S_FLD[CHAR_INDEX];
                    IF CHR_IN_SET(ONE_CHAR,MAP_ARRAY[I].SET_TYPE)
                      THEN 
                        NEW_FIELDS[I].S_FLD[CHAR_INDEX] := S_FLD[CHAR_INDEX]
                      ELSE
                        BEGIN     
                          MESSAGE(MAX_ROW,30,CONCAT('ERROR: Data is of ',
                             'wrong type for field ',S_ID),TRUE);
                          EXIT(COPY_DATA_FILE);
                        END;
                    CHAR_INDEX := CHAR_INDEX + 1;
                  END;
                S := S_FLD;
                EAT_SPACES(S,TRUE,TRUE);
                IF ((LENGTH(S) > NEW_FIELDS[I].S_LEN) AND (NOT TRUNC_FLDS_OK))
                  THEN
                    BEGIN
                      MSG := S_ID;
                      EAT_SPACES(MSG,TRUE,TRUE);
                      ERASE_EOS(0,MAX_ROW-1);
                      WRITELN('One or more of the fields',
                         ' is not large enough to hold all of the');
                      WRITE('data being copied ',
                              'to it. Proceed anyway? Y/N :');
                      WRITE(ALARM_BELL);
                      GOTOXY(47,MAX_ROW);
                      CH := ' ';
                      REPEAT
                        READ(KEYBOARD,CH);
                      UNTIL CH IN ['Y','y','N','n'];
                      IF (NOT (CH IN ['Y','y']))
                        THEN EXIT(COPY_DATA_FILE);
                      GOTOXY(0,22);
                      WRITE('                                        ',
                                             '                          ');
                      ERASE_EOS(0,MAX_ROW);
                      TRUNC_FLDS_OK := TRUE;
                    END;
              END;
      END;
  END; {COPY_FIELDS}

BEGIN {READ_TEST_COPY}
  GET_FILE(O_DEFI_NAME,OLD_FIELDS,GET_PROMPTS,RESULTS);
  ERASE_EOS(0,22);
  RESET(NEW_FILE,N_DATA_NAME);
  RESULTS := 0;
  OFFSET_RECS := 0;
  TRUNC_FLDS_OK := FALSE;
  END_NEW_FILE := FALSE;
  OLD_REC_NO := 1;
  NEW_REC_NO := 1;
  IF APPEND_FILE                  { Find last non-blank record }
    THEN
      WHILE RESULTS = 0 DO
        BEGIN
          READ_WRITE('R','N',NEW_REC_NO,NEW_REC_LEN,NEW_BUF,NEW_BLOCK,
                                                               RESULTS);
          IF ((IO_REC.A[3] <> 126) AND (RESULTS = 0))
            THEN OFFSET_RECS := NEW_REC_NO;
          NEW_REC_NO := NEW_REC_NO + 1;
        END;
  RESULTS := 0;
  NEW_REC_NO := OFFSET_RECS + 1;
  WHILE RESULTS = 0 DO
    BEGIN
      READ_OLD_RECORD(REC_IS_BLANK,RESULTS);
      IF RESULTS = 0 
       THEN
        BEGIN
         IF REC_IS_BLANK
           THEN
             BEGIN
               IF COPY_BLNKS
                THEN
                 BEGIN
                  READ_WRITE('R','N',NEW_REC_NO,NEW_REC_LEN,NEW_BUF,
                                                   NEW_BLOCK,RESULTS);
                  IF RESULTS = 0
                   THEN
                    BEGIN
                     FILLCHAR(IO_REC.A[0],NEW_REC_LEN,' ');
                     IO_REC.A[0] := NEW_REC_LEN;
                     IO_REC.A[1] := 16;
                     IO_REC.A[2] := 32;
                     IO_REC.A[3] := 126;
                     IO_REC.A[NEW_REC_LEN-1] := 42;
                     IO_REC.A[NEW_REC_LEN] := 13;
                     READ_WRITE('W','N',NEW_REC_NO,NEW_REC_LEN,
                                              NEW_BUF,NEW_BLOCK,RESULTS);
                     STR(OLD_REC_NO,S);
                     MESSAGE(MAX_ROW,40,CONCAT('STATUS: Copying record# ',
                                                                 S),FALSE);
                     NEW_REC_NO := NEW_REC_NO + 1;
                    END
                  ELSE END_NEW_FILE := TRUE;
                 END;
              END
             ELSE
               IF COPY_RECORD
                THEN
                  BEGIN
                    READ_WRITE('R','N',NEW_REC_NO,NEW_REC_LEN,
                                             NEW_BUF,NEW_BLOCK,RESULTS);
                    IF RESULTS = 0
                      THEN
                        BEGIN
                          IF CLEAR_FILE
                            THEN
                              FOR II := 1 TO SCREEN_FIELDS DO
                                BEGIN
                                  NEW_FIELDS[II].S_FLD := '';
                                  FOR I := 1 TO NEW_FIELDS[II].S_LEN DO
                                    INSERT(' ',NEW_FIELDS[II].S_FLD,1);
                                END
                            ELSE
                              LOAD_SCREEN('A',NEW_FIELDS,NUM_NEW_FLDS,
                                                               IO_REC.B);
                          COPY_FIELDS;
                          BUILD_RECORD;
                          STR(OLD_REC_NO,S);
                          MESSAGE(MAX_ROW,40,CONCAT('STATUS: Copying record# ',
                                                                  S),FALSE);
                          READ_WRITE('W','N',NEW_REC_NO,NEW_REC_LEN,NEW_BUF,
                                                         NEW_BLOCK,RESULTS);
                          NEW_REC_NO := NEW_REC_NO + 1;
                        END
                    ELSE END_NEW_FILE := TRUE;
                   END;
        END;
      OLD_REC_NO := OLD_REC_NO + 1;
    END;
  IF CLEAR_FILE
    THEN
      BEGIN
        II := NEW_REC_NO;
        RESULTS := 0;
        WHILE RESULTS = 0 DO
         BEGIN
          READ_WRITE('R','N',II,NEW_REC_LEN,NEW_BUF,NEW_BLOCK,RESULTS);
          IF RESULTS = 0
           THEN
            BEGIN
             FILLCHAR(IO_REC.A[0],NEW_REC_LEN,' ');
             IO_REC.A[0] := NEW_REC_LEN;
             IO_REC.A[1] := 16;
             IO_REC.A[2] := 32;
             IO_REC.A[3] := 126;
             IO_REC.A[NEW_REC_LEN-1] := 42;
             IO_REC.A[NEW_REC_LEN] := 13;
             READ_WRITE('W','N',II,NEW_REC_LEN,NEW_BUF,NEW_BLOCK,RESULTS);
             II := II + 1;
            END
         END;
      END;
  NEW_REC_NO := NEW_REC_NO - 1;
  IF ((NEW_REC_NO >= 1) OR (CLEAR_FILE))
    THEN                         { Forces NEW_BUF to be written after }
      BEGIN                      { last record has been written to it }
        READ_WRITE('R','N',NEW_REC_NO,NEW_REC_LEN,NEW_BUF,NEW_BLOCK,RESULTS);
        NEW_BLOCK := -1;
        READ_WRITE('W','N',NEW_REC_NO,NEW_REC_LEN,NEW_BUF,NEW_BLOCK,RESULTS);
      END;
  STR(NEW_REC_NO-OFFSET_RECS,S);
  IF ((S = '0') AND (NOT(END_NEW_FILE)))
    THEN MSG := 'Found no records meeting specifications'
    ELSE
      IF END_NEW_FILE
        THEN MSG := CONCAT('File full, ',S,' records copied.')
        ELSE MSG := CONCAT('Copy complete, ',S,' records copied.');
  ERASE_EOS(0,22);
  MESSAGE(MAX_ROW,40,MSG,TRUE);
  CLOSE(NEW_FILE,LOCK);
END; {READ_TEST_COPY}

Procedure MESSAGE{M_ROW,M_COL :Integer; MSG :String; DING: Boolean};
{ Procedure displays messages at the message row and column. }

  begin {MESSAGE}
    gotoxy(M_COL,M_ROW);  write(MSG);
    if DING then write(ALARM_BELL);
  end; {MESSAGE}

Procedure EAT_SPACES{var TEMP :String; LEFT_EAT,RIGHT_EAT :Boolean};
{ Procedure to remove the spaces from either or both sides of a string. }

  begin {EAT SPACES}
   if LEFT_EAT then EATSPL(TEMP);
   if RIGHT_EAT then EATSPR(TEMP);
  end; {EAT SPACES}

PROCEDURE LEAVE{MSG : STRING};
  BEGIN
    MESSAGE(MAX_ROW,38,MSG,TRUE);
    EXIT(COPY_DATA_FILE);
  END;

BEGIN {COPY_DATA_FILE}
  INITIALIZE;
  GET_FILES;
  CREATE_MAP_ARRAY;
  GET_COPY_INFO;
  READ_TEST_COPY;
END.


========================================================================================
DOCUMENT :usus Folder:VOL25:ud.list.text
========================================================================================

{xL #5:LSTLST.TEXT}
PROGRAM LIST;

{  Once a data base has been defined, this set of procedures allows the
     operator to list out the data in the data base records. }

  uses {$U sh.screen.unit} SCREEN40;

  CONST
     MAX_TESTS    = 52;
     SCREEN_TESTS = 13;
  
  TYPE
    OPS = (LT,GT,EQ,LE,GE,NE);
    TEST_REC = PACKED RECORD
                 FIELD_LOC : 0..SCREEN_FIELDS;
                 OPERATOR  : OPS;
                 VALUE     : STRINGFL;
               END;
    TEST_DEF = ARRAY[1..MAX_TESTS] OF TEST_REC;
    STRING255 = STRING[255];

  VAR
    GET_FIELDS,MAINT_FIELDS  : SCREEN_ARR;  { Array to hold data fields }
    GET_PROMPTS : PROMPT_ARR; { Array to hold screen prompts }
    GET_RESULTS,                 { 0 If 'GET.SCRN' loaded }
    RESULTS,I,II,INDEX,DB_RECNO,REC_LEN,NUM_FLDS,CURRENT_BLOCK: Integer;
    EXXIT,CH,EXIT_KEY : CHAR;
    VERSION :  String[28];
    PROMPT1 : STRING[29];
    PROMPT2 : STRING[31];
    VOLUME,               { Data base volume }
    LIST_TYPE,            { Output file type }
    LIST_VOL  :String[7]; { Print format volume }
    NAME,                 { Data base Name }
    LIST_NAME :String[10];{ Print format name }
    DB_NAME   :String[18];{ Volume + Data Base Name }
    WRITE_FILE_NAME : string[28]; { Output file name }
    STR_RECNO : String[5];
    IO_REC    : Packed record      { String to hold data base record }
                case Integer of
                  1: (A: Packed Array[0..255] of 0..255);
                  2: (B: String[255]);
                end;
    DATA_FILE : File;
                  
  Procedure RECORD_LENGTH(var S_ARRAY: SCREEN_ARR);
    forward;
  
  Function VAL(S: string; var NUM: integer): boolean;
    forward;
    
  Procedure MESSAGE(M_ROW,M_COL: Integer; MSG: String; DING: Boolean);
    forward;
  
  Segment Procedure INITIALIZE;
  {  Procedure initilizes everything to begin maintaining the data base. }
   var I: Integer;
    begin  {INITIALIZE}
     for I:=1 to SCREEN_FIELDS do 
      with GET_FIELDS[I] do
       begin
        S_ROW := END_SCREEN;  S_COL := 15;
        S_MIN := 0;           S_TYP := 'V';
        S_JUS := 'L'; S_NA  := 'S';         S_SKIP := False;
        S_DEF := '';  S_FLD := ''; S_ID := '';
       end;
     for I:=1 to SCREEN_FIELDS do
      with MAINT_FIELDS[I] do
       begin
        S_ROW := END_SCREEN;  S_COL := 15;
        S_MIN := 0;           S_TYP := 'V';  S_LEN := 0;
        S_JUS := 'L';         S_NA  := 'S';  S_SKIP := False;
        S_DEF := '';          S_FLD := '';   S_ID := '';
       end;
     for I:=1 to PROMPT_FIELDS do
      with GET_PROMPTS[I] do
       begin
        P_ROW:=END_SCREEN;  P_COL:=0;  P_FLD:='';
       end;
     with GET_FIELDS[1] do
      begin
       S_ID := 'VOL';  S_ROW := 8; S_LEN := 7;
      end;
     with GET_FIELDS[2] do
       begin
         S_ID := 'NAME';  S_ROW := 10; S_LEN := 10;
       end;
     with GET_PROMPTS[1] do
       begin
         P_ROW := 8;  P_FLD := 'Volume    :';
       end;
     with GET_PROMPTS[2] do
       begin
         P_ROW := 10;  P_FLD := 'Name      :';
       end;
     with GET_PROMPTS[3] do
       begin
         P_ROW := 12;  P_FLD := 'Type      :    SCRN and TEXT';
       end;
     VERSION:='Version  IV.0';
     PROMPT1:='Get,Save format,Output file';
     PROMPT2:='Change,Export,List,Tests,Quit ?';
     for I:=1 to 27 do
      if not(PROMPT1[I] in['A'..'Z']) 
        then PROMPT1[I]:=chr(ord(PROMPT1[I])+128);
     for I:=1 to 29 do
      if not(PROMPT2[I] in['A'..'Z']) 
        then PROMPT2[I]:=chr(ord(PROMPT2[I])+128);
     DB_RECNO := 1;
     CURRENT_BLOCK := -1;
     write_file_name:=''; { Dec 29 }
    end;   {INITIALIZE}

  Segment Procedure GET_DATA_BASE;
  { Procedure gets the Data Base Definition from the disk. }
  var
    DATA_NAME,            { Data file name }
    DEFI_NAME:String[23]; { Data Base Definition file name }
    begin  {GET_DATA_BASE}  
      ERASE_EOS(0,0);
      writeln(' ':25,'PRINT A DATA BASE');
      writeln(' ':25,'=================');
      writeln(' ':25,VERSION);
      writeln;
      writeln(
      'Copyright (C) 1981 by Texas Instruments Corporate Engineering Center');
      writeln('All rights reserved as per the Computer Software ',
                                                     'Copyright Act of 1980');
      DISPLAY_PROMPTS(GET_PROMPTS,0,0,0,23);
      DISPLAY_SCREEN(GET_FIELDS,0,0,0,23);
      MESSAGE(MAX_ROW,0,'<ENTER> to execute, <ESC> to abort',False);
      repeat
        SCREEN(GET_FIELDS,true,0,0,0,0,MAX_ROW,MAX_ROW,40,EXXIT);
        if EXXIT = ESC_KEY then exit(LIST);
        VOLUME := GET_FIELDS[FIND('VOL',GET_FIELDS)].S_FLD;
        EATSPR(VOLUME);
        NAME   := GET_FIELDS[FIND('NAME',GET_FIELDS)].S_FLD;
        EATSPR(NAME);
        DB_NAME := concat(VOLUME,':',NAME);
        DEFI_NAME := concat(DB_NAME,'.SCRN');
        DATA_NAME := concat(DB_NAME,'.TEXT');
        GET_FILE(DEFI_NAME,MAINT_FIELDS,GET_PROMPTS,RESULTS);
        if RESULTS = 0
          then
            begin
             {$I-}
              reset(DATA_FILE,DATA_NAME);
             {$I+}
              if IORESULT<>0
                then MESSAGE(MAX_ROW,40,'ERROR: No data file found',True)
                else exit(GET_DATA_BASE);
            end
          else MESSAGE(MAX_ROW,40,'ERROR: Unknown Data Base',True);
      until False;
    end;   {GET_DATA_BASE}

 Segment Procedure ACCESS_DATA_BASE;
  { Procedure performs all the adds, examines and deletes for the data base }
  var DISPLAY_FLAG:Boolean;
      START_LIST:Integer;
      ESC:boolean; { Mar 16 }
      BUFFER: Packed Array[0..511] of 0..255;
      LIST_VOL_NAME :String[23];   { Print format file name }
      EXPRT_FILE_NAME :String[28]; { Export file name }
      IO_REC    : Packed record      { String to hold data base record }
                case Integer of
                  1: (A: Packed Array[0..255] of 0..255);
                  2: (B: String[255]);
                end;
      TEST_ARRAY : TEST_DEF;
      TESTS,ALL_TESTS : BOOLEAN;
  
 Segment Procedure GET_SAVE_FORMAT(GS_COMMAND:char; var ESC: boolean);
  
  { Procedure loads or saves printing format specification on disk. }
    
    var 
      S: string;
      P_FIELDS,TEMP_FIELDS: SCREEN_ARR;
      P_PROMPTS,TEMP_PROMPTS: PROMPT_ARR;
      I: integer;
    begin
      FOR I := 1 TO SCREEN_FIELDS DO
        WITH P_FIELDS[I] DO
          BEGIN
            S_ROW := END_SCREEN; S_COL := 15; S_MIN := 0; S_TYP := 'V';
            S_JUS := 'L'; S_NA := 'S'; S_SKIP := FALSE; S_DEF := '';
            S_FLD := '';
          END;
      FOR I := 1 TO PROMPT_FIELDS DO
        WITH P_PROMPTS[I] DO
          BEGIN
            P_ROW := END_SCREEN; P_COL := 0; P_FLD := '';
          END;
     with P_FIELDS[1] do
      begin
       S_ID := 'VOL';  S_ROW := 8; S_LEN := 7;
      end;
     with P_FIELDS[2] do
       begin
         S_ID := 'NAME';  S_ROW := 10; S_LEN := 10;
       end;
     with P_PROMPTS[1] do
       begin
         P_ROW := 8;  P_FLD := 'Volume    :';
       end;
     with P_PROMPTS[2] do
       begin
         P_ROW := 10;  P_FLD := 'Name      :';
       end;
      if CH='O' then begin
        with P_PROMPTS[3] do begin
          P_ROW:=12;
          P_FLD:='Type      :';
        end;
        with P_FIELDS[3] do begin
          S_ID:='TYPE';
          S_ROW:=12;
          S_LEN:=5;
        end;
      end
      else begin
        with P_PROMPTS[3] do begin
          P_ROW:=12;
          P_FLD:='Type      :    SCRN and TEXT';
        end;
        P_FIELDS[3].S_ROW:=END_SCREEN;
      end;
      ERASE_EOS(0,0);
      if GS_COMMAND='G' then S:='GET PRINTING FORMAT'
        else if GS_COMMAND='S' then S:='SAVE PRINTING FORMAT'
          else if GS_COMMAND='E' then S:='EXPORT FILE NAME'
            else S:='OUTPUT FILE NAME';
      writeln(' ':25,S);
      writeln(' ':25,'====================':LENGTH(S));
      DISPLAY_PROMPTS(P_PROMPTS,0,0,0,23);
      gotoxy(0,12);
      if GS_COMMAND <>'O' then
        if GS_COMMAND = 'E' then write('Type      :    TEXT         ')
          else write('Type      :    LIST         ');
      MESSAGE(MAX_ROW,0,'<ENTER> to execute, <ESC> to abort',False);
      DISPLAY_SCREEN(P_FIELDS,0,0,0,23);
      repeat
        SCREEN(P_FIELDS,true,0,0,0,0,MAX_ROW,MAX_ROW,40,EXXIT);
        ERASE_EOL(MAX_ROW,40);
        if EXXIT = ENTER_KEY
          then
            begin
              ESC:=false;
              LIST_VOL := P_FIELDS[FIND('VOL',P_FIELDS)].S_FLD;
              EATSPR(LIST_VOL);
              LIST_NAME := P_FIELDS[FIND('NAME',P_FIELDS)].S_FLD;
              EATSPR(LIST_NAME);
              if GS_COMMAND = 'O' then begin  { Jan 8 }
                LIST_TYPE:=P_FIELDS[FIND('TYPE',P_FIELDS)].S_FLD;
                IF (LIST_VOL='') AND (LIST_NAME='') THEN WRITE_FILE_NAME:=''
                else WRITE_FILE_NAME:=concat(LIST_VOL,':',LIST_NAME,'.',
                  LIST_TYPE);
                exit(GET_SAVE_FORMAT);
              end
              else
                if GS_COMMAND = 'E' then begin  { Dec 29 }
                  EXPRT_FILE_NAME := concat(LIST_VOL,':',LIST_NAME,'.TEXT');
                  exit(GET_SAVE_FORMAT);
                end
                else LIST_VOL_NAME := concat(LIST_VOL,':',LIST_NAME,'.LIST');
              if GS_COMMAND = 'G'
               then
                begin
                 GET_FILE(LIST_VOL_NAME,TEMP_FIELDS,TEMP_PROMPTS,GET_RESULTS);
                 if GET_RESULTS <> 0
                  then MESSAGE(MAX_ROW,40,'ERROR: Unknown printing format',
                                                                       True)
                   else begin
                     I := FIND('WIDTH',TEMP_FIELDS);
                     if I = 0 then
                       MESSAGE(MAX_ROW,40,'ERROR: Format file is obsolete',
                                                                        True)
                     else begin
                       GET_FIELDS:=TEMP_FIELDS; GET_PROMPTS:=TEMP_PROMPTS;
                       exit(GET_SAVE_FORMAT);
                     end
                   end
                 end
                else  { GS_COMMAND = 'S' }
                 begin
                  SAVE_FILE(LIST_VOL_NAME,GET_FIELDS,GET_PROMPTS,
                                                                GET_RESULTS);
                  if GET_RESULTS <> 0
                   then MESSAGE(MAX_ROW,40,
                               'ERROR: Unable to save printing format',True)
                   else exit(GET_SAVE_FORMAT);
                  end;
            end
          else begin
            ESC:=true;
            exit(GET_SAVE_FORMAT);
          end;
      until False;
  end;

 SEGMENT Procedure READ_WRITE(RW_COMMAND: Char;
                              var REC_NO,REC_LEN,IO_RET_CODE:Integer);
  var IO_BLOCKS,START_POSITION,TWO_BLOCK,START_REC,BYTE_TWO_BLOCK,
      BLOCK_NO,REC_NUM,FIRST_MOV_LEN,CHAR_OFFSET: Integer;

  begin {READ_WRITE}
 {$I-}
   IO_RET_CODE:=-1;
   REC_NUM:=REC_NO-1;
   if REC_NUM<0 then REC_NUM:=0;
   TWO_BLOCK:=REC_NUM div (1023 div REC_LEN);  (* 1024 correction Dec 5 1980 *)
   START_REC:=TWO_BLOCK*(1023 div REC_LEN);  (* 1024 correction Dec 5 1980 *)
   BYTE_TWO_BLOCK:=(REC_NUM-START_REC)*REC_LEN;
   BLOCK_NO:=(TWO_BLOCK*2)+2;
   if BYTE_TWO_BLOCK>=512  (* = correction Dec 5 1980 *)
     then
      begin
       BLOCK_NO:=BLOCK_NO+1;
       CHAR_OFFSET:=BYTE_TWO_BLOCK-512;
      end
     else CHAR_OFFSET:=BYTE_TWO_BLOCK;
   if CHAR_OFFSET+REC_LEN>512
     then
      begin
       if CURRENT_BLOCK<>BLOCK_NO
         then
          begin
           IO_BLOCKS:=blockread(DATA_FILE,BUFFER,1,BLOCK_NO);
           if IO_BLOCKS=0 then exit(READ_WRITE);
          end;
       FIRST_MOV_LEN:=512-CHAR_OFFSET;
       if RW_COMMAND='W'
         then
           begin
            moveleft(IO_REC.A[1],BUFFER[CHAR_OFFSET],FIRST_MOV_LEN);
            IO_BLOCKS:=blockwrite(DATA_FILE,BUFFER,1,BLOCK_NO);
            if IO_BLOCKS=0 then exit(READ_WRITE);
           end
         else moveleft(BUFFER[CHAR_OFFSET],IO_REC.A[1],FIRST_MOV_LEN);
       BLOCK_NO:=BLOCK_NO+1;
       IO_BLOCKS:=blockread(DATA_FILE,BUFFER,1,BLOCK_NO);
       if IO_BLOCKS=0 then exit(READ_WRITE);
       if RW_COMMAND='W'
         then
          begin
           moveleft(IO_REC.A[FIRST_MOV_LEN+1],BUFFER[0],REC_LEN-FIRST_MOV_LEN);
           IO_BLOCKS:=blockwrite(DATA_FILE,BUFFER,1,BLOCK_NO);
           if IO_BLOCKS=0 then exit(READ_WRITE);
          end
         else 
           moveleft(BUFFER[0],IO_REC.A[FIRST_MOV_LEN+1],REC_LEN-FIRST_MOV_LEN);
      end
    else
     begin
      if CURRENT_BLOCK<>BLOCK_NO
        then
         begin
          IO_BLOCKS:=blockread(DATA_FILE,BUFFER,1,BLOCK_NO);
          if IO_BLOCKS=0 then exit(READ_WRITE);
         end;
      if RW_COMMAND='W'
         then
          begin
           moveleft(IO_REC.A[1],BUFFER[CHAR_OFFSET],REC_LEN);
           IO_BLOCKS:=blockwrite(DATA_FILE,BUFFER,1,BLOCK_NO);
           if IO_BLOCKS=0 then exit(READ_WRITE);
          end
         else moveleft(BUFFER[CHAR_OFFSET],IO_REC.A[1],REC_LEN);
     end;
    CURRENT_BLOCK:=BLOCK_NO;
    if IO_REC.A[3]=0 then exit(READ_WRITE);
    IO_RET_CODE:=0;
    IO_REC.A[0]:=REC_LEN;
  {$I+}
  end;  {READ_WRITE}
  
SEGMENT Procedure LOAD_SCREEN(LOAD_COMMAND :Char; var S_ARRAY: SCREEN_ARR;
                    NUMBER_FLDS:INTEGER; var RECORD_STRING: STRING255);
  { Procedure load the screen array from a record obtained from the disk  }
  { file.                                                                 }

   var LOAD_INDEX,T_INDEX,COPY_INDEX,COPY_LENGTH : Integer;

   begin {LOAD_SCREEN}
    COPY_INDEX := 4;
    LOAD_INDEX:=1;
    while LOAD_INDEX <= NUMBER_FLDS  do
     with S_ARRAY[LOAD_INDEX] do
      begin
       COPY_LENGTH:=S_LEN;
       if (LOAD_COMMAND = 'A') or
          ((LOAD_COMMAND = 'D') and (S_ID = COPY(S_DEF,2,LENGTH(S_DEF)-2)))
         then
           S_FLD:=copy(RECORD_STRING,COPY_INDEX,COPY_LENGTH)
         else
          begin
            IF (S_DEF = '') OR (S_DEF = COPY(UNDERLINE,1,1))
              THEN
               BEGIN
                 S_FLD := ' ';
                 FOR T_INDEX := 1 TO S_LEN-1 DO INSERT(' ',S_FLD,T_INDEX);
               END
              ELSE  { s_def<>''  Mar 12 }
                if s_def[1]<>'[' then begin
                  s_fld:=' ';
                  FOR T_INDEX := 1 TO S_LEN-1 DO INSERT(' ',S_FLD,T_INDEX)
                end
                else begin { s_def[1]='[' }
                  t_index:=find(copy(s_def,2,length(s_def)-2),S_ARRAY);
                  if t_index=0 then s_fld:=s_def
                    else s_fld:=S_ARRAY[t_index].s_fld;
                end;
          end;
        COPY_INDEX:=COPY_INDEX + COPY_LENGTH;
        LOAD_INDEX:=LOAD_INDEX + 1;
      end; {with/while}
   end; {LOAD SCREEN}

SEGMENT FUNCTION LIST_RECORD : BOOLEAN;
  
  { Determines whether a record is to be copied or not. }

  VAR
    BLANK,PASSED : BOOLEAN;
    F : STRINGFL;

  FUNCTION COMPARE(TEST : TEST_REC): BOOLEAN;

    { Function is true if test passes, false if not. }

    VAR
      OLD_VAL : STRINGFL;
      NUM1,NUM2 : REAL;
     
     function STR_TO_REAL(var S: STRING; var NUM: REAL): boolean;
      
      { Returns a value of true and the real value in NUM if
        string can be converted to real, is set to false otherwise }
      
      var
        I : integer;
        FACTOR : REAL;
        D_PT : BOOLEAN;
      begin
        STR_TO_REAL:=false;
        I:=1;
        D_PT := FALSE;
        NUM:=0;
        EATSPL(S); EATSPR(S);
        if length(S)=0 then exit(STR_TO_REAL);
        WHILE ((I <= LENGTH(S)) AND (NOT D_PT)) DO
          BEGIN
            if S[I] in ['0'..'9'] then
              NUM:=10*NUM+ord(S[I])-ord('0')
            ELSE IF S[I] = '.' THEN D_PT := TRUE
            else exit(STR_TO_REAL);
            I := I + 1;
          END;
        IF D_PT
          THEN
            BEGIN
              FACTOR := 10;
              WHILE I <= LENGTH(S) DO
                IF S[I] IN ['0'..'9']
                  THEN
                    BEGIN
                      NUM := NUM + ((ord(S[I])-ord('0'))/FACTOR);
                      FACTOR := FACTOR * 10;
                      I := I + 1;
                    END
                  ELSE EXIT(STR_TO_REAL);
            END;
        STR_TO_REAL:=true;
      end;  { STR_TO_REAL }
      
    BEGIN   { COMPARE }
      COMPARE := FALSE;
      OLD_VAL := MAINT_FIELDS[TEST.FIELD_LOC].S_FLD;
      EATSPL(OLD_VAL);  EATSPR(OLD_VAL);
      WITH TEST DO
        IF ((STR_TO_REAL(OLD_VAL,NUM1)) AND (STR_TO_REAL(VALUE,NUM2)))
          THEN     { Compare as reals if possible }
            CASE TEST.OPERATOR OF
              LT: COMPARE := NUM1 < NUM2;
              GT: COMPARE := NUM1 > NUM2;
              EQ: COMPARE := NUM1 = NUM2;
              LE: COMPARE := NUM1 <= NUM2;
              GE: COMPARE := NUM1 >= NUM2;
              NE: COMPARE := NUM1 <> NUM2;
            END
          ELSE     { Otherwise compare as strings }
            CASE TEST.OPERATOR OF
              LT: COMPARE := OLD_VAL < VALUE;
              GT: COMPARE := OLD_VAL > VALUE;
              EQ: COMPARE := OLD_VAL = VALUE;
              LE: COMPARE := OLD_VAL <= VALUE;
              GE: COMPARE := OLD_VAL >= VALUE;
              NE: COMPARE := OLD_VAL <> VALUE;
            END;
    END; {COMPARE}

  BEGIN {LIST_RECORD}
    LIST_RECORD := TRUE;
    IF TESTS                 { Then see if record meets the user's tests }
     THEN
      BEGIN
       IF ALL_TESTS          { LIST_RECORD set to true if all tests pass }
         THEN
           BEGIN
             I := 1;
             PASSED := TRUE;
             WHILE ((I <= MAX_TESTS) AND (PASSED)) DO
               BEGIN
                 IF TEST_ARRAY[I].FIELD_LOC > 0
                   THEN PASSED := COMPARE(TEST_ARRAY[I]);
                 I := I + 1;
               END;
             LIST_RECORD := PASSED;
           END
         ELSE
           BEGIN            {LIST_RECORD set to true if any test passes}
             I := 1;
             PASSED := FALSE;
             WHILE ((I <= MAX_TESTS) AND (NOT PASSED)) DO
               BEGIN
                 IF TEST_ARRAY[I].FIELD_LOC > 0
                   THEN PASSED := COMPARE(TEST_ARRAY[I]);
                 I := I + 1;
               END;
             LIST_RECORD := PASSED;
           END;
      END;
  END;
  
SEGMENT Procedure EXPORT(EXP_FILENAME: String;
                         var DATARRAY: SCREEN_ARR;
                         var OUT_FILE: String);
 
{ Data export unit Version II.2.B.2b modified for UDE Jan 1981}

 const 
   MAXSIZE  =  500;
   AMT_MEM  = 1300;
   MAXLINES =   10;

 
 type 
   BUFR   = Array[0..0] of String[255];
   STR255 = String[255];
   EXP_RECORD = record
     START,LENGTH: integer;
   end;

 var
   EXPFILELNS : Integer;
   HEAPPTR: ^BUFR;
   OUT,EXPFILE: Text;
   NUMERIC,EATLEFT,EATRIGHT :Boolean;
   IDNO,LNS,N,I,J: Integer;
   CH :String[1];
   IDVAL,IDNAME,LINE_IMAGE: String;
   LINE: STR255;
   RESULT: Integer;
   EXP_ARRAY : array[1..SCREEN_FIELDS] of EXP_RECORD;

Segment Procedure EXPORT_ARRAY;
var
  i,n: integer;
begin
  i:=1; n:=4;
  while i<=screen_fields do
    if maint_fields[i].s_row=end_screen then i:=screen_fields+1
    else
      with exp_array[i] do begin
        start:=n;
        length:=maint_fields[i].s_len;
        n:=length+n;
        i:=i+1;
      end;
end;  {export_array}

Segment Procedure GET_EXPFILE(EXP_FILENAME: String;
                      var RESULT: Integer);
 var QUIT: Boolean;

 begin {GET_EXPFILE}
  {$R-}
   EXPFILELNS:=0;
   repeat
    readln(EXPFILE,HEAPPTR^[EXPFILELNS]);  
    EXPFILELNS:=EXPFILELNS+1;
{   if MEMAVAIL<MAXSIZE then
     begin
      QUIT:=True;
      RESULT:=99;
     end;                }
   until (eof(EXPFILE)) or (QUIT) or (EXPFILELNS = MAXLINES);
  {$R+}
   EXPFILELNS:=EXPFILELNS-1;
 end; {GET_EXPFILE}
 
Segment Procedure CLOSE_EXPFILE;
 begin {CLOSE EXPFILE}
     CLOSE(EXPFILE);
     VARDISPOSE(HEAPPTR,AMT_MEM);
 end; {CLOSE EXPFILE}

 Segment Procedure ERROR(E :Integer);
  var E_MSG: String;
      CH: Char;
      I: Integer;
  begin
   E_MSG:='I/O ERROR in export routine.';
   case E of
     1: E_MSG:='ERROR: Illegal character in text.';
     2: E_MSG:='ERROR: Can not open output file.';
     3: E_MSG:='ERROR: Illegal data field ID.';
     4: E_MSG:='ERROR: Unexpected end of line.';
     5: E_MSG:='ERROR: Can not open export file.';
     6: E_MSG:='ERROR: Buffer Overflow.';
     7: E_MSG:='ERROR: Cannot get memory';
     end; {case}
   MESSAGE(MAX_ROW-1,40,E_MSG,true);
   MESSAGE(MAX_ROW,40,'Press SPACE to continue',false);
   read(CH);
   exit(EXPORT);
  end; {ERROR}
  
 begin {EXPORT}
  erase_eol(0,max_row);
  MESSAGE(MAX_ROW,40,'STATUS: Export in progress',false);
  {$i-}
  if OUTFILE='' then rewrite(OUT,'PRINTER:')
    else Rewrite(OUT,OUTFILE);
  if IORESULT<>0 then ERROR(2);
  {$i+}
  EXPORT_ARRAY;  { Jan 9 }
  IF VARNEW(HEAPPTR,AMT_MEM) <> AMT_MEM
    THEN ERROR(7);
  DB_RECNO:=1;
  READ_WRITE('R',DB_RECNO,REC_LEN,RESULT);
  IF TESTS
    THEN LOAD_SCREEN('A',MAINT_FIELDS,NUM_FLDS,IO_REC.B);
  WHILE RESULT=0 do begin  { Jan 9 }
    if ((IO_REC.A[3]=ord('*')) and (LIST_RECORD))
     then                   { Jan 9 }
       BEGIN
        RESET(EXPFILE,EXP_FILENAME);
        IF IO_RESULT <> 0 THEN ERROR(5);
        REPEAT
          Get_Expfile(EXP_FILENAME,RESULT);
          if RESULT=99 then ERROR(6)
            else if RESULT<>0 then ERROR(5);
          for I:=0 to EXPFILELNS do begin
           {$R-}
           LINE_IMAGE:='';  N:=0;  LINE:=HEAPPTR^[I];
           repeat
            CH:=' '; N:=N+1;
            if length(LINE)>0 then CH[1]:=LINE[N];
            if CH[1]='{' then
              begin { ID }
                EATRIGHT:=False;  EATLEFT:=False;
                N:=N+1;  CH[1]:=LINE[N];
                if CH[1]='*' then  begin  EATLEFT:=True;  IDNAME:='';  end
                 else IDNAME:=CH;
                while CH[1]<>'}' do
                 begin
                  N:=N+1;  CH[1]:=LINE[N];
                  if CH[1]=RETURN_KEY 
                    then ERROR(4) 
                    else IDNAME:=concat(IDNAME,CH);
                  if CH[1]='*' then
                   begin
                    if (IDNAME='') then ERROR(3);
                    EATRIGHT:=True;
                    N:=N+1;  CH[1]:=LINE[N];
                    if CH[1]<>'}' then ERROR(4);
                   end; {then}
                 end; {while}
                delete(IDNAME,length(IDNAME),1);
                IDVAL:=' ';  NUMERIC:=True;
                for J:=1 to length(IDNAME) do
                   if not(IDNAME[J] in['0'..'9']) then NUMERIC:=False;
                if NUMERIC then begin
                  if VAL(IDNAME,IDNO) then IDVAL[1]:=chr(IDNO);
                 end
                 else
                  begin
                   IDNO:=FIND(IDNAME,DATARRAY);
                   if IDNO>0 then IDVAL:=copy(IO_REC.B,EXP_ARRAY[IDNO].START,
                       EXP_ARRAY[IDNO].LENGTH)
                     else IDVAL:=concat('{',IDNAME,'}');
                   if EATLEFT then EATSPL(IDVAL);
                   if EATRIGHT then EATSPR(IDVAL);
                  end;
                LINE_IMAGE:=concat(LINE_IMAGE,IDVAL);
              end { ID }
             else LINE_IMAGE:=concat(LINE_IMAGE,CH);
            until N>=length(LINE);
          {if SHOW then writeln(LINE_IMAGE);} {Jan 8}
           writeln(OUT,LINE_IMAGE);
          end; { for }
        UNTIL EOF(EXPFILE);
        CLOSE(EXPFILE);
       END;
     DB_RECNO:=DB_RECNO+1;
     READ_WRITE('R',DB_RECNO,REC_LEN,RESULT);
     IF TESTS
       THEN LOAD_SCREEN('A',MAINT_FIELDS,NUM_FLDS,IO_REC.B);
   end;  {while result=0}
  {$R+}
  close(OUT,lock);
  close_expfile;
 end; {EXPORT}

 SEGMENT PROCEDURE GET_TEST_ARRAY;

  { Gets the tests to be made on each record of the "from" data file
      before it is copied to the "to" data file. Only a limited no.
      of these tests are displayed on the screen at any one time
      (limited by the no. of possible fields in GET_FIELDS).       }

  VAR
    FIRST_TEST,NUM_TESTS  : INTEGER;
    GET_FIELDS : SCREEN_ARR;
    ERROR : BOOLEAN;
    S,MSG : STRING;
    
SEGMENT PROCEDURE USER_TESTS;
  VAR
    NUM_FIELDS,ROW,ID_COL,ID_ROW : INTEGER;
    PROMPT : STRING;
  BEGIN
    ERASE_EOS(0,0);
    WRITE('Comparison tests to be made on fields of each record:');
    GOTOXY(62,0);
    WRITE('Choose from the');
    GOTOXY(62,1);
    WRITE('following fields:');
    GOTOXY(0,18);
    WRITE('Valid operators are:  < , > , = , <= , >= , or <>');
    GOTOXY(0,20);
    WRITE('Currently viewing tests 1 - 13');
    GOTOXY(0,22);
    PROMPT := 'Get, Save tests, Change, Next, Back, Quit:';
    FOR I := 1 TO LENGTH(PROMPT) DO
      IF NOT(PROMPT[I] IN ['A'..'Z'])
        THEN PROMPT[I] := CHR(ORD(PROMPT[I])+128);
    WRITE(PROMPT);
    I := 1;
    ROW := 4;
    WHILE I < SCREEN_FIELDS-1 DO
      BEGIN
        WITH GET_FIELDS[I] DO          { Field }
          BEGIN
            S_ROW := ROW; S_COL := 0; S_LEN := 8; S_MIN := 0;
            S_JUS := 'L'; S_NA := 'S'; S_SKIP := TRUE;
            S_DEF := ''; S_FLD := ''; S_TYP := 'V';
          END;
        WITH GET_FIELDS[I+1] DO        { Operator }
          BEGIN
            S_ROW := ROW; S_COL := 12; S_LEN := 2; S_MIN := 0;
            S_JUS := 'L'; S_NA := 'S'; S_SKIP := TRUE;
            S_DEF := ''; S_FLD := ''; S_TYP := 'V';
          END;
        WITH GET_FIELDS[I+2] DO        { Value }
          BEGIN
            S_ROW := ROW; S_COL := 18; S_LEN := 40; S_MIN := 0;
            S_JUS := 'L'; S_NA := 'S'; S_SKIP := TRUE;
            S_DEF := ''; S_FLD := ''; S_TYP := 'V';
          END;
        ROW := ROW + 1;
        I := I + 3;
      END;
    WITH GET_FIELDS[SCREEN_FIELDS] DO
      BEGIN
        S_ROW := END_SCREEN; S_LEN := 0; S_FLD := '';
      END;
    DISPLAY_SCREEN(GET_FIELDS,0,0,0,23);
    GOTOXY(0,2);
    WRITE('FIELD ID  OPERATOR                 VALUE');
    NUM_FIELDS := 0;
    I := 1;
    WHILE I <= SCREEN_FIELDS DO
      BEGIN
        IF MAINT_FIELDS[I].S_ROW = END_SCREEN 
          THEN I := SCREEN_FIELDS
        ELSE NUMFIELDS := NUMFIELDS + 1;
        I := I + 1;
      END;

    { The following code writes out the ids the user may choose from
      in testing the fields to be copied. If there are less than 20,
      they are written out in a single column, otherwise they are
      written out alternating between two columns.                   }

    IF NUM_FIELDS <= 20
      THEN ID_COL := 66    { Center a single column }
      ELSE ID_COL := 62;   { Center double columns  }
    ID_ROW := 3;
    I := 1;
    WHILE I <= NUM_FIELDS DO
      BEGIN
        GOTOXY(ID_COL,ID_ROW);
        WRITE(MAINT_FIELDS[I].S_ID);
        IF ID_COL = 62
          THEN          { Alternate ids between 1st and 2nd cols }
            ID_COL := 72
          ELSE
            IF ID_COL = 66
              THEN ID_ROW := ID_ROW + 1
              ELSE IF ID_COL = 72
                     THEN
                       BEGIN
                         ID_COL := 62;
                         ID_ROW := ID_ROW + 1;
                       END;
        I := I + 1;
      END;
  END; {USER_TESTS}

SEGMENT PROCEDURE DISPLAY_TESTS(TEST_NO : INTEGER);
  
  { Transfers the appropriate section of TEST_ARRAY tests to GET_FIELDS
      for display.                                                      }
  
  VAR
    FOUND : BOOLEAN;
  BEGIN
    FOR I := 1 TO SCREEN_FIELDS DO
      GET_FIELDS[I].S_FLD := '';
    I := 1;
    WHILE I < SCREEN_TESTS*3 DO
      WITH TEST_ARRAY[TEST_NO +(I DIV 3)] DO
        BEGIN
          IF FIELD_LOC = 0
            THEN 
              BEGIN
                GET_FIELDS[I].S_FLD := '';
                GET_FIELDS[I+1].S_FLD := '';
                GET_FIELDS[I+3].S_FLD := '';
              END
            ELSE
              BEGIN
                GET_FIELDS[I].S_FLD := MAINT_FIELDS[FIELD_LOC].S_ID;
                WITH GET_FIELDS[I+1] DO
                  CASE OPERATOR OF
                    LT: S_FLD := '<';
                    GT: S_FLD := '>';
                    EQ: S_FLD := '=';
                    LE: S_FLD := '<=';
                    GE: S_FLD := '>=';
                    NE: S_FLD := '<>';
                  END;
                GET_FIELDS[I+2].S_FLD := VALUE;
              END;
          I := I + 3;
        END;
    DISPLAY_SCREEN(GET_FIELDS,0,0,0,23);
  END;

SEGMENT PROCEDURE UPDATE_TEST_ARRAY(TEST_NO : INTEGER);

  { Checks the tests in GET_FIELDS for validity and transfers them
    to the appropriate section of TEST_ARRAY.                      }

  VAR
    OP : OPS;
    FLD_LEN,I,K,LOCATION : INTEGER;
    BLANK_FIELD,BLANK_OP,BLANK_VALUE : BOOLEAN;

  PROCEDURE CHK_FIELD(VAR FIELD      : STRING;
                    VAR LOC          : INTEGER;
                    VAR IS_BLANK     : BOOLEAN;
                    VAR FLD_LENGTH   : INTEGER);
  { Determines if the field name of the test is valid. Passes back the
      length of the fields value field so that CHK_VALUE may determine
      if the length of value of the test is within the maximum allowable. }

  VAR
    FOUND : BOOLEAN;

  BEGIN
    EATSPL(FIELD);  EATSPR(FIELD);
    IF LENGTH(FIELD) = 0
      THEN IS_BLANK := TRUE
      ELSE IS_BLANK := FALSE;
    FLD_LENGTH := 0;
    IF NOT IS_BLANK
      THEN
        BEGIN
          FOUND := FALSE;
          LOC := FIND(FIELD,MAINT_FIELDS);
          IF LOC <> 0
            THEN
              BEGIN
                FOUND := TRUE;
                FLD_LENGTH := MAINT_FIELDS[LOC].S_LEN;
              END;
          IF NOT FOUND
            THEN
              BEGIN
                MESSAGE(MAX_ROW,40,CONCAT('ERROR: ',FIELD,
                                            ' is an invalid field name'),
                                                                   TRUE);
                ERROR := TRUE;
                EXIT(UPDATE_TEST_ARRAY);
              END;
        END;
  END;

PROCEDURE CHK_OP(VAR OP_STRING : STRING;
                 VAR OPRATR    : OPS;
                 VAR IS_BLANK  : BOOLEAN);

  { Determine if the operator of the test is valid. Valid operators
      are: "<", ">", "<=", ">=", "<>", and "=".                      }

  VAR
    GOOD : BOOLEAN;
  BEGIN
    EATSPL(OP_STRING);  EATSPR(OP_STRING);
    GOOD := TRUE;
    IS_BLANK := FALSE;
    IF LENGTH(OP_STRING) = 0
      THEN IS_BLANK := TRUE
      ELSE
        IF OP_STRING = '<'
          THEN OPRATR := LT
        ELSE IF OP_STRING = '>'
          THEN OPRATR := GT
        ELSE IF OP_STRING = '='
          THEN OPRATR := EQ
        ELSE IF OP_STRING = '<='
          THEN OPRATR := LE
        ELSE IF OP_STRING = '>='
          THEN OPRATR := GE
        ELSE IF OP_STRING = '<>'
          THEN OPRATR := NE
        ELSE GOOD := FALSE;
    IF NOT GOOD
      THEN
        BEGIN
          MESSAGE(MAX_ROW,40,CONCAT('ERROR: ',OP_STRING,' is an invalid ',
                                                           'operator'),TRUE);
          ERROR := TRUE;
          EXIT(UPDATE_TEST_ARRAY);
        END;
  END;

PROCEDURE CHK_VALUE(VAR VALUE: STRING; IS_BLANK: BOOLEAN; FLD_LENGTH: INTEGER);

  { Determines if the length of the value of the test is within the maximum. }

  VAR
    COL : INTEGER;
  BEGIN
    IF FLD_LENGTH > 0
      THEN
        BEGIN
          EATSPL(VALUE);  EATSPR(VALUE);
          IF LENGTH(VALUE) > FLD_LENGTH
            THEN
              BEGIN
                STR(FLD_LENGTH,MSG);
                MSG := CONCAT('ERROR: Value "',VALUE,'" exceeds max length',
                                          ' of ',MSG);
                COL := 80-LENGTH(MSG);
                IF COL > 40 THEN COL := 40;
                MESSAGE(MAX_ROW,COL,MSG,TRUE);
                ERROR := TRUE;
                EXIT(UPDATE_TEST_ARRAY);
              END
            ELSE
              IF LENGTH(VALUE) = 0
                THEN IS_BLANK := TRUE
                ELSE IS_BLANK := FALSE;
        END;
  END;

BEGIN {UPDATE_TEST_ARRAY}
    ERASE_EOL(0,MAX_ROW);
    ERROR := FALSE;
    I := 1;
    WHILE I < 3*SCREEN_TESTS DO
      BEGIN
        CHK_FIELD(GET_FIELDS[I].S_FLD,LOCATION,BLANK_FIELD,FLD_LEN);
        CHK_OP(GET_FIELDS[I+1].S_FLD,OP,BLANK_OP);
        CHK_VALUE(GET_FIELDS[I+2].S_FLD,BLANK_VALUE,FLD_LEN);
        IF ((BLANK_OP) AND (NOT BLANK_FIELD))
          THEN
            BEGIN
              MESSAGE(MAX_ROW,40,'ERROR: Missing operator',true);
              ERROR := TRUE;
              EXIT(UPDATE_TEST_ARRAY);
            END;
        IF ((BLANK_FIELD) OR (BLANK_OP))
          THEN TEST_ARRAY[TEST_NO + (I DIV 3)].FIELD_LOC := 0
          ELSE
            WITH TEST_ARRAY[TEST_NO+(I DIV 3)] DO
              BEGIN
                FIELD_LOC := LOCATION;
                OPERATOR := OP;
                VALUE := GET_FIELDS[I+2].S_FLD;
              END;
        I := I + 3;
      END;
  END;   {UPDATE_TEST_ARRAY}

Segment PROCEDURE GET_SAVE(COMMAND : CHAR);
    VAR
      GOOD      : BOOLEAN;
      FILE_NAME : STRING[23];
      TEST_FILE : FILE OF TEST_REC;
  
    BEGIN
      FOR II := 1 TO SCREEN_FIELDS DO
        WITH GET_FIELDS[II] DO
          BEGIN
            S_ROW := END_SCREEN; S_COL := 14; S_MIN := 0; S_TYP := 'V';
            S_JUS := 'L'; S_NA := 'S'; S_DEF := ''; S_FLD := '';
          END;
      WITH GET_FIELDS[1] DO
        BEGIN
          S_ID := 'VOL'; S_ROW := 6; S_LEN := 7;
        END;
      WITH GET_FIELDS[2] DO
        BEGIN
          S_ID := 'NAME'; S_ROW := 8; S_LEN := 10;
        END;
      ERASE_EOS(0,0);
      GOTOXY(25,0);
      IF COMMAND = 'G'
        THEN WRITE('GET COMPARISON TESTS')
        ELSE WRITE('SAVE COMPARISON TESTS');
      GOTOXY(25,1);
      IF COMMAND = 'G'
        THEN WRITE('====================')
        ELSE WRITE('=====================');
      GOTOXY(0,6);
      WRITELN('Volume    :');
      WRITELN;
      WRITELN('Name      :');
      WRITELN;
      WRITELN('Type      :   Cmpr');
      MESSAGE(MAX_ROW,0,'<ENTER> to execute, <ESC> to abort',false);
      DISPLAY_SCREEN(GET_FIELDS,0,0,0,23);
      REPEAT
        GOOD := TRUE;
        SCREEN(GET_FIELDS,TRUE,0,0,0,0,23,MAX_ROW,40,EXIT_KEY);
        IF EXIT_KEY = ESC_KEY THEN EXIT(GET_SAVE);
        VOLUME := GET_FIELDS[1].S_FLD;
        NAME := GET_FIELDS[2].S_FLD;
        EATSPL(VOLUME);  EATSPR(VOLUME);
        EATSPL(NAME);  EATSPR(NAME);
        FILE_NAME := CONCAT(VOLUME,':',NAME,'.CMPR');
     {$I-}
        IF COMMAND = 'G'
          THEN
            BEGIN
              RESET(TEST_FILE,FILE_NAME);
              IF IO_RESULT = 0
                THEN
                  BEGIN
                    FOR I := 1 TO MAX_TESTS DO
                      BEGIN
                       TEST_ARRAY[I].FIELD_LOC := TEST_FILE^.FIELD_LOC;
                       TEST_ARRAY[I].OPERATOR  := TEST_FILE^.OPERATOR;
                       TEST_ARRAY[I].VALUE     := TEST_FILE^.VALUE;
                       IF I <> MAX_TESTS THEN GET(TEST_FILE);
                       IF IO_RESULT <> 0 THEN GOOD := FALSE;
                      END;
                    CLOSE(TEST_FILE,LOCK);
                  END
                ELSE GOOD := FALSE;
            END
          ELSE
            BEGIN
              REWRITE(TEST_FILE,FILE_NAME);
              IF IO_RESULT = 0
                THEN
                  BEGIN
                    FOR I := 1 TO MAX_TESTS DO
                      BEGIN
                        TEST_FILE^.FIELD_LOC := TEST_ARRAY[I].FIELD_LOC;
                        TEST_FILE^.OPERATOR  := TEST_ARRAY[I].OPERATOR;
                        TEST_FILE^.VALUE     := TEST_ARRAY[I].VALUE;
                        PUT(TEST_FILE);
                        IF IO_RESULT <> 0 THEN GOOD := FALSE;
                      END;
                    CLOSE(TEST_FILE,LOCK);
                  END
                ELSE GOOD := FALSE;
            END;
        IF NOT GOOD
          THEN MESSAGE(MAX_ROW,40,'ERROR: Invalid file specification',true);
      UNTIL GOOD;
     {$I+}
    END; {GET_SAVE}

 BEGIN {GET_TEST_ARRAY}
  USER_TESTS;
  ERROR := FALSE;
  FIRST_TEST := 1;
  DISPLAY_TESTS(FIRST_TEST);
  REPEAT
    IF ERROR
      THEN CH := 'C'
      ELSE 
        BEGIN
          GOTOXY(43,MAX_ROW-1);
          READ(KEYBOARD,CH);
          ERASE_EOL(0,MAX_ROW);
        END;
    CASE CH OF
      'C','c': BEGIN
                 SCREEN(GET_FIELDS,TRUE,0,0,0,0,23,MAX_ROW,40,EXIT_KEY);
                 IF EXIT_KEY = ESC_KEY THEN EXIT(GET_TEST_ARRAY);
                 UPDATE_TEST_ARRAY(FIRST_TEST);
               END;
      'B','b': BEGIN
                 IF ERROR
                   THEN WRITE(ALARM_BELL)
                   ELSE
                     BEGIN
                       IF FIRST_TEST <> 1
                         THEN FIRST_TEST := FIRST_TEST - SCREEN_TESTS
                         ELSE FIRST_TEST := MAX_TESTS-SCREEN_TESTS+1;
                       STR(FIRST_TEST,S);
                       STR(FIRST_TEST+12,MSG);
                       MSG := CONCAT('Currently viewing tests ',S,' - ',
                                                                 MSG,' ');
                       MESSAGE(20,0,MSG,FALSE);
                       DISPLAY_TESTS(FIRST_TEST);
                     END;
               END;
      'G','g': BEGIN
                 GET_SAVE('G');
                 USER_TESTS;
                 FIRST_TEST := 1;
                 DISPLAY_TESTS(FIRST_TEST);
               END;
      'S','s': BEGIN
                 IF ERROR
                   THEN WRITE(ALARM_BELL)
                   ELSE
                     BEGIN
                       GET_SAVE('S');
                       USER_TESTS;
                       FIRST_TEST := 1;
                       DISPLAY_TESTS(FIRST_TEST);
                     END;
               END;
      'N','n': BEGIN
                 IF ERROR
                   THEN WRITE(ALARM_BELL)
                   ELSE
                     BEGIN
                       IF FIRST_TEST < MAX_TESTS-SCREEN_TESTS+1
                         THEN FIRST_TEST := FIRST_TEST + SCREEN_TESTS
                         ELSE FIRST_TEST := 1;
                       STR(FIRST_TEST,S);
                       STR(FIRST_TEST+12,MSG);
                       MSG := CONCAT('Currently viewing tests ',S,' - ',
                                                                  MSG,' ');
                       MESSAGE(20,0,MSG,FALSE);
                       DISPLAY_TESTS(FIRST_TEST);
                     END;
               END;
      END;
  UNTIL ((CH = 'Q') OR (CH = 'q'));
  II := 1;
  NUM_TESTS := 0;
  WHILE ((II <= MAX_TESTS) AND (NUM_TESTS < 2)) DO
    BEGIN
      IF TEST_ARRAY[II].FIELD_LOC > 0
        THEN NUM_TESTS := NUM_TESTS + 1;
      II := II + 1;
    END;
  IF NUM_TESTS <> 0 
    THEN TESTS := TRUE;
  ALL_TESTS := TRUE;
  IF NUM_TESTS > 1
    THEN
      BEGIN
        ERASE_EOS(0,0);
        WRITE('List or export each record if :');
        GOTOXY(0,2);
        WRITE('1) All of the above tests have been met');
        GOTOXY(0,4);
        WRITE('2) Any of the above tests has been met');
        GOTOXY(0,6);
        WRITE('Enter 1 or 2 :');
        REPEAT
          ERASE_EOL(15,6);
          READ(KEYBOARD,CH);
        UNTIL ((CH = '1') OR (CH = '2'));
        WRITE(CH);
        IF CH = '2'
          THEN ALL_TESTS := FALSE;
      END;
END; {GET_TEST_ARRAY}

Segment Procedure PRINT_IT(var ERROR_FIELD: Integer);
 { Procedure formats the data records according the the format
       specifaction and then prints the records. }

  const NUMBER_COLUMNS = 8;
        MAX_LINES = 61;

  type PRINT_FIELDS = record
                        FIELD_WIDTH,
                        COLUMN_WIDTH,
                        START_POS:Integer;
                        PRINT_TITLE:String[40];
                      end;
  
  var PAGE_NUMBER,P_LENGTH,COLUMN_NUMBER,INDEX,LENGTH_INDEX,LIST_INDEX,
      ARRAY_INDEX,HEADING_INDEX,TITLE_WIDTH,LINE_NUMBER,FOOTING_INDEX,
      FOOTING_LINES,LAST_LINE,MAINT_INDEX,PRINT_INDEX: Integer;
      FOOTING,HEADING,ASCII_TITLE,ASCII_ID: String[40];
      STRING_HEAD,STRING_INDEX,STRING_RECNO:String[5];
      STRING_FOOT,STRING_ID,STRING_TITLE: String[8];
      PRINT_ARRAY: Array[1..NUMBER_COLUMNS] of PRINT_FIELDS;
      LP: Text;
      STRING_WIDTH: string; WIDTH: integer;
      
    Procedure PSTRING(FLEN: Integer; STRNG: String);
     var I: integer;
     begin {PSTRING}
      for I:=1 to length(STRNG) do
        if STRNG[I] = ULINE then STRNG[I] := ' ';
      write(LP,' ':(FLEN-length(STRNG)) div 2,STRNG,
               ' ':(FLEN-length(STRNG)+1) div 2);
     end; {PSTRNG}
     
    Procedure PRINT_LENGTH;
      begin {PRINT LENGTH}
        P_LENGTH := 0;
        for LENGTH_INDEX := 1 to ARRAY_INDEX-1 do
          P_LENGTH := P_LENGTH + PRINT_ARRAY[LENGTH_INDEX].COLUMN_WIDTH;
      end; {PRINT LENGTH}
    
    Procedure COUNT_FOOTINGS;
      begin {COUNT FOOTINGS}
        FOOTING_LINES := 0;
        for FOOTING_INDEX := 1 to 3 do
          begin
            str(FOOTING_INDEX,STRING_FOOT);
            STRING_FOOT := concat('FOOT',STRING_FOOT);
            FOOTING := GET_FIELDS[FIND(STRING_FOOT,GET_FIELDS)].S_FLD;
            EATSPL(FOOTING);  EATSPR(FOOTING);
            if length(FOOTING)>0 then FOOTING_LINES:=FOOTING_LINES + 1;
          end;
      end; {COUNT FOOTINGS}
      
    
    Procedure PRINT_FOOTINGS;
      begin {PRINT FOOTINGS}
        writeln(LP);
        for FOOTING_INDEX := 1 to 3 do
          begin
            str(FOOTING_INDEX,STRING_FOOT);
            STRING_FOOT := concat('FOOT',STRING_FOOT);
            FOOTING := GET_FIELDS[FIND(STRING_FOOT,GET_FIELDS)].S_FLD;
            EATSPL(FOOTING);  EATSPR(FOOTING);
            if FOOTING = '#'
              then
                begin
                  str(PAGE_NUMBER,STRING_FOOT);
                  PSTRING_(P_LENGTH,concat('PAGE ',STRING_FOOT));
                  writeln(LP);
                  LINE_NUMBER := LINE_NUMBER + 1
                end
              else
                if length(FOOTING) > 0
                  then 
                    begin
                      PSTRING(P_LENGTH,FOOTING);
                      writeln(LP);
                      LINE_NUMBER:=LINE_NUMBER + 1;
                    end;
          end;
      end; {PRINT FOOTINGS}
    
    Procedure PRINT_HEADINGS;
      var UNDER_LINE:String[40];
          TEMP_WIDTH:Integer;
      begin {PRINT_HEADINGS}
        UNDER_LINE := '========================================';
        for HEADING_INDEX:=1 to 3 do
          begin
            str(HEADING_INDEX,STRING_HEAD);
            STRING_HEAD := concat('HEAD',STRING_HEAD);
            HEADING := GET_FIELDS[FIND(STRING_HEAD,GET_FIELDS)].S_FLD;
            EATSPL(HEADING);  EATSPR(HEADING);
            if length(HEADING) > 0
              then 
                begin
                  PSTRING(P_LENGTH,HEADING);
                  writeln(LP);
                  LINE_NUMBER := LINE_NUMBER + 1;
                end;
          end;
        if LINE_NUMBER>1 then writeln(LP);
        for HEADING_INDEX:=1 to ARRAY_INDEX - 1 do
          begin
            with PRINT_ARRAY[HEADING_INDEX] do
              PSTRING(COLUMN_WIDTH,PRINT_TITLE);
          end;
        writeln(LP);
        for HEADING_INDEX := 1 to ARRAY_INDEX -1 do
          begin
            with PRINT_ARRAY[HEADING_INDEX] do
              begin
                if FIELD_WIDTH>0
                  then TEMP_WIDTH := FIELD_WIDTH
                  else TEMP_WIDTH := -FIELD_WIDTH;
                PSTRING(COLUMN_WIDTH,COPY(UNDER_LINE,1,TEMP_WIDTH));
              end;
          end;
        writeln(LP);
        writeln(LP);
        LINE_NUMBER := LINE_NUMBER + 3;
      end; {PRINT HEADINGS}


    begin {PRINT IT}
     MESSAGE(MAX_ROW,40,'List in progress',false);
     {$I-}
     if WRITE_FILE_NAME ='' then begin
       rewrite(LP,'PRINTER:');
       if IORESULT<>0 then 
         begin
          MESSAGE(MAX_ROW,40,'ERROR: Printer not on line.',True);
          exit(PRINT_IT);
         end;
     end
     else begin
       rewrite(lp,write_file_name);
       if ioresult<>0 then begin
         message(max_row,40,'ERROR: Output file not available.',true);
         exit(print_it);
       end;
     end; {Dec 29}
         
     ERROR_FIELD := 0;
     ARRAY_INDEX := 1;
     string_width:=GET_FIELDS[find('WIDTH',GET_FIELDS)].s_fld; {Dec 29}
     if not val(string_width,width) then begin {Dec 29}
       message(max_row,40,'ERROR: Invalid print width',true);
       error_field:=find('WIDTH',GET_FIELDS);
     end;  {if not val}
     for PRINT_INDEX := 1 to NUMBER_COLUMNS do
      begin
       str(PRINT_INDEX,STRING_INDEX);
       STRING_ID := concat('ID',STRING_INDEX);
       STRING_TITLE := concat('TIT',STRING_INDEX);
       ASCII_TITLE := GET_FIELDS[FIND(STRING_TITLE,GET_FIELDS)].S_FLD;
       EATSPL(ASCII_TITLE);  EATSPR(ASCII_TITLE);
       TITLE_WIDTH := length(ASCII_TITLE);
       LIST_INDEX := FIND(STRING_ID,GET_FIELDS);
       ASCII_ID := GET_FIELDS[LIST_INDEX].S_FLD;
       EATSPL(ASCII_ID);  EATSPR(ASCII_ID);
       if ASCII_ID = '#'
         then 
           with PRINT_ARRAY[ARRAY_INDEX] do
            begin
             FIELD_WIDTH := 5;
             if TITLE_WIDTH <= FIELD_WIDTH
               then COLUMN_WIDTH := FIELD_WIDTH + 2
               else COLUMN_WIDTH := TITLE_WIDTH + 2;
             FIELD_WIDTH := -FIELD_WIDTH;
             PRINT_TITLE := ASCII_TITLE;
             ARRAY_INDEX := ARRAY_INDEX + 1;
            end
         else
          begin
           MAINT_INDEX := FIND(ASCII_ID,MAINT_FIELDS);
           if (MAINT_INDEX = 0)
                    and
              (length(ASCII_ID) > 0)
              then
                begin
                  MESSAGE(MAX_ROW,40,'ERROR: Invalid field ID',True);
                  ERROR_FIELD := LIST_INDEX;
                  exit(PRINT_IT);
                end
              else
                if MAINT_INDEX > 0
                  then
                    begin
                     with PRINT_ARRAY[ARRAY_INDEX] do
                      begin
                       PRINT_TITLE := ASCII_TITLE;
                       FIELD_WIDTH := MAINT_FIELDS[MAINT_INDEX].S_LEN;
                       if TITLE_WIDTH <= FIELD_WIDTH
                         then COLUMN_WIDTH := FIELD_WIDTH + 2
                         else COLUMN_WIDTH := TITLE_WIDTH + 2;
                       START_POS:=0;
                       for INDEX:=1 to MAINT_INDEX-1 do
                          START_POS:=START_POS+MAINT_FIELDS[INDEX].S_LEN;
                       START_POS:=START_POS+1;
                      end;
                     ARRAY_INDEX := ARRAY_INDEX + 1;
                    end;
          end;
      end;
     if ARRAY_INDEX = 1
      then
        begin
         MESSAGE(MAX_ROW,40,'ERROR: No Field IDs found',True);
         exit(PRINT_IT);
       end;
     PRINT_LENGTH;
     if P_LENGTH > width  {Dec 29}
       then 
         begin
          MESSAGE(MAX_ROW,40,concat('ERROR: Print record > ',
            string_width,' characters'),True); {Dec 29}
          exit(PRINT_IT);
        end;
     COUNT_FOOTINGS;
     LAST_LINE := MAX_LINES-FOOTING_LINES;
     writeln(LP,FORM_FEED);
     LINE_NUMBER := 1;
     PAGE_NUMBER := 1;
     DB_RECNO := 1;
     READ_WRITE('R',DB_RECNO,REC_LEN,RESULTS);
     IF TESTS
       THEN LOAD_SCREEN('A',MAINT_FIELDS,NUM_FLDS,IO_REC.B);
     while RESULTS = 0 do
      begin
       if LINE_NUMBER = LAST_LINE
         then
           begin
            if FOOTING_LINES>0 then PRINT_FOOTINGS;
            writeln(LP,FORM_FEED);
            LINE_NUMBER := 1;
            PAGE_NUMBER := PAGE_NUMBER + 1;
           end;
       if LINE_NUMBER = 1 then PRINT_HEADINGS;
       str(DB_RECNO,STRING_RECNO);
       while length(STRING_RECNO)<4 do  
         STRING_RECNO:=concat(' ',STRING_RECNO);
     { gotoxy(13,23);
       write(STRING_RECNO); } {Dec 29}
       if IO_REC.A[3] = 42
         THEN 
           IF LIST_RECORD 
             THEN
               begin
                for COLUMN_NUMBER := 1 to ARRAY_INDEX-1 do
                 begin
                  with PRINT_ARRAY[COLUMN_NUMBER] do
                   begin
                    if FIELD_WIDTH < 1
                      then
                        begin
                         PSTRING_(COLUMN_WIDTH,STRING_RECNO);
                        end
                      else
                       PSTRING(COLUMN_WIDTH,
                                       copy(IO_REC.B,START_POS+3,FIELD_WIDTH));
                   end;
                 end;
                writeln(LP);
                LINE_NUMBER := LINE_NUMBER + 1;
               end;
       DB_RECNO := DB_RECNO +1;
       READ_WRITE('R',DB_RECNO,REC_LEN,RESULTS);
       IF TESTS
         THEN LOAD_SCREEN('A',MAINT_FIELDS,NUM_FLDS,IO_REC.B);
     end; {while RESULTS}
     if LINE_NUMBER < LAST_LINE
       then
         begin
          for PRINT_INDEX := LINE_NUMBER to LAST_LINE-1 do writeln(LP);
          if FOOTING_LINES > 0 then PRINT_FOOTINGS;
         end;
     close(lp,lock); {Dec 29}
     ERASE_EOL(40,MAX_ROW);
    end; {PRINT IT}
  
  begin  {ACCESS_DATA_BASE}
    FOR I := 1 TO MAX_TESTS DO
      WITH TEST_ARRAY[I] DO
        BEGIN
          FIELD_LOC := 0;  VALUE := '';
        END;
    TESTS := FALSE;
    RECORD_LENGTH(MAINT_FIELDS); {Jan 9}
    ERASE_EOS(0,0);
    GET_FILE('*UD/LIST.SCRN',GET_FIELDS,GET_PROMPTS,RESULTS);
    if RESULTS <> 0
      then
        begin
          MESSAGE(MAX_ROW,40,'ERROR: Unable to load "UD/LIST.SCRN"',True);
          exit(LIST);
        end;
    DISPLAY_FLAG := True;
    repeat
      if DISPLAY_FLAG
        then
          begin
            ERASE_EOS(0,0);
            DISPLAY_PROMPTS(GET_PROMPTS,0,0,0,23);
            DISPLAY_SCREEN(GET_FIELDS,0,0,0,23);
            gotoxy(0,MAX_ROW-1);  writeln(PROMPT1);  write(PROMPT2);
            DISPLAY_FLAG := False;
          end;
      gotoxy(32,23);  read(Keyboard,CH);
      if CH = ESC_KEY
        then
          begin
            close(DATA_FILE,lock);
            exit(LIST);
          end
        else if CH in['a'..'z'] then CH:=chr(ord(CH)+ord('A')-ord('a'));
      ERASE_EOL(32,23);
      write(CH);
      case CH of
        'G','S','O':  begin
                GET_SAVE_FORMAT(CH,ESC);
                DISPLAY_FLAG := True;
              end;
        'L':  begin
                PRINT_IT(START_LIST);
                if START_LIST <> 0
                  then SCREEN(GET_FIELDS,true,START_LIST,0,0,0,MAX_ROW,
                    MAX_ROW,40,EXXIT);
              end;
        'C':  SCREEN(GET_FIELDS,true,0,0,0,0,MAX_ROW,MAX_ROW,40,EXXIT);
        'E':  begin
                GET_SAVE_FORMAT(CH,ESC); {Export file}
                if not ESC then
                  EXPORT(EXPRT_FILE_NAME,MAINT_FIELDS,WRITE_FILE_NAME);
                DISPLAY_FLAG:=TRUE;
              end;
        'T':  BEGIN
                GET_TEST_ARRAY;
             {  GET_FILE('*UD/LIST.SCRN',GET_FIELDS,GET_PROMPTS,RESULTS);
                if RESULTS <> 0
                  then
                    begin
                      MESSAGE(MAX_ROW,40,
                              'ERROR: Unable to load "UD/LIST.SCRN"',True);
                      exit(LIST);
                    end;               }
                DISPLAY_FLAG:=TRUE;
              END;
        'Q':  exit(ACCESS_DATA_BASE);
      end;
    until False;
  end;   {ACCESS_DATA_BASE}

  Procedure RECORD_LENGTH{var S_ARRAY: SCREEN_ARR};
  { Function to find the length of the record defined by the data base
       definition. }
    var
      DONE: boolean;
    begin  
      REC_LEN := 0;
      INDEX := 1;
      DONE:=false;     {Mar 20 to handle 40 fields }
      while (not DONE) and (INDEX<=SCREEN_FIELDS) do
        if S_ARRAY[INDEX].S_ROW <> END_SCREEN then
        begin
          REC_LEN := REC_LEN + S_ARRAY[INDEX].S_LEN;
          INDEX := INDEX + 1;
        end
        else DONE:=true;
      REC_LEN := REC_LEN + 5;
      NUM_FLDS := INDEX-1;
    end;
  
  Procedure MESSAGE; (* M_ROW,M_COL: Integer; MSG: String; DING: Boolean *)
  { Procedure displays messages at the message row and column. }
    begin
      gotoxy(M_COL,M_ROW);  write(MSG);
      if DING then write(ALARM_BELL);
    end;
  
  Function VAL; {(S: string; var NUM: integer): boolean;}{ Jan 7}
  { Procedure converts a string to an integer and returns an error indicator }
    var
      neg: boolean;
      i: integer;
      correct: boolean;
    begin
      num:=0;
      eatspl(s); eatspr(s);
      if length(s)=0 then begin
        val:=false;
        exit(val);
      end;
      neg:=s[1]='-';
      if s[1] in ['+','-'] then delete(s,1,1);
      correct:=true;
      for i:=1 to length(s) do 
        if s[i] in ['0'..'9'] then num:=10*num+ord(s[i])-ord('0')
        else correct:=false;
      if correct and neg then num:=-num;
      if not correct then num:=0;
      val:=correct;
    end;  { val }
    
begin  {LIST}
 INITIALIZE;
 GET_DATA_BASE;
 ACCESS_DATA_BASE;
 close(DATA_FILE,lock);
end.   {LIST}


========================================================================================
DOCUMENT :usus Folder:VOL25:ud.maint.text
========================================================================================

{$L #5:MNTLST.TEXT}

PROGRAM MAINTAIN;

{  Once a data base has been defined, this set of procedures maintains the
     data base by adding, examining, changing and deleting the various 
     data base records. }
 
  Uses {$U sh.screen.unit} SCREEN40;
  
  const MAX_INT  = 32767;  (* maximum integer & number of records *)
        BLANKS            = '              ' ;
        ERROR_COL         =     0 ;
        ERROR_LINE        =    23 ;
        MAXFRAC           =     4 ;
        MAXWHOLE          =     9 ;
        MAX_CALC_TEXT     =    40 ;
        MAX_VALUE_DIGITS  =    14 ;
        STARS             = '**************' ;
        ZEROS             = '00000000000000' ;
        ROUNDING_FACTOR   =     0 ;
        
  type STRING5   = String[5];
       STRING23  = String[23];
       STRING40  = String[40];
       STRING255 = String[255];
       INTEGER14 = Integer[14];
       ASTRING           = STRING ;
       SIXWORDINT        = INTEGER[ 20 ] ;
       THREEWORDINT      = INTEGER[  8 ] ;
       T_SCREEN_COLUMN   = 0 .. 79 ;
       T_SCREEN_LINE     = 0 .. 23 ;
       T_CALC                      = RECORD
         CALC_TEXT                 : STRING[ MAX_CALC_TEXT ] ;
         END ; { T_CALC }
       
       T_VALUE                     = RECORD
         VALUE                     : STRING[ MAX_VALUE_DIGITS ] ;
         DECIMAL_POSITION          : INTEGER ;
         END ; { T_VALUE }
  
  var
    GET_FIELDS,MAINT_FIELDS    : SCREEN_ARR;  { Array to hold data fields }
    GET_PROMPTS,MAINT_PROMPTS  : PROMPT_ARR;  { Array to hold screen prompts }
    DATA_RESULTS,    { 0 If data file exist }
    DEFI_RESULTS,    { 0 If data base definition exist }
    GET_RESULTS,     { 0 If 'GET.SCRN' loaded }
    RESULTS,
    FIELD_ROW,FIELD_COL,FIELD_LEN,FIELD_MIN,
    COPY_INDEX,COPY_LENGTH,INDEX,MAX_RECORDS,ERRCOL,ERROW,
    DB_RECNO,REC_LEN,CURRENT_BLOCK   : Integer;
    EXXIT,EXIT_KEY,CH,FIELD_JUS,FIELD_NA : Char;
    FIELD_FLD : STRINGFL;
    EXAMINE_FLAG,FIELD_SKIP,CALCULATIONS : Boolean;
    PROMPTLINE,OPTLINE: String;
    VOLUME    : String[7];  { Data base volume }
    NAME      : String[10]; { Data base Name }
    DB_NAME   : String[18]; { Volumn + Data Base Name }
    DATA_NAME : STRING23; { Data file name }
    DEFI_NAME : STRING23; { Data Base Definition file name }
    STR_RECNO : String[5];
    IO_REC    : Packed record      { String to hold data base record }
                case Integer of
                  1: (A: Packed Array[0..255] of 0..255);
                  2: (B: STRING255);
                end;
    NUM_FIELDS : integer;  { number of screen fields }
    DATA_FILE : File;
    Digitset : Set of Char;
    Operators : Set of Char;
    Longintzero : threewordint;
    Max         : Threewordint;
    Multipler   : Threewordint;
                  
Procedure MESSAGE(M_ROW,M_COL :Integer; MSG :String; DING: Boolean);
  Forward;

Procedure RECORD_LENGTH(var S_ARRAY :SCREEN_ARR);
  Forward;

Segment Procedure INIT_FLOAT ;
CONST
  ONE_HUNDRED            = 100 ;
  TEN                    =  10 ;
VAR
  I                      : INTEGER ;
  INT                    : INTEGER ;
  ONE                    : INTEGER ;
BEGIN

  DIGITSET  := [ '0' .. '9' ] ;
  OPERATORS := ['+','-','*','/','^','(',')','#','=',' '];
  
  { NOTE: The following strange code is placed here to get around a compiler
          requirement that reals be present in order for the compiler to 
          compile a LongInteger constant.
  }
  ONE :=   1 ;
  INT :=  10 ;
  MAX := INT ;
  FOR I := 1 TO 14-1 DO
    MAX := MAX * INT ;        { Compute 1E14 }
  MAX       := MAX - ONE ;    { Compute (1E14)-1, the largest VALUE allowed. }
  
  MULTIPLER := INT ;
  FOR I := 1 TO 5-1 DO
    MULTIPLER := MULTIPLER * INT ; { Compute 1E5, used to shift and align 
                                     digits around the implied decimal point. }
  
  { See above note about compiler needing reals to compile a longinteger const }
  LONGINTZERO := MAX - MAX ;

END ; { INIT_FLOAT }

Segment Procedure NUMTOSTR (       VAR ANS          : ASTRING ;
                               NUM          : THREEWORDINT ;
                               BEFORE, AFTER: INTEGER ) ;
{   Dale Ander  May 28, 1980
  NUMTOSTR takes the Longinteger in NUM and creates a string representation
  of it and puts this string into ANS.  The form of the string is dependant
  upon the values of BEFORE and AFTER.  BEFORE is the number of digits
  to put before the decimal point and AFTER is the number after.
}
VAR
  I, L                   : INTEGER ;
  MINUSZERO              : BOOLEAN ;

BEGIN
  IF NUM>=MAX THEN NUM:=0; { SEP 28 TO HANDLE OVERFLOW NUMBERS }
  IF NOT (BEFORE IN [1..MAXWHOLE])
    THEN
      BEFORE := MAXWHOLE ;
  BEFORE := BEFORE + 1 ;                    { Allow room for sign.    }
  IF NOT (AFTER IN [0..MAXFRAC])
    THEN
      AFTER := MAXFRAC ;
  
  
  STR( NUM, ANS ) ;                         { Convert NUM to a string }
  IF NUM >= 0                               { Put space instead of minus sign }
    THEN
      ANS := CONCAT( ' ', ANS ) ;
  L := LENGTH( ANS ) - MAXFRAC ;
  IF L < 3
    THEN
      BEGIN
      INSERT( COPY( ZEROS, 1, 3-L ), ANS, 2 ) ;
      L := LENGTH( ANS ) - MAXFRAC ;
      END ;
  
  { Remove part of fraction not needed }
  DELETE( ANS, L+AFTER, MAXFRAC - AFTER + 1 ) ;
  
  IF BEFORE - L + 1 > 0                     { Insert leading blanks   }
    THEN
      INSERT( COPY( BLANKS, 1, BEFORE - L + 1 ), ANS, 1 )
    ELSE
      { If field is not wide enough for number then return *'s        }
      IF BEFORE < L - 1
        THEN
          ANS := COPY( STARS, 1, BEFORE + AFTER ) ;
  
  IF NUM < 0                                { Look for -0 case        }
    THEN
      BEGIN
      I := 1 ;
      L := LENGTH( ANS ) ;
      REPEAT
        I := I + 1 ;
        MINUSZERO := ANS[I] IN DIGITSET ;
      UNTIL ( I = L ) OR NOT MINUSZERO ;
      END ; { IF NUM < 0 }
  
  IF AFTER > 0                              { Put in decimal point    }
    THEN
      INSERT( '.', ANS, LENGTH( ANS ) - AFTER + 1 ) ;

END ; { OF NUMTOSTR }



Segment Function FIGURE (    VAR Z                  : THREEWORDINT ;
                         X, Y               : THREEWORDINT ;
                         OP                 : CHAR )
                                            : BOOLEAN   ;
{ Dale Ander May 28, 1980
  This function calculates Z given X and Y and the operation in OP.  It
  is assumed that both X and Y have an 'implied' decimal point in them
  and that they have (Maxfrac+1) digits to the right of this 'implied'
  decimal point.  The answer, Z, is to also have this implied decimal point
  in the same position.  If an overflow occurs it returns false and sets Z
  to 9's.  Otherwise it return true.
}

VAR
  I, POWER               : INTEGER ;
  
  ANS                    : SIXWORDINT ;

BEGIN
  CASE OP OF
    '+' : ANS := X + Y ;
    '-' : ANS := X - Y ;
    '*' : ANS := (X * Y + ROUNDING_FACTOR) DIV MULTIPLER ;
    '/' : IF Y <> 0
            THEN
              ANS := (X * MULTIPLER) DIV Y
            ELSE
              IF X = 0
                THEN
                  ANS := 0
                ELSE
                  ANS := MAX + 1 ;
    '^' : BEGIN
          Y := Y DIV MULTIPLER ;
          IF (Y < 0) OR (Y > MAXINT)
            THEN
              ANS := MAX + 1
            ELSE
              IF Y = 0
                THEN
                  ANS := MULTIPLER
                ELSE
                  BEGIN
                  POWER := TRUNC( Y ) ;
                  I := 1 ;
                  ANS := X ;
                  WHILE (I < POWER) AND (ANS < MAX) DO
                    BEGIN
                    ANS := (ANS * X) DIV MULTIPLER ;
                    I   := I + 1 ;
                    END
                  END
          END ;
    END ; { CASE }
    
    IF ANS > MAX
      THEN
        BEGIN
        Z := MAX ;
        FIGURE := FALSE ;
        END
      ELSE
        BEGIN
        Z := ANS ;
        FIGURE := TRUE ;
        END ;
END ; { OF FIGURE }

Segment Procedure INT_TO_STR (INT : INTEGER ; VAR OUT : STRING)  ;
BEGIN
  STR( INT, OUT);
END;  { INT_TO_STR }

Segment Procedure VALUE (        RETURN_INTEGER     : BOOLEAN ;
                         INSTRING           : ASTRING ;
                     VAR REALANS            : THREEWORDINT ;
                     VAR INTANS             : INTEGER ) ;
VAR
  WSUM, FSUM             : THREEWORDINT ;
  NEGATIVE               : BOOLEAN ;
  PTR                    : INTEGER ;
  CH                     : CHAR ;

PROCEDURE GETCHAR ;
BEGIN
  CH  := INSTRING[ PTR ] ;
  PTR := PTR + 1 ;
END ; { GETCHAR }

PROCEDURE SUM(       VAR ANS                : THREEWORDINT ;
                         DIGITS             : INTEGER ) ;
VAR
  COUNT, ORDZERO         : INTEGER ;

BEGIN
  COUNT   := 0 ;
  ANS     := 0 ;
  ORDZERO := ORD('0') ;
  WHILE (CH IN DIGITSET) AND (COUNT < DIGITS) DO
    BEGIN
    COUNT := COUNT + 1 ;
    ANS   := 10 * ANS + ORD( CH ) - ORDZERO ;
    GETCHAR ;
    END ;
END ; { SUM }

BEGIN
  NEGATIVE := FALSE ;
  FSUM     := 0 ;
  WSUM     := 0 ;
  EATSPL( INSTRING ) ;
  EATSPR( INSTRING ) ;
  INSTRING := CONCAT( INSTRING, ' ' ) ;
  PTR      := 1 ;
  
  GETCHAR ;
  
  IF CH IN ['+', '-']
    THEN
      BEGIN
      NEGATIVE := CH = '-' ;
      GETCHAR
      END ;
  
  SUM( WSUM, MAXWHOLE ) ;                   { GET WHOLE PART OF NUMBER         }

  IF CH = '.'
    THEN
      BEGIN
      { Put trailing zeroes on }
      INSERT( COPY( ZEROS, 1, MAXFRAC+1 ), INSTRING, LENGTH( INSTRING ) ) ;
      GETCHAR ;                             { Skip period                      }
      SUM( FSUM, MAXFRAC + 1 ) ;
      END ;
  
      
  IF RETURNINTEGER 
    THEN
      BEGIN
      INTANS  := TRUNC( WSUM ) ;
      REALANS := - 77 ;
      IF NEGATIVE
        THEN
          INTANS := -INTANS ;
      END
    ELSE
      BEGIN
      REALANS := WSUM * MULTIPLER + FSUM ;
      INTANS  := -77 ;
      IF NEGATIVE
        THEN
          REALANS := -REALANS ;
      END ;


END ; { OF VALUE }

Segment Function INTVALUE (S: STRING; var NUM: integer): boolean ;
var
  I: integer;
  NUML: threewordint;
begin
  INTVALUE:=false;
  I:=1;
  NUML:=0;
  EATSPL(S); EATSPR(S);
  if length(S)=0 then exit(INTVALUE);
  for I:=1 to length(S) do
    if S[I] in DIGITSET then
      NUML:=10*NUML+ord(S[I])-ord('0')
    else exit(INTVALUE);
  if NUML>MAX_INT then exit(INTVALUE);
  NUM:=trunc(NUML);
  INTVALUE:=true;
end;  { INTVALUE }

  
  
Segment Procedure INITIALIZE;
  {Procedure initilizes everything to begin maintaining the data base.}
   var I: Integer;
   begin  {INITIALIZE}
    for I:=1 to SCREEN_FIELDS do
     with GET_FIELDS[I] do 
      begin {Init fields}
       S_ROW:=END_SCREEN;  S_COL:=15;  S_MIN:=0;  S_TYP:='V';
       S_JUS:='L';  S_NA:='S';  S_DEF:='';  S_FLD:=''; S_SKIP:=false;
      end; {Init fields}
    with GET_FIELDS[1] do
     begin
      S_ID:='VOL';  S_ROW:=8;  S_LEN:=7;
     end;
    with GET_FIELDS[2] do
     begin
      S_ID:='NAME';  S_ROW:=10;  S_LEN:=10;
     end;
    for I:=1 to PROMPT_FIELDS do
     with GET_PROMPTS[I] do
      begin
       P_ROW:=END_SCREEN;  P_COL:=0;  P_FLD:='';
      end; {with/for}
    with GET_PROMPTS[1] do
     begin
      P_ROW:=0;  P_COL:=25;  P_FLD:='MAINTAIN A DATA BASE';
     end;
    with GET_PROMPTS[2] do
     begin
      P_ROW:=1;  P_COL:=25;  P_FLD:='====================';
     end;
    with GET_PROMPTS[3] do
     begin
      P_ROW:=2;  P_COL:=25;  P_FLD:='Version IV.0';
     end;
    with GET_PROMPTS[4] do
     begin
      P_ROW:=8;  P_FLD:='Volume    :';
     end;
    with GET_PROMPTS[5] do
     begin
      P_ROW:=10;  P_FLD:='Name      :';
     end;
    with GET_PROMPTS[6] do
     begin
      P_ROW:=12;  P_FLD:='Type      :    SCRN and TEXT';
     end;
    ERASE_EOS(0,0);
    PROMPTLINE:='Rec # <_____>,Add,Mash';
    OPTLINE:='Store,Examine,Change,Delete,Quit ?';
    for I:=1 to 22 do  if not(PROMPTLINE[I] in['A'..'Z'])
                          then PROMPTLINE[I]:=chr(ord(PROMPTLINE[I])+128);
    for I:=1 to 33 do  if not(OPTLINE[I] in['A'..'Z'])
                          then OPTLINE[I]:=chr(ord(OPTLINE[I])+128);
    FIELD_LEN:=5;  FIELD_MIN:=0;
    ERRCOL:=40;    ERROW:=23;
    FIELD_JUS:='L'; FIELD_NA :='N';
    FIELD_FLD:='0'; FIELD_SKIP:=FALSE;
    DB_RECNO:=1;
    CURRENT_BLOCK:=-1;
    EXAMINE_FLAG:=True;
    Init_Float;
  end;   {INITIALIZE}
  
  Segment Procedure GET_DATA_BASE;
{Procedure gets the Data Base Definition form the disk or initilizes
   a new data base file.}
  

Procedure CREATE(var CREATE_NAME:STRING23;
                   var CREATE_LENGTH,NUMBER_RECORDS,CREATE_RESULTS:Integer);
  { Procedure creates and initilizes a file to hold data base records. }
   
   var NO_BLOCKS : Integer;
       buffer: packed array[0..1023] of 0..255;
       off_set: integer;
       check: integer;

   begin {CREATE}
    CREATE_RESULTS:=1;
    fillchar(IO_REC.A[0],sizeof(IO_REC),chr(00));
    NO_BLOCKS:=NUMBER_RECORDS div (1024 div REC_LEN)+1;
    (*$i-*)
    rewrite(data_file,CREATE_NAME);
    if IO_RESULT<>0 then exit(create);
    fillchar(IO_REC.A[4],CREATE_LENGTH-5,' ');
    IO_REC.A[0]:=CREATE_LENGTH;
    IO_REC.A[1]:=16;
    IO_REC.A[2]:=32;
    IO_REC.A[3]:=126;
    IO_REC.A[CREATE_LENGTH-1]:=42;
    IO_REC.A[CREATE_LENGTH]:=13;
    fillchar(BUFFER[0],sizeof(BUFFER),chr(00));
    check:=blockwrite(data_file,buffer,2); (* text file prefix *)
    if CHECK<>2 then begin
      close(data_file);
      exit(create);
    end;
    off_set:=0;
    while off_set+create_length <= 1023 do begin
      moveleft(io_rec.a[1],buffer[off_set],create_length);
      off_set:=off_set+create_length;
    end;
    index:=1;
    while index <= no_blocks do begin
      check:=blockwrite(data_file,buffer,2);
      if check<>2 then begin
        close(data_file);
        exit(create);
      end;
      index:=index+1;
    end;  (* while *)
    (*$i+*)
    close(data_file,LOCK);
    CREATE_RESULTS:=0;
   end; {CREATE}

  Procedure GET_DATA_FILE;
  { Procedure checks for data base data file.  If no data file exist
           then the operator can create one. }
   
   var
     RIGHT: BOOLEAN;
   begin {GET DATA FILE}
   {$I-}
    reset(DATA_FILE,DATA_NAME);
   {$I+}
    if IO_RESULTS <> 0
      then
       begin
        ERASE_EOL(0,MAX_ROW);
        write('Create new data base Y/N ? Y');
        gotoxy(27,MAX_ROW);
        read(Keyboard,CH);
        if CH in [' ','Y','y']
          then 
           begin {make the file}
            ERASE_EOL(0,MAX_ROW);
            write('Maximum number of records ?');
            REPEAT
              FIELD_ROW:=MAX_ROW; FIELD_COL:=29;
              FIELD_FLD:='0'; FIELD_SKIP:=FALSE;
              FIELD(FIELD_ROW,FIELD_COL,ERROW,ERRCOL,FIELD_LEN,FIELD_MIN,EXXIT,
                FIELD_JUS,FIELD_NA,FIELD_FLD,FIELD_SKIP);
              RIGHT:=INTVALUE(FIELD_FLD,MAX_RECORDS); { MAR 11 }
              IF NOT RIGHT THEN 
                MESSAGE(MAX_ROW,40,'ERROR: Incorrect number of records',TRUE);
            UNTIL RIGHT;
            MESSAGE(MAX_ROW,40,'STATUS: Creating Data File',False);
            CREATE(DATA_NAME,REC_LEN,MAX_RECORDS,RESULTS);
            if RESULTS<>0
              then
               begin
                MESSAGE(MAX_ROW,40,'ERROR: Unable to create text data file',
                  True);
                DATA_RESULTS:=1;
               end
             else DATA_RESULTS:=0;
            end
           else DATA_RESULTS:=1;
         end
       else
         begin
          close(DATA_FILE);
          DATA_RESULTS:=0;
         end;
  end; {GET DATA FILE}

begin  {GET_DATA_BASE}  
  DISPLAY_PROMPTS(GET_PROMPTS,0,0,0,23);
  DISPLAY_SCREEN(GET_FIELDS,0,0,0,23);
  repeat
    MESSAGE(4,0,
      'Copyright (C) 1981 by Texas Instruments Corporate Engineering Center',
      false);
    MESSAGE(5,0,
     'All rights reserved as per the Computer Software Copyright Act of 1980',
      false);
    MESSAGE(MAX_ROW,0,'<ENTER> to execute, <ESC> to abort',False);
    SCREEN(GET_FIELDS,true,0,0,0,0,23,MAX_ROW,40,EXIT_KEY);
    if EXIT_KEY=ESC_KEY then exit(MAINTAIN);
    VOLUME:=GET_FIELDS[FIND('VOL',GET_FIELDS)].S_FLD;
    EATSPR(VOLUME);
    NAME:=GET_FIELDS[FIND('NAME',GET_FIELDS)].S_FLD;
    EATSPL(NAME);
    DB_NAME:=concat(VOLUME,':',NAME);
    DEFI_NAME:=concat(DB_NAME,'.SCRN');
    DATA_NAME:=concat(DB_NAME,'.TEXT');
    DATA_RESULTS:=0;
    GET_FILE(DEFI_NAME,MAINT_FIELDS,MAINT_PROMPTS,RESULTS);
    if RESULTS=0
      then
        begin
          RECORD_LENGTH(MAINT_FIELDS);
          if REC_LEN>255 then begin
            message(MAX_ROW,40,'ERROR: Defined screen is too long',true);
            DATA_RESULTS:=1;
          end;
{         if CALCULATIONS then begin
            message(MAX_ROW,40,'ERROR: Calculated fields in screen',true);
            DATA_RESULTS:=1;
          end; }
          if DATA_RESULTS=0 THEN GET_DATA_FILE;
        end
      else begin
        MESSAGE(MAX_ROW,40,'ERROR: Unknown Data Base',True);
        DATA_RESULTS:=1;
      end;
    if DATA_RESULTS=0  then exit(GET_DATA_BASE);
  until False;
end;   {GET_DATA_BASE}

  {$P}
{                                                                              }
{    Perform the calculations.                                                 }
{                                                                              }


SEGMENT PROCEDURE DO_CALC ;

VAR
  RESULT                : INTEGER ;
  CALC                  : T_CALC ;
  TEMP_STRING           : STRING ;
  OUTANS                : STRING ;
  DONE                  : BOOLEAN ;
  OVERFLOW              : BOOLEAN ;
  UNDEFINED             : BOOLEAN ;
  INDX                  : INTEGER ;

PROCEDURE ERR(NUM: INTEGER);
VAR 
  ERR_TEXT              : STRING ;
  C                     : CHAR ;
BEGIN
  CASE NUM OF
    1: ERR_TEXT := 'ERROR: OVERFLOW occurred' ;
    2: ERR_TEXT := 'WARNING: Undefined Field in Calculation';
    3: ERR_TEXT := 'ERROR: Calculation Value too large';
  END;
  message(max_row-1,40,err_text,true);
  erase_eol(40,max_row);
  write('Press SPACE to continue');
  read(keyboard,c);
  if eof(keyboard) then reset(keyboard);
  erase_eol(40,max_row-1);
  erase_eol(40,max_row);
END;   (* of err *)

PROCEDURE DOIT ;
VAR
  ANSWER                : THREEWORDINT ;
  CURRENT_CALC_LINE     : INTEGER ;
  C_STRING              : STRING ;
  RESULT                : INTEGER ;

PROCEDURE DOMATH;
TYPE
     TOKENKINDS = (CONSTV, EOFV, LPARENV, MINUSV, PLUSV, UPARROWV, RPARENV,
                   VALUEV, SLASHV, STARV, EQV);
VAR
     SCANRSLT: THREEWORDINT;
     TOKENTYPE: TOKENKINDS;
     PT: INTEGER;
     
PROCEDURE SCANNER;
VAR
     NUM: INTEGER;
     CH: CHAR;


PROCEDURE GETVALUE;
VAR
  REQ_INT               : INTEGER ;
  VALSTR                : STRING;
  ENDOFNUM              : INTEGER ;
  N                     : INTEGER;
  CH                    : CHAR;
  NUMERIC               : BOOLEAN;
BEGIN
(*  get name or number value *)
  NUMERIC:=TRUE;
  ENDOFNUM := PT + 1;
  WHILE NOT (C_STRING[ENDOFNUM] IN OPERATORS) DO
    ENDOFNUM:=ENDOFNUM+1;
  VALSTR:=COPY(C_STRING,PT,ENDOFNUM-PT);
  PT := ENDOFNUM;

(* determine if a constant *)
  for n:=1 to length(valstr) do
    if not((valstr[n] in digitset) or (valstr[n]='.'))
      then numeric:=false;

(* get value of number *)
  IF NUMERIC THEN BEGIN
    VALUE( FALSE, VALSTR, SCANRSLT, REQ_INT ) ;
    TOKENTYPE := CONSTV;
  END
  ELSE BEGIN  (* NOT NUMERIC *)
    N:=FIND(VALSTR,MAINT_FIELDS);
    IF N<>0 THEN 
      VALUE(FALSE,MAINT_FIELDS[N].S_FLD,SCANRSLT,REQ_INT)
    ELSE BEGIN
      VALUE(FALSE,'0',SCANRSLT,REQ_INT);
      UNDEFINED:=TRUE;
    END;
    TOKENTYPE:=VALUEV;
  END;  (* NOT NUMERIC *)
END;   (* getvalue *)

BEGIN  (* SCANNER *)
  IF C_STRING[ PT ] = ' ' 
    THEN
      REPEAT 
        PT := PT + 1 
      UNTIL C_STRING[ PT ] <> ' '; (* get non blank *)
  CH := C_STRING[ PT ];
  IF NOT (CH IN OPERATORS)
    THEN
      GETVALUE
    ELSE
      BEGIN
        CASE CH OF
          '+': TOKENTYPE:=PLUSV;
          '-': TOKENTYPE:=MINUSV;
          '*': TOKENTYPE:=STARV;
          '/': TOKENTYPE:=SLASHV;
          '^': TOKENTYPE:=UPARROWV;
          '(': TOKENTYPE:=LPARENV;
          ')': TOKENTYPE:=RPARENV;
          '#': TOKENTYPE:=EOFV;
          '=': TOKENTYPE:=EQV
        END;
        PT := PT + 1
      END;
  IF TOKENTYPE = EOFV THEN PT := PT - 1;
END;   (* of scanner *)

PROCEDURE EXPRESSION( VAR ANS: THREEWORDINT );
VAR
     SAVEOP: CHAR;
     CHANGESIGN: BOOLEAN;
     RESULT: THREEWORDINT;

PROCEDURE PARENEXPRESSION( VAR ANS: THREEWORDINT );
BEGIN
  SCANNER;            (* throw away left paren  *)
  EXPRESSION( ANS );
  SCANNER             (* throw away right paren *)
END;    (* of parenexpression *)

PROCEDURE PRIMARY( VAR ANS: THREEWORDINT );
BEGIN   (* PRIMARY *)
  IF TOKENTYPE IN [ CONSTV, VALUEV ] THEN
    BEGIN
      { The following statement is used to remove the requirement that
        DECOPS be included in this segment.  The original line of code follows
        and is commented out. }
      IF NOT FIGURE( ANS,LONGINTZERO,SCANRSLT,'+') THEN ERR(1);
     {ANS := SCANRSLT;}
      SCANNER
    END
  ELSE
    IF TOKENTYPE = LPARENV THEN PARENEXPRESSION( ANS )
END;    (* of primary *)

PROCEDURE FACTOR( VAR ANS: THREEWORDINT );
VAR
     RESULT: THREEWORDINT;

BEGIN   (* FACTOR *)
  PRIMARY( ANS );
  WHILE TOKENTYPE = UPARROWV DO
    BEGIN
      SCANNER;
      PRIMARY( RESULT );
      IF NOT FIGURE(ANS,ANS,RESULT,'^') THEN ERR(1);
    END
END;    (* of factor *)

PROCEDURE TERM( VAR ANS: THREEWORDINT );
VAR
     SAVEOP: CHAR;
     RESULT: THREEWORDINT;

BEGIN   (* TERM *)
  FACTOR( ANS );
  WHILE TOKENTYPE IN [ STARV, SLASHV ] DO
    BEGIN
      IF TOKENTYPE = STARV THEN SAVEOP := '*' ELSE SAVEOP := '/';
      SCANNER;
      FACTOR( RESULT );
      IF NOT FIGURE(ANS,ANS,RESULT,SAVEOP) THEN ERR(1);
    END
END;    (* of term *)

BEGIN   (* EXPRESSION *)
  IF TOKENTYPE IN [ PLUSV, MINUSV ] THEN
    BEGIN
      CHANGESIGN := TOKENTYPE = MINUSV;
      SCANNER
    END
  ELSE CHANGESIGN := FALSE;
  TERM( ANS );
  IF CHANGESIGN THEN
    IF FIGURE(ANS,LONGINTZERO,ANS,'-') THEN;  (* do the unary minus *)
  WHILE TOKENTYPE IN [ PLUSV, MINUSV ] DO
    BEGIN
      IF TOKENTYPE = PLUSV THEN SAVEOP := '+' ELSE SAVEOP := '-';
      SCANNER;
      TERM( RESULT );
      IF NOT FIGURE(ANS,ANS,RESULT,SAVEOP) THEN ERR(1);
    END
END;   (* of expression *)


BEGIN  (* DOMATH *)
  PT := 1;
  SCANNER;
  EXPRESSION( ANSWER );
  NUMTOSTR(OUTANS,ANSWER,MAXWHOLE,MAXFRAC); { MAR 9 }
END;   (* of domath *)

BEGIN


    EATSPR( CALC.calc_text ) ;
    c_string:=concat(calc.calc_text,'#');
    DOMATH;

END;   (* of doit *)

{------------------------------------------------------------------------------}


BEGIN  { get the calculation string }

  done:=false;
  overflow:=false;
  undefined:=false;
  indx:=1;
  while (not done) and (indx <= screen_fields) do
    with maint_fields[indx] do begin
      if s_row=end_screen then done:=true
      else
        if s_typ in ['C','c'] then begin
          calc.calc_text:=s_def;
          (*$r-*)
          s_fld[0]:=chr(s_len);
          (*$r+*)
          doit;
          eatspl(outans); eatspr(outans);
          (*$r-*)
          
          (* remove trailing blanks *)
          while outans[length(outans)]='0' do
            delete(outans,length(outans),1);
          if outans[length(outans)]='.' 
            then delete(outans,length(outans),1);
          
          result:=pos('.',outans); {Sep 22}
          if length(outans)>s_len then  {truncate if necessary Sep 22}
            if (result>0) and (result-1<=s_len) then begin
              while length(outans)>s_len do delete(outans,length(outans),1);
              if outans[length(outans)]='.'
                then delete(outans,length(outans),1);
            end
            else begin
              outans:='0';
              overflow:=true;
            end;
          fillchar(s_fld[1],s_len,' ');
          if s_jus in ['R','r'] then
            moveleft(outans[1],s_fld[s_len-length(outans)+1],length(outans))
          else
            moveleft(outans[1],s_fld[1],length(outans));
          (*$r+*)
        end;  (* if s_type *)
      indx:=indx+1;
    end;
  if overflow then err(3);
  if undefined then err(2);
END;  {docalc}
  

Segment Procedure ACCESS_DATA_BASE;
 { Procedure performs all the adds, examines and deletes for the data base }
  
 var
   BUFFER : Packed array[0..511] of 0..255;
   DEFAULT_REC : STRING255;

Segment Procedure READ_WRITE(RW_COMMAND: Char; var REC_NO,REC_LEN,
                                                     IO_RET_CODE:Integer);
  
  var IO_BLOCKS,START_POSITION,TWO_BLOCK,START_REC,BYTE_TWO_BLOCK,
      BLOCK_NO,REC_NUM,FIRST_MOV_LEN,CHAR_OFFSET: Integer;
  
  begin {READ_WRITE}
 {$I-}
   IO_RET_CODE:=-1;
   REC_NUM:=REC_NO-1;
   if REC_NUM<0 then REC_NUM:=0;
   TWO_BLOCK:=REC_NUM div (1023 div REC_LEN);  (* 1024 correction Dec 5 1980 *)
   START_REC:=TWO_BLOCK*(1023 div REC_LEN);  (* 1024 correction Dec 5 1980 *)
   BYTE_TWO_BLOCK:=(REC_NUM-START_REC)*REC_LEN;
   BLOCK_NO:=(TWO_BLOCK*2)+2;
   if BYTE_TWO_BLOCK>=512  (* = correction Dec 5 1980 *)
     then
      begin
       BLOCK_NO:=BLOCK_NO+1;
       CHAR_OFFSET:=BYTE_TWO_BLOCK-512;
      end
     else CHAR_OFFSET:=BYTE_TWO_BLOCK;
   if CHAR_OFFSET+REC_LEN>512
     then
      begin
       if CURRENT_BLOCK<>BLOCK_NO
         then
          begin
           IO_BLOCKS:=blockread(DATA_FILE,BUFFER,1,BLOCK_NO);
           if IO_BLOCKS=0 then exit(READ_WRITE);
          end;
       FIRST_MOV_LEN:=512-CHAR_OFFSET;
       if RW_COMMAND='W'
         then
           begin
            moveleft(IO_REC.A[1],BUFFER[CHAR_OFFSET],FIRST_MOV_LEN);
            IO_BLOCKS:=blockwrite(DATA_FILE,BUFFER,1,BLOCK_NO);
            if IO_BLOCKS=0 then exit(READ_WRITE);
           end
         else moveleft(BUFFER[CHAR_OFFSET],IO_REC.A[1],FIRST_MOV_LEN);
       BLOCK_NO:=BLOCK_NO+1;
       IO_BLOCKS:=blockread(DATA_FILE,BUFFER,1,BLOCK_NO);
       if IO_BLOCKS=0 then exit(READ_WRITE);
       if RW_COMMAND='W'
         then
          begin
           moveleft(IO_REC.A[FIRST_MOV_LEN+1],BUFFER[0],REC_LEN-FIRST_MOV_LEN);
           IO_BLOCKS:=blockwrite(DATA_FILE,BUFFER,1,BLOCK_NO);
           if IO_BLOCKS=0 then exit(READ_WRITE);
          end
         else moveleft(BUFFER[0],IO_REC.A[FIRST_MOV_LEN+1],REC_LEN-FIRST_MOV_LEN);
      end
    else
     begin
      if CURRENT_BLOCK<>BLOCK_NO
        then
         begin
          IO_BLOCKS:=blockread(DATA_FILE,BUFFER,1,BLOCK_NO);
          if IO_BLOCKS=0 then exit(READ_WRITE);
         end;
      if RW_COMMAND='W'
         then
          begin
           moveleft(IO_REC.A[1],BUFFER[CHAR_OFFSET],REC_LEN);
           IO_BLOCKS:=blockwrite(DATA_FILE,BUFFER,1,BLOCK_NO);
           if IO_BLOCKS=0 then exit(READ_WRITE);
          end
         else moveleft(BUFFER[CHAR_OFFSET],IO_REC.A[1],REC_LEN);
     end;
    CURRENT_BLOCK:=BLOCK_NO;
    if IO_REC.A[3]=0 then exit(READ_WRITE);
    IO_RET_CODE:=0;
    IO_REC.A[0]:=REC_LEN;
  {$I+}
  end;  {READ_WRITE}

  Procedure DISPLAY_RECNO;
  { Procedure displays the current record number on the screen. }
  
    begin {DISPLAY RECNO}
      int_to_str(DB_RECNO,STR_RECNO);
     if length(STR_RECNO)<5 then 
       STR_RECNO:=concat(STR_RECNO,copy(UNDERLINE,1,5-length(STR_RECNO)));
     gotoxy(7,MAX_ROW-1);
     write(STR_RECNO);
    end; {DISPLAY RECNO}

  Procedure LOAD_SCREEN(LOAD_COMMAND :Char; var RECORD_STRING: STRING255);
  { Procedure load the screen array from a record obtained from the disk 
       file. }
   
   var LOAD_INDEX,T_INDEX : Integer;
   
   begin {LOAD_SCREEN}
    COPY_INDEX := 4;
    LOAD_INDEX:=1;
    while LOAD_INDEX <= NUM_FIELDS  do
     with MAINT_FIELDS[LOAD_INDEX] do
      begin
       COPY_LENGTH:=S_LEN;
       if (LOAD_COMMAND = 'A') or
          ((LOAD_COMMAND = 'D') and (S_ID = COPY(S_DEF,2,LENGTH(S_DEF)-2)))
         then S_FLD:=copy(RECORD_STRING,COPY_INDEX,COPY_LENGTH)
         else
          begin 
            IF (S_DEF = '') OR (S_DEF = COPY(UNDERLINE,1,1))
              THEN
               BEGIN
                 S_FLD := ' ';
                 FOR T_INDEX := 1 TO S_LEN-1 DO INSERT(' ',S_FLD,T_INDEX);
               END
              ELSE  { s_def<>''  Mar 12 }
                if s_def[1]<>'[' then begin
                  s_fld:=' ';
                  FOR T_INDEX := 1 TO S_LEN-1 DO INSERT(' ',S_FLD,T_INDEX)
                end
                else begin { s_def[1]='[' }
                  t_index:=find(copy(s_def,2,length(s_def)-2),maint_fields);
                  if t_index=0 then s_fld:=s_def
                    else s_fld:=maint_fields[t_index].s_fld;
                end;
          end;
        COPY_INDEX:=COPY_INDEX + COPY_LENGTH;
        LOAD_INDEX:=LOAD_INDEX + 1;
      end; {with/while}
   end; {LOAD SCREEN}

  Procedure BUILD_RECORD;
  { Procedure builds records to be placed on the disk. }
  
   begin {BUILD RECORD}
    IO_REC.A[0]:=3;  
    for INDEX:=1 to NUM_FIELDS do  { Jan 5 To correct value range error }
       IO_REC.B:=concat(IO_REC.B,MAINT_FIELDS[INDEX].S_FLD);
    (*get rid of leftover low-intensity underscores *)
    for index:=1 to length(io_rec.b) do 
      if io_rec.a[index]=223 then io_rec.a[index]:=32;  (* blank *)
    IO_REC.A[0]:=REC_LEN;
    IO_REC.A[1]:=16; (* dle *)
    IO_REC.A[2]:=32; (* space *)
    IO_REC.A[3]:=42; (* * *)
    IO_REC.A[REC_LEN-1]:=42;
    IO_REC.A[REC_LEN]:=13; (* carriage return *)
   end; {BUILD RECORD}
  
Procedure ADD;
  { Procdure finds the first next blank record and allows the operator
       to add a new record. }
    
    var 
      BLANK_INDEX:Integer;
      
    begin
      ERASE_EOL(0,MAX_ROW);
      write('Add Mode, <ENTER> to Add, <ESC> to quit');
      for BLANK_INDEX := 1 to 255 do  insert(' ',DEFAULT_REC,BLANK_INDEX);
      repeat
        repeat
          (* file max=32767 records  Oct 30 *)
          if db_recno<0 then begin
            ERASE_EOL(34,MAX_ROW);
            MESSAGE(MAX_ROW,40,'ERROR: Unable to find blank record',True);
            db_recno:=max_int;
            exit(ADD);
          end;
          READ_WRITE('R',DB_RECNO,REC_LEN,RESULTS);
          if RESULTS <> 0
            then 
              begin 
                ERASE_EOL(34,MAX_ROW);
                MESSAGE(MAX_ROW,40,'ERROR: Unable to find blank record',True);
                exit(ADD);
              end;
          DISPLAY_RECNO;
          DB_RECNO := DB_RECNO + 1;
        until (IO_REC.A[3] = 0) or (IO_REC.A[3] = 126);   
        DB_RECNO := DB_RECNO -1;
        LOAD_SCREEN('D',DEFAULT_REC);
        DISPLAY_SCREEN(MAINT_FIELDS,0,0,0,23);
        SCREEN(MAINT_FIELDS,true,0,0,0,0,23,MAX_ROW,40,EXIT_KEY);
        if EXIT_KEY=ESC_KEY  then begin
          ERASE_EOL(0,MAX_ROW);
          exit(ADD);
        end;
        if calculations then begin
          docalc; { Mar 9 }
          display_screen(maint_fields,0,0,0,23);
        end;
        BUILD_RECORD;
        READ_WRITE('W',DB_RECNO,REC_LEN,RESULTS);
        DEFAULT_REC:=IO_REC.B;
      until False;
    end;
  (*xL-*)
  (* Removed Jan 5
  Procedure INDEX_SET;
  { Procedure sets the index on a specific key in the data base. }

    begin
      MESSAGE(MAX_ROW,40,'ERROR: Inoperative selection',True);
    end;
  *)
  Procedure RECNO;
  { Procedure allows the operative to set the physical record number in
     the data base. }
  
    begin
      EXAMINE_FLAG:=False;
      FIELD_ROW := 22;  FIELD_COL := 7;
      int_to_str(DB_RECNO,FIELD_FLD);
      FIELD(FIELD_ROW,FIELD_COL,ERROW,ERRCOL,FIELD_LEN,FIELD_MIN,EXXIT,
        FIELD_JUS,FIELD_NA,FIELD_FLD,FIELD_SKIP);
      if not intvalue(field_fld,db_recno) then begin { Mar 11 }
        message(max_row,40,'ERROR: Incorrect record number',true);
        exit(recno);
      end;
      if DB_RECNO<1 then DB_RECNO:=1;
      DISPLAY_RECNO;
    end;
       
  Procedure STORE;
  { Procedure allows operator to store records in the data base. }
  
    begin
      BUILD_RECORD;
      READ_WRITE('W',DB_RECNO,REC_LEN,RESULTS);
      if RESULTS = 0  then EXAMINE_FLAG := True
        else MESSAGE(MAX_ROW,40,'ERROR: Unable to add record',True);
    end;
    
  Procedure EXAMINE;
  
  { Procedure allows the operator to examine records in the data base. }
    
    begin
      if EXAMINE_FLAG then 
        if DB_RECNO<max_int then DB_RECNO:=DB_RECNO+1;
      DISPLAY_RECNO;
      READ_WRITE('R',DB_RECNO,REC_LEN,RESULTS);
      if RESULTS <> 0
        then begin
          MESSAGE(MAX_ROW,40,'ERROR: Unable to read record',True);
          EXAMINE_FLAG:=FALSE;
        end
        else
          begin
            EXAMINE_FLAG:=True;
            LOAD_SCREEN('A',IO_REC.B);
            DISPLAY_SCREEN(MAINT_FIELDS,0,0,0,23);
          end;
    end;
    
   Procedure DELETE(DISPLAY: boolean);
  { Procedure allows the operator to delete records from the data base. }
  
    begin
      fillchar(IO_REC.A[0],REC_LEN,' ');
      IO_REC.A[0] := REC_LEN;
      IO_REC.A[1] := 16;
      IO_REC.A[2] := 32;
      IO_REC.A[3] := 126;
      IO_REC.A[REC_LEN-1] := 42;
      IO_REC.A[REC_LEN] := 13;
      READ_WRITE('W',DB_RECNO,REC_LEN,RESULTS);
      if RESULTS <> 0
        then MESSAGE(MAX_ROW,40,'ERROR: Unable to delete record',True)
        else if DISPLAY then
          begin
            LOAD_SCREEN('A',IO_REC.B);
            DISPLAY_SCREEN(MAINT_FIELDS,0,0,0,23);
          end;
      end;
    
  Procedure COMPRESS;
  { Compresses all records to the front of the file }
  (*$g+*)
  label 1;
  
  var
    NEXT,BLANK: integer;
    DONE: boolean;
    RESULT: integer;
      
  begin { compress }
    message(max_row,40,'Mash in Progress',false);
    blank:=1;
    done:=false;
    repeat { find blank record }
      read_write('R',blank,rec_len,result);
      if result<>0 then goto 1;
      if io_rec.a[3]=ord('~') then done:=true
      else if blank=max_int then goto 1
        else blank:=blank+1;
    until done;
    next:=blank+1;
    done:=false;
    while not done do begin  
      repeat   { find record }
        read_write('R',next,rec_len,result);
        if result<>0 then goto 1;
        if io_rec.a[3]=ord('*') then done:=true
        else if next=max_int then goto 1
        else next:=next+1;
      until done;
      read_write('W',blank,rec_len,result);
      if result<>0 then begin
        message(max_row,40,'Data file has uncorrectible error!',true);
        exit(compress);
      end;
      done:=false;
      blank:=blank+1;
      db_recno:=next;
      delete(false);
      if next=max_int then done:=true
      else next:=next+1;
    end;  (* while *)
1:
    db_recno:=1; { display record 1 }
    examine_flag:=false;
    examine;
    message(max_row,40,'Mash Complete   ',false);
  (*$g-*)
  end;  { compress }
  
begin  {ACCESS_DATA_BASE}
      ERASE_EOS(0,0);
      (*i-*)
      reset(DATA_FILE,DATA_NAME);
      if IO_RESULT <> 0
        then 
          begin
            MESSAGE(MAX_ROW,40,'ERROR: Unable to re-open data file',True);
            exit(MAINTAIN);
          end;
      (*i+*)
      READ_WRITE('R',DB_RECNO,REC_LEN,RESULTS);
      if RESULTS <> 0
        then MESSAGE(MAX_ROW,40,'ERROR: Unable to read first record',True)
        else LOAD_SCREEN('A',IO_REC.B);
      DISPLAY_PROMPTS(MAINT_PROMPTS,0,0,0,23);
      DISPLAY_SCREEN(MAINT_FIELDS,0,0,0,23);
      gotoxy(0,MAX_ROW-1);  writeln(PROMPTLINE);
      DISPLAY_RECNO;
      repeat
        gotoxy(0,MAX_ROW);  write(OPTLINE);
        read(Keyboard,CH);
        if CH=ESC_KEY  
          then exit(MAINTAIN) 
          else ERASE_EOL(LENGTH(OPTLINE),MAX_ROW);
        if CH in['a'..'z'] then CH:=chr(ord(CH)+ord('A')-ord('a'));
        if not (CH IN['S','M','R','A','E','C','D','Q'])
          then MESSAGE(MAX_ROW,40,'ERROR: Invalid Selection',True)
          else
            case CH of
              'M' :  COMPRESS;
              'R' :  RECNO;
              'S' :  STORE;
              'A' :  ADD;
              'E' :  EXAMINE;
              'C' :  BEGIN  { Mar 9 }
                      SCREEN(MAINT_FIELDS,true,0,0,0,0,23,MAX_ROW,40,EXIT_KEY);
                      if calculations then begin  { Mar 11 }
                        docalc;
                        display_screen(maint_fields,0,0,0,23);
                      end;
                     END;
              'D' :  DELETE(true);
              'Q' :  exit(ACCESS_DATA_BASE);
             end;
      until False;
    end;   {ACCESS_DATA_BASE}

Procedure FORMAT_RECNO(var RECNO_FIELD :STRING5);
  var RECNO_INDEX: Integer;
  begin {FORMAT RECNO}
   for RECNO_INDEX:=1 to length(RECNO_FIELD) do
    if RECNO_FIELD[RECNO_INDEX] in ['+','-','.']
      then RECNO_FIELD[RECNO_INDEX]:=' ';
   RECNO_INDEX:=pos(' ',RECNO_FIELD);
   if RECNO_INDEX=0 then RECNO_INDEX:=length(RECNO_FIELD)
     else RECNO_INDEX:=RECNO_INDEX-1;
   if RECNO_INDEX=0 then RECNO_FIELD:='1'
     else RECNO_FIELD:=copy(RECNO_FIELD,1,RECNO_INDEX);
  end; {FORMAT RECNO}
    
  Procedure BELL;
    begin {BELL}
      write(ALARM_BELL);
    end; {BELL}
    
  Procedure RECORD_LENGTH{var S_ARRAY :SCREEN_ARR};
  { Function to find the length of the record defined by the data base
       definition.}
  { For the first release this will also check to see if there are any 
       fields defined as calculated.  These will be marked as in error. }
   var
     DONE: boolean; { Jan 5 To correct end_screen problem }

   begin {RECORD LENGTH}
    REC_LEN:=0;
    DONE:=false; { Jan 5 }
    INDEX:=1;
    CALCULATIONS:=false;
    while not DONE do 
      if MAINT_FIELDS[INDEX].S_ROW=END_SCREEN then DONE:=true 
      else begin
        REC_LEN:=REC_LEN+MAINT_FIELDS[INDEX].S_LEN;
        if MAINT_FIELDS[INDEX].S_TYP IN ['C','c']
          then CALCULATIONS:=true;
        DONE := INDEX = SCREEN_FIELDS;
        INDEX:=INDEX+1;
      end;
    REC_LEN:=REC_LEN+5;
    NUM_FIELDS:=INDEX-1; { Jan 5/Mar 12 }
   end; {RECORD LENGTH}
  
  Procedure MESSAGE{M_ROW,M_COL :Integer; MSG :String; DING: Boolean};
  { Procedure displays messages at the message row and column. }
  
    begin {MESSAGE}
      gotoxy(M_COL,M_ROW);  write(MSG);
      if DING then write(ALARM_BELL);
    end; {MESSAGE}
  
  Procedure EAT_SPACES(var TEMP :String; LEFT_EAT,RIGHT_EAT :Boolean);
  { Procedure to remove the spaces from either or both sides of a string. }
  
    begin {EAT SPACES}
     if LEFT_EAT then EATSPL(TEMP);
     if RIGHT_EAT then EATSPR(TEMP);
    end; {EAT SPACES}
    
  
begin  {MAINTAIN}
  INITIALIZE;
  GET_DATA_BASE;
  ACCESS_DATA_BASE;
  close(DATA_FILE,lock);
end.   {MAINTAIN}




========================================================================================
DOCUMENT :usus Folder:VOL25:ud.sort.text
========================================================================================

{$L PRINTER:}

PROGRAM UDE_SORT;

{ Once a data base has been defined, this set of procedures allows the
     operator to sort data base records. }
  
  uses {$U SH.SCREEN.UNIT} SCREEN40;
  
  type STRING25 = String[25];

  var ACCESS_FLAG: Boolean;
      ERROR,RECSREAD,RECSWRIT: Integer;
      CH: Char;

  Segment Procedure ACCESS_DATA_BASE(var SORT_FLAG: Boolean);
  { Procedure initilizes everything to begin maintaining the data base. }

  var GET_FIELDS,SORT_FIELDS,
      MAINT_FIELDS    : SCREEN_ARR;  { Array to hold data fields }
      GET_PROMPTS,SORT_PROMPTS,
      MAINT_PROMPTS : PROMPT_ARR;  { Array to hold screen prompts }
      GET_RESULTS,RESULTS,ERROR_ID: Integer;
      EXIT_KEY,CH: Char;
      DISPLAY_FLAG: Boolean;
      VOLUME,                 { Data base volume }
      SORT_VOL  : STRING[7];
      NAME,                   { Data base Name }
      SORT_NAME : STRING[10]; { Sort format name }
      DB_NAME   : STRING[18]; { Volume + Data Base Name }
      PROMPT1,PROMPT2,VERSION,
      DATA_NAME,              { Data file name }
      DEFI_NAME,              { Data Base Definition file name }
      SORT_VOL_NAME : STRING[23]; { Sort format file name }
      DATA_FILE : File;
    
  Procedure MESSAGE(M_ROW,M_COL: Integer; MSG: String; DING: Boolean);
    forward;

  Procedure INITIALIZE;
   var I: Integer;
   begin  {INITIALIZE}
    for I:=1 to SCREEN_FIELDS do
     with GET_FIELDS[I] do
      begin
       S_ID :='';   S_ROW:=END_SCREEN;
       S_COL:=15;   S_LEN:=7;    S_MIN:=0;
       S_TYP:='V';  S_JUS:='L';  S_NA :='S';
       S_SKIP:=False;S_DEF:='';   S_FLD:='';
      end; {with/for}
    for I:=1 to PROMPT_FIELDS do
     with GET_PROMPTS[I] do
      begin
       P_ROW:=END_SCREEN;  P_COL:=0;   P_FLD:='';
      end; {with/for}
    with GET_FIELDS[1] do
      begin
        S_ID :='VOL';  S_ROW:=5;
      end;
    with GET_FIELDS[2] do
      begin
        S_ID :='NAME';  S_ROW:=7;  S_LEN:=10;
      end;
    with GET_PROMPTS[1] do
      begin
        P_ROW:=5;  P_FLD:='Volume    :'
      end;
    with GET_PROMPTS[2] do
      begin
        P_ROW:=7;  P_FLD:='Name      :'
      end;
    CLEAR_HOME;
    PROMPT1:='Get format,Save format';
    PROMPT2:='Change,eXecute,Quit ?';
    VERSION:='Version  IV.0';
    for I:=1 to 22 do 
     if not(PROMPT1[I] in['A'..'Z']) then PROMPT1[I]:=chr(ord(PROMPT1[I])+128);
    for I:=1 to 21 do
     if not(PROMPT2[I] in['A'..'Z']) then PROMPT2[I]:=chr(ord(PROMPT2[I])+128);
   end;   {INITIALIZE}

  Procedure GET_DATA_BASE;
  { Procedure gets the Data Base Definition from the disk. }
    begin  {GET_DATA_BASE}  
     HOME;
     writeln(' ':25,'SORT A DATA BASE');
     writeln(' ':25,'=================');
     writeln(' ':25,VERSION);
     DISPLAY_PROMPTS(GET_PROMPTS,0,0,0,23);
     gotoxy(0,9);
     write('Type      :    SCRN and TEXT');
     DISPLAY_SCREEN(GET_FIELDS,0,0,0,23);
     MESSAGE(MAX_ROW,0,'<ENTER> to execute, <ESC> to abort',False);
     repeat
      SCREEN(GET_FIELDS,true,0,0,0,0,MAX_ROW,MAX_ROW,40,EXIT_KEY);
      if EXIT_KEY = ESC_KEY then exit(UDE_SORT);
      VOLUME := GET_FIELDS[FIND('VOL',GET_FIELDS)].S_FLD;
      EATSPR(VOLUME);
      NAME   := GET_FIELDS[FIND('NAME',GET_FIELDS)].S_FLD;
      EATSPR(NAME);
      DB_NAME := concat(VOLUME,':',NAME);
      DEFI_NAME := concat(DB_NAME,'.SCRN');
      DATA_NAME := concat(DB_NAME,'.TEXT');
      GET_FILE(DEFI_NAME,MAINT_FIELDS,MAINT_PROMPTS,RESULTS);
      if RESULTS = 0
       then
        begin
        {$I-}
         reset(DATA_FILE,DATA_NAME);
        {$I+}
         if IORESULT <> 0
           then MESSAGE(MAX_ROW,40,'ERROR: No data file found',True)
           else 
             begin
               close(DATA_FILE,lock);
               exit(GET_DATA_BASE);
             end;
         end
       else MESSAGE(MAX_ROW,40,'ERROR: Unknown Data Base',True)
     until False;
   end;   {GET_DATA_BASE}

  Procedure GET_SAVE_FORMAT(GS_COMMAND: Char);
  { Procedure loads or saves printing format specification on disk. }
   begin {GET SAVE FORMAT}
     CLEAR_HOME;
     if GS_COMMAND = 'G'
      then
       begin
         HOME;
         writeln(' ':25,'GET SORTING FORMAT');
         writeln(' ':25,'==================');
       end
      else
       begin
         HOME;
         writeln(' ':25,'SAVE SORTING FORMAT');
         writeln(' ':25,'===================');
       end;
     DISPLAY_PROMPTS(GET_PROMPTS,0,0,0,23);
     gotoxy(0,9);
     write('Type      :    SORT');
     MESSAGE(MAX_ROW,0,'<ENTER> to execute, <ESC> to abort',False);
     DISPLAY_SCREEN(GET_FIELDS,0,0,0,23);
     repeat  
      SCREEN(GET_FIELDS,true,0,0,0,0,MAX_ROW,MAX_ROW,40,EXIT_KEY);
      ERASE_EOL(40,MAX_ROW);
      if EXIT_KEY = ENTER_KEY
        then
         begin
          SORT_VOL := GET_FIELDS[FIND('VOL',GET_FIELDS)].S_FLD;
          EATSPR(SORT_VOL);
          SORT_NAME := GET_FIELDS[FIND('NAME',GET_FIELDS)].S_FLD;
          EATSPR(SORT_NAME);
          SORT_VOL_NAME := concat(SORT_VOL,':',SORT_NAME,'.SORT');
          if GS_COMMAND = 'G'
            then
              begin
               GET_FILE(SORT_VOL_NAME,SORT_FIELDS,SORT_PROMPTS,GET_RESULTS);
               if GET_RESULTS <> 0
                 then MESSAGE(MAX_ROW,40,'ERROR: Unknown sorting format',True)
                 else exit(GET_SAVE_FORMAT);
              end
             else
              begin
               SAVE_FILE(SORT_VOL_NAME,SORT_FIELDS,SORT_PROMPTS,GET_RESULTS);
               if GET_RESULTS <> 0
                 then MESSAGE(MAX_ROW,40,
                              'ERROR: Unable to save sorting format',True)
                 else exit(GET_SAVE_FORMAT);
              end;
         end
        else exit(GET_SAVE_FORMAT);
     until False;
   end; {GET SAVE FORMAT}
    
  Procedure MESSAGE;(* M_ROW,M_COL: Integer; MSG: String; DING: Boolean *)
  { Procedure displays messages at the message row and column. }
    begin
      gotoxy(M_COL,M_ROW);  write(MSG);
      if DING then write(ALARM_BELL);
    end;
  
  Procedure SORTPARM(var PARM_RETURN: Integer);
   const NUMBER_KEYS  = 10;  { Maximnu number of keys allowed on screen }
   type PARM_RECORD = record
           FIELD_NUMBER :  Integer;
           AD_VALUE     : Char;
         end;
   var PARM_INDEX,IDFIELD_NUMBER,MAINT_INDEX,ARRAY_INDEX :  Integer;
       IDVALUE,IDNAME : String[8];
       PARM_ARRAY : Array[1..NUMBER_KEYS] of PARM_RECORD;
       PARM_FILE : Text;
       WORK_VOL,
       OUTPUT_VOLUME : STRING[7];
       OUTPUT_NAME   : STRING[10];
    begin {SORTPARM}
      PARM_RETURN := 0;
      PARM_INDEX := 0;
      gotoxy(0,10);
      for ARRAY_INDEX := 1 to NUMBER_KEYS do
       begin
        str(ARRAY_INDEX,IDNAME);
        IDNAME := concat('ID',IDNAME);
        IDFIELD_NUMBER := FIND(IDNAME,SORT_FIELDS);
        IDVALUE := SORT_FIELDS[IDFIELD_NUMBER].S_FLD;
        EATSPL(IDVALUE);  EATSPR(IDVALUE);
        if length(IDVALUE) > 0
          then 
           begin 
            MAINT_INDEX := FIND(IDVALUE,MAINT_FIELDS);
            if (MAINT_INDEX = 0)
               then
                 begin
                  MESSAGE(MAX_ROW,40,'ERROR: Invalid field ID',True);
                  PARM_RETURN := IDFIELD_NUMBER;
                  exit(SORT_PARM);
                 end
               else
                 begin
                  str(ARRAY_INDEX,IDNAME);
                  IDNAME := concat('AD',IDNAME);
                  IDFIELD_NUMBER := FIND(IDNAME,SORT_FIELDS);
                  IDVALUE := SORT_FIELDS[IDFIELD_NUMBER].S_FLD;
                  EATSPL(IDVALUE);  EATSPR(IDVALUE);
                  PARM_INDEX := PARM_INDEX + 1;
                  with PARM_ARRAY[PARM_INDEX] do
                    begin
                      FIELD_NUMBER := MAINT_INDEX + 1;
                      if (IDVALUE = 'D') or (IDVALUE = 'd')
                        then AD_VALUE := 'D' else AD_VALUE := 'A';
                    end; 
                end;
            end;
       end;
      if PARM_INDEX = 0
         then 
           begin
            MESSAGE(MAX_ROW,40,'ERROR: No valid field ids found',True);
            PARM_RETURN := 1;
            exit(SORTPARM);
           end;
      (*$i-*)
      rewrite(PARMFILE,'TEMPSORT.TEXT');
      if IORESULT <> 0 then begin
        MESSAGE(MAX_ROW,40,'ERROR: No room for param file on disk',True);
        PARM_RETURN := 1;
        exit(SORTPARM);
      end;
      (*$i+*)
      writeln(PARMFILE,'S');
      writeln(PARMFILE,DATA_NAME);
      writeln(PARMFILE,'T');
      OUTPUT_VOLUME := SORT_FIELDS[FIND('VOL',SORT_FIELDS)].S_FLD;
      EATSPL(OUTPUT_VOLUME);  EATSPR(OUTPUT_VOLUME);
      if (OUTPUT_VOLUME = 'PRINTER') or (OUTPUT_VOLUME = 'printer')
        then writeln(PARMFILE,'PRINTER:')
        else
         begin
          OUTPUT_NAME   := SORT_FIELDS[FIND('NAME',SORT_FIELDS)].S_FLD;
          EATSPL(OUTPUT_NAME);  EATSPR(OUTPUT_NAME);
          if length(OUTPUT_NAME) < 1
            then writeln(PARMFILE,DATA_NAME)
            else writeln(PARMFILE,concat(OUTPUT_VOLUME,':',OUTPUT_NAME,'.TEXT'));
         end;
      writeln(PARMFILE,'T');
      WORK_VOL := SORT_FIELDS[FIND('WORKVOL',SORT_FIELDS)].S_FLD;
      EATSPL(WORK_VOL);  EATSPR(WORK_VOL);
      writeln(PARMFILE,concat(WORK_VOL,':'));
      writeln(PARMFILE,'T');
      writeln(PARMFILE,'Y');
      writeln(PARMFILE,'F');
      writeln(PARMFILE,'1');
      ARRAY_INDEX := 1;
      while ARRAY_INDEX <= SCREEN_FIELDS do begin
        if MAINT_FIELDS[ARRAY_INDEX].S_ROW <> END_SCREEN then
          writeln(PARMFILE,MAINT_FIELDS[ARRAY_INDEX].S_LEN)
        else ARRAY_INDEX := SCREEN_FIELDS;
        ARRAY_INDEX := ARRAY_INDEX + 1;
      end;
      writeln(PARMFILE,'1');
      writeln(PARMFILE,'0');
      writeln(PARMFILE,'1');
      writeln(PARMFILE,'A');
      for ARRAY_INDEX := 1 to PARM_INDEX do
        begin
          writeln(PARMFILE,PARM_ARRAY[ARRAY_INDEX].FIELD_NUMBER);
          writeln(PARMFILE,PARM_ARRAY[ARRAY_INDEX].AD_VALUE);
        end;
      writeln(PARMFILE,'0');
      writeln(PARMFILE,'N');
      close(PARMFILE,lock);
    end;
    
    begin  {ACCESS_DATA_BASE}
      INITIALIZE;
      GET_DATA_BASE;
      GET_FILE('UD/SORT.SCRN',SORT_FIELDS,SORT_PROMPTS,RESULTS);
      if RESULTS <> 0
        then 
          begin
            MESSAGE(MAX_ROW,40,'ERROR: Unable to load "UD/SORT.SCRN"',True);
            exit(UDE_SORT);
          end;
      GET_FIELDS[FIND('VOL',GET_FIELDS)].S_FLD := ' ';
      GET_FIELDS[FIND('NAME',GET_FIELDS)].S_FLD := ' ';
      DISPLAY_FLAG := True;
      repeat
       if DISPLAY_FLAG
        then
          begin
           CLEAR_HOME;
           DISPLAY_PROMPTS(SORT_PROMPTS,0,0,0,23);
           DISPLAY_SCREEN(SORT_FIELDS,0,0,0,23);
           gotoxy(0,MAX_ROW-1); 
           writeln(PROMPT1);
           write(PROMPT2);
           DISPLAY_FLAG := False;
         end;
       gotoxy(24,MAX_ROW);
       read(Keyboard,CH);
        if CH = ESC_KEY then exit(UDE_SORT);
        SORT_FLAG := False;
        if CH in['a'..'z'] then CH:=chr(ord(CH)+ord('A')-ord('a'));
        ERASE_EOL(25,MAX_ROW);
        if not(CH in['C','G','X','S','Q'])
          then MESSAGE(MAX_ROW,40,'ERROR: Invalid Selection',True)
          else
           case CH of
             'G':  begin
                    GET_SAVE_FORMAT('G');
                    DISPLAY_FLAG := True;
                   end;
             'S':  begin
                    GET_SAVE_FORMAT('S');
                    DISPLAY_FLAG := True;
                  end;
             'X':  begin
                    SORTPARM(ERROR_ID);
                    if ERROR_ID <> 0
                      then SCREEN(SORT_FIELDS,true,ERROR_ID,0,0,0,MAX_ROW,
                        MAX_ROW,40,EXIT_KEY)
                      else
                       begin
                         SORT_FLAG :=True;
                         exit(ACCESS_DATA_BASE);
                       end;
                  end;
             'C':  SCREEN(SORT_FIELDS,true,0,0,0,0,MAX_ROW,MAX_ROW,40,EXIT_KEY);
             'Q':  exit(UDE_SORT);
            end;
      until False;
    end;   {ACCESS_DATA_BASE}

  segment procedure psort(paramname:strING25; var error,recsread,
                        recswritten:integer);

const
  maxkeys = 11;      {number of keys}
  maxkeylen = 40;    {number of chars. in a key}
  maxfiles = 10;     {number of intermediate workfiles}
  mrl = 255;         {record (line) length}
  maxfields = 42;    {number of fields in fixed length record}
                     { plus 2 to account for the *'s at front and back}
  minmem = 9000;     { leave room for stack }

type
  stringrec = string[mrl];
  key = string [maxkeylen];
  nodeptr = ^node;
  node = record
          item : stringrec;
          majkey : key;
          lptr, rptr : nodeptr
         end;
  comparison = (lessthan, equal, greaterthan);
  keydirn = (ascending, descending);
  field =  record
             keystart, keylen : 1..mrl
           end;
  keyvals = record
              fieldnum : 1..maxfields;
              keydirection : keydirn
            end;
  str = string[25];

var
  filename, ifilename, ofilename : str;
  infile, outfile : text;
  inffile, outffile : file of stringrec;
  filesused : integer;
  toomanyfiles : boolean;
  fielddata : array[1..maxfields] of field;
  keydata : array [1..maxkeys] of keyvals;
  intread : integer;
  numfields, numkeys : integer;
  memorycontained : boolean;
  intfilevol : string [10];
  keytype : (fixed, variable);
  keydelim : char;
  i : integer;
  temp_outfile : integer;
  mergefile : integer;
  inform : boolean;
  mergeonly : boolean;
  one_mo_time : boolean;
  end_of_infile : boolean;
  textin, textint, textout : boolean;
  mergeinput : array[1..maxfiles] of str;
  bell : char;
  ioerr: boolean;
  
  {-----------DEFINED FOR BLOCK IO BY CLAY LAIRD   3 JUL 80------}
  
  BLOCKS_WROTE,BLOCK_NUMBER,ARRAY_INDEX,BLOCK_RESULTS: INTEGER;
  OUTPUT_FILE : FILE;
  BLOCK_ARRAY : PACKED ARRAY [0..1023] OF CHAR;
  
  PROCEDURE BL_OPEN(VAR BLOCK_FILE:STR;           (* File name         *)
                     VAR BLOCK_RETURN:INTEGER);   (* Return code       *)
    FORWARD;

  PROCEDURE BL_WRITE(VAR BLOCK_RECORD:STRINGREC;  (* String to write   *)
                     VAR BLOCK_RETURN:INTEGER);   (* Return code       *)
    FORWARD;

  PROCEDURE BL_CLOSE(VAR BLOCK_RETURN:INTEGER);   (* Return code       *)
    FORWARD;
  
  {-----------------------------------------------------}
  
  function relation(item1, item2 : stringrec; stkey : integer)
                                         : comparison;forward;
  procedure getfield(fieldnum : integer; source : stringrec;
                   var thefield : key); forward;
  procedure checkio(str1, str2 : str; var ioerr : boolean);
                                                forward;
  procedure openoutputfile; forward;
  
  {----------------------------------------------------}
  
  segment procedure getparm(from : str);
     { Gets the parameters from the parameter file. }
  
  var
    parmfile : text;
    inint : integer;
    inchar : char;
    instring : str;
    start : integer;
    inkey : key;
    
    procedure setupmergenames;
           
      begin
        mergeinput[ 1] := concat(intfilevol, 'SRT1');
        mergeinput[ 2] := concat(intfilevol, 'SRT2');
        mergeinput[ 3] := concat(intfilevol, 'SRT3');
        mergeinput[ 4] := concat(intfilevol, 'SRT4');
        mergeinput[ 5] := concat(intfilevol, 'SRT5');
        mergeinput[ 6] := concat(intfilevol, 'SRT6');
        mergeinput[ 7] := concat(intfilevol, 'SRT7');
        mergeinput[ 8] := concat(intfilevol, 'SRT8');
        mergeinput[ 9] := concat(intfilevol, 'SRT9');
        mergeinput[10] := concat(intfilevol, 'SRT10');
    {   mergeinput[11] := concat(intfilevol, 'SRT11');
        mergeinput[12] := concat(intfilevol, 'SRT12');
        mergeinput[13] := concat(intfilevol, 'SRT13');
        mergeinput[14] := concat(intfilevol, 'SRT14');
        mergeinput[15] := concat(intfilevol, 'SRT15');
        mergeinput[16] := concat(intfilevol, 'SRT16');
        mergeinput[17] := concat(intfilevol, 'SRT17');
        mergeinput[18] := concat(intfilevol, 'SRT18');
        mergeinput[19] := concat(intfilevol, 'SRT19');
        mergeinput[20] := concat(intfilevol, 'SRT20');     }
      end;
    
    
    begin
        (*$I-*)
        reset(parmfile,from);
        checkio('abort',from,ioerr);
        (*$I+*)
        ERASE_EOL(40,22);
        writeln('STATUS: Reading parameter file');
        readln(parmfile,instring);
        inchar := instring[1];
        mergeonly := FALSE;
        readln(parmfile, ifilename);
        readln(parmfile,instring);
        inchar := instring[1];
        textin := (inchar='T') or (inchar='t');
        readln(parmfile, ofilename);
        readln(parmfile,instring);
        inchar := instring[1];
        textout := (inchar='T') or (inchar='t');
        readln(parmfile, intfilevol);
        readln(parmfile, instring);
        inchar := instring[1];
        textint := (inchar='T') or (inchar='t');
        readln(parmfile, instring);inchar := instring[1];
        inform := (inchar = 'Y') or (inchar = 'y');
        readln(parmfile, instring);inchar:=instring[1];
        keytype := fixed;
        numfields := 1;
        start := 1;
        repeat
          readln(parmfile, inint);
          if inint > 0 then
            begin
              with fielddata[numfields] do
                begin
                  keylen := inint;
                  keystart := start
                end;   {with}
              start := start + inint;
              numfields := numfields + 1
            end;
        until inint <= 0;
        numfields := numfields - 1;
        numkeys := 1;
        repeat
          readln(parmfile, inint);
          if inint > 0 then
            begin
              with keydata[numkeys] do
                begin
                  fieldnum := inint;
                  readln(parmfile, instring);
                  inchar := instring[1];
                  if inchar in ['A','a'] then
                    keydirection := ascending
                  else
                    keydirection := descending;
                end;   {with}
              numkeys := numkeys + 1
            end
        until inint <= 0;
        numkeys := numkeys - 1;
        readln(parmfile, instring);
        inchar := instring[1];
        close(parmfile,purge);  (* to dispose of temp file, Oct 29 *)
        SETUPMERGENAMES;
    end;  { getparmp }
  {------------------------------------------------------}

  segment procedure distribute;

  var
    f1 : text;
    inrec : stringrec;
    inrecmajkey : key;
    someontree : boolean;
    root : nodeptr;
    heap : ^integer;
  
  procedure writelnx(item : stringrec);
  
  begin
      writeln(f1, item)
  end;  { writelnx }
  
   procedure rewritex(n : integer);
   
  begin
  (*$i-*)
      rewrite(f1, mergeinput[n])
  (*$i+*)
  end; { rewritex }
  
  procedure closex;
  
  begin
      close(f1, lock)
  end;  { closex }
  
  procedure putontree(var ptr : nodeptr);
    
    var
      p1 : nodeptr;
      
    function compare : comparison;
    begin
      if inrecmajkey < p1^.majkey then
        begin
          if keydata[1].keydirection = ascending then
            compare := lessthan
          else
            compare := greaterthan
        end
      else
        begin
          if keydata[1].keydirection = ascending then
            compare := greaterthan
          else
            compare := lessthan
        end
    end;   { compare }
      
    begin
      p1 := ptr;
      if p1 = nil then
        begin
          new(p1);
          with p1^ do
            begin
              lptr := nil; rptr := nil;
              item := inrec;
              majkey := inrecmajkey
            end;
          ptr := p1; someontree := true
        end
      else
        begin
          if inrecmajkey = p1^.majkey then
            begin
              if relation(inrec, p1^.item,2) = lessthan then
                putontree(p1^.lptr)
              else
                putontree(p1^.rptr)
            end
          else
            begin   { use major key }
              if compare = lessthan then
                putontree(p1^.lptr)
              else
                putontree(p1^.rptr)
            end
        end
    end;        { putontree }
    
    procedure outputree(ptr : nodeptr);
    
    begin
      if ptr <> nil then
        with ptr^ do
          begin
            outputree(lptr);
            if memorycontained 
              then
                begin
                  ITEM := CONCAT('  ',ITEM,' ');
                  ITEM[1] := CHR(16);
                  ITEM[2] := CHR(32);
                  ITEM[LENGTH(ITEM)] := CHR(13);
                  BL_WRITE(ITEM,BLOCK_RESULTS);
                  recswritten := recswritten + 1;
                end
              else writelnx(item);
            outputree(rptr)
          end
      end;    { outputree }
      
  function eofinfile : boolean;
  
  begin
      eofinfile := eof(infile)
  end;   { eofinfile }
  
  begin { distribute }
    ERASE_EOL(40,22);
    write('STATUS: Distributing ...');
    ERASE_EOL(40,23);
    toomanyfiles := false; someontree := false;
    filesused := 0;
    while (not eofinfile) and (filesused < maxfiles-2) do
      begin
        root := nil;
        mark(heap);
        while (varavail('ude_sort,psort,distribute') > minmem) and 
                                                    (not eofinfile) do
          begin
            readln(infile, inrec);
            if inrec <> '' then { use only non-null strs}
              begin
                recsread := recsread + 1;
                getfield(keydata[1].fieldnum,inrec,inrecmajkey);
                putontree(root)
              end
          end;
        
        if someontree then
          begin
            if (not eofinfile) or (filesused > 0) or (one_mo_time) then
              begin
                filesused := filesused + 1;
                ERASE_EOL(40,23);
                write('  Writing workfile # ',filesused, '...');
                rewritex(filesused);
                if IORESULT <> 0 then CHECKIO('abort','',IOERR);
                outputree(root);     { write to int file}
                closex;   { close and lock that workfile }
                release(heap)
              end
             else
               begin    { memory contained }
                 memorycontained := true;
                 openoutputfile;
                 ERASE_EOL(40,22);
                 GOTOXY(40,23);
                 write('STATUS: Writing output file...    ');
                 outputree(root);
                 release(heap)
               end
           end
         else
           begin
             release(heap);
             memorycontained := true; {prevent the merge}
             openoutputfile  {for the later close (of empty 
                                         file)}
           end
       end;
     end_of_infile := eofinfile;
   end; { distribute }
  {---------------------------------------------------- }
  
  segment procedure merge;
  
  type
    tabrec = record
              hasdata : boolean;
              inrec : stringrec
            end;
            
  var
    {--------- SHIFT COMMENT DELIMITER TO CHANGE --------}
    {--------- NUMBER OF WORK/MERGE-INPUT FILES. --------}
    
    {............... Text Files .........................}
    
  f1,f2,f3,f4,f5,f6,f7,f8,f9,f10
  { ,f11,f12,f13,f14,f15,f16,f17,f18,f19,f20 } :text;
    
    {----------------------------------------------------}
    
    table : array [1..maxfiles] of tabrec;
    current : 0..maxfiles;      { points to current smallest
                                     record }
    i : 1..maxfiles;
    badio : boolean;
    
      {----------------------------------------------------}
  
  { The following functions/procedures are because
   the declaration
     
     f : array[1..maxfiles] of text;
     
    is not permitted in UCSD Pascal (and some others).
  }
  
  procedure readlnx(n : integer; var item : stringrec);
    begin
      case n of
        1: readln( f1, item);
        2: readln( f2, item);
        3: readln( f3, item);
        4: readln( f4, item);
        5: readln( f5, item);
        6: readln( f6, item);
        7: readln( f7, item);
        8: readln( f8, item);
        9: readln( f9, item);
       10: readln(f10, item);
  {    11: readln(f11, item);
       12: readln(f12, item);
       13: readln(f13, item);
       14: readln(f14, item);
       15: readln(f15, item);
       16: readln(f16, item);
       17: readln(f17, item);
       18: readln(f18, item);
       19: readln(f19, item);
       20: readln(f20, item);     }
     end;
    end;   { readlnx }
     
  function eofx(n : integer) : boolean;

  begin
    {$I-}
    case n of
      1 : eofx := eof( f1);
      2 : eofx := eof( f2);
      3 : eofx := eof( f3);
      4 : eofx := eof( f4);
      5 : eofx := eof( f5);
      6 : eofx := eof( f6);
      7 : eofx := eof( f7);
      8 : eofx := eof( f8);
      9 : eofx := eof( f9);
      10: eofx := eof(f10);
   {  11: eofx := eof(f11);
      12: eofx := eof(f12);
      13: eofx := eof(f13);
      14: eofx := eof(f14);
      15: eofx := eof(f15);
      16: eofx := eof(f16);
      17: eofx := eof(f17);
      18: eofx := eof(f18);
      19: eofx := eof(f19);
      20: eofx := eof(f20);  }
    end;
   {$I+}
  end;  { eofx }

  procedure resetx(n : integer);
    begin
      (*$I-*)
        case n of
          1: reset( f1, mergeinput[1]);
          2: reset( f2, mergeinput[2]);
          3: reset( f3, mergeinput[3]);
          4: reset( f4, mergeinput[4]);
          5: reset( f5, mergeinput[5]);
          6: reset( f6, mergeinput[6]);
          7: reset( f7, mergeinput[7]);
          8: reset( f8, mergeinput[8]);
          9: reset( f9, mergeinput[9]);
         10: reset(f10, mergeinput[10]);
      {  11: reset(f11, mergeinput[11]);
         12: reset(f12, mergeinput[12]);
         13: reset(f13, mergeinput[13]);
         14: reset(f14, mergeinput[14]);
         15: reset(f15, mergeinput[15]);
         16: reset(f16, mergeinput[16]);
         17: reset(f17, mergeinput[17]);
         18: reset(f18, mergeinput[18]);
         19: reset(f19, mergeinput[19]);
         20: reset(f20, mergeinput[20]);    }
       end;
      (*$I+*)
    end;   { resetx }

  procedure closex(n : integer; l_or_p : char);

  begin
    if l_or_p = 'l'
      then
        case n of
           1 : close( f1,lock);
           2 : close( f2,lock);
           3 : close( f3,lock);
           4 : close( f4,lock);
           5 : close( f5,lock);
           6 : close( f6,lock);
           7 : close( f7,lock);
           8 : close( f8,lock);
           9 : close( f9,lock);
          10 : close(f10,lock);
      {   11 : close(f11,lock);
          12 : close(f12,lock);
          13 : close(f13,lock);
          14 : close(f14,lock);
          15 : close(f15,lock);
          16 : close(f16,lock);
          17 : close(f17,lock);
          18 : close(f18,lock);
          19 : close(f19,lock);
          20 : close(f20,lock)      }
        end
      else
        case n of
         1 : close( f1,purge);
         2 : close( f2,purge);
         3 : close( f3,purge);
         4 : close( f4,purge);
         5 : close( f5,purge);
         6 : close( f6,purge);
         7 : close( f7,purge);
         8 : close( f8,purge);
         9 : close( f9,purge);
        10 : close(f10,purge);
    {   11 : close(f11,purge);
        12 : close(f12,purge);
        13 : close(f13,purge);
        14 : close(f14,purge);
        15 : close(f15,purge);
        16 : close(f16,purge);
        17 : close(f17,purge);
        18 : close(f18,purge);
        19 : close(f19,purge);
        20 : close(f20,purge)    }
      end;  { closepx }
  end;

  procedure writelnx(n : integer; var item : stringrec);
    begin
      case n of
        1: writeln( f1, item);
        2: writeln( f2, item);
        3: writeln( f3, item);
        4: writeln( f4, item);
        5: writeln( f5, item);
        6: writeln( f6, item);
        7: writeln( f7, item);
        8: writeln( f8, item);
        9: writeln( f9, item);
       10: writeln(f10, item);
  {    11: writeln(f11, item);
       12: writeln(f12, item);
       13: writeln(f13, item);
       14: writeln(f14, item);
       15: writeln(f15, item);
       16: writeln(f16, item);
       17: writeln(f17, item);
       18: writeln(f18, item);
       19: writeln(f19, item);
       20: writeln(f20, item);     }
     end;
    end;   { writelnx }
  
  procedure rewritex(n : integer);
    begin
    (*$i-*)
      case n of
        1: rewrite( f1, mergeinput[1]);
        2: rewrite( f2, mergeinput[2]);
        3: rewrite( f3, mergeinput[3]);
        4: rewrite( f4, mergeinput[4]);
        5: rewrite( f5, mergeinput[5]);
        6: rewrite( f6, mergeinput[6]);
        7: rewrite( f7, mergeinput[7]);
        8: rewrite( f8, mergeinput[8]);
        9: rewrite( f9, mergeinput[9]);
       10: rewrite(f10, mergeinput[10]);
    {  11: rewrite(f11, mergeinput[11]);
       12: rewrite(f12, mergeinput[12]);
       13: rewrite(f13, mergeinput[13]);
       14: rewrite(f14, mergeinput[14]);
       15: rewrite(f15, mergeinput[15]);
       16: rewrite(f16, mergeinput[16]);
       17: rewrite(f17, mergeinput[17]);
       18: rewrite(f18, mergeinput[18]);
       19: rewrite(f19, mergeinput[19]);
       20: rewrite(f20, mergeinput[20]);    }
     end;
    (*$i+*)
    end;   { rewritex }

  {-----------------------------------------------------}
  
  function filesexhausted : boolean;
  
  var
    i : 1..maxfiles;
    result : boolean;
    accept : boolean;
    
  begin
    
    result := true;
    for i := 1 to filesused do
      result := result and eofx(i);
    if one_mo_time then result := result and eofx(mergefile);
    filesexhausted := result
  
  end;  { filesexhausted }
  
  {------------------------------------------------------}
  
  function least : integer;
  
     { returns value which points to least entry in table }
          
  var
    i, j : 1..maxfiles;
    min : stringrec;
    
  begin
    j := 1;
    while (not table[j].hasdata) and (j < filesused) do
                 { skip nonexistent values }
      j := j + 1;
    
    if table[j].hasdata then
      begin
        least := j;
          
        min := table[j].inrec;   { get started }
        
        for i := j + 1 to filesused do
          with table[i] do
            if hasdata then
              begin
                if relation(inrec,min,1) = lessthan then
                  begin
                    least := i;
                    min := inrec
                  end
              end;
        if table[mergefile].hasdata
          then
            with table[mergefile] do
              if relation(inrec,min,1) = lessthan
                then least := mergefile;
      end
      else
        if table[mergefile].hasdata
          then least := mergefile
          else least := 0;  { empty }
    end;        { least }
    
    begin       { merge }
      recswritten := 0;
      badio := false;
      if end_of_infile
        then openoutputfile
        else begin
          rewritex(temp_outfile);
          if IORESULT <> 0 then CHECKIO('abort','',IOERR);
        end;
      ERASE_EOL(40,22);
      if end_of_infile
        then write('STATUS: Merging to output file...')
        else write('STATUS: Merging to workfile ',temp_outfile,'...');
      ERASE_EOL(40,23);
      for i := 1 to maxfiles do
        begin
          table[i].hasdata := false;
          if (i <= filesused) or ((i = mergefile) and (one_mo_time))
            then
              begin
                resetx(i);
                checkio('noabort', mergeinput[i], ioerr);
                badio := badio or ioerr;
                with table[i] do
                  if not ioerr then
                    begin
                      repeat   { ignore null records }
                        readlnx(i, inrec)
                      until (inrec <> '') or eofx(i);
                      if inrec <> '' then
                        begin
                          intread := intread + 1;
                          hasdata := true
                        end;
                    end;
              end;
        end;
      if badio then
        begin
          error := 2;
          exit(psort)  { ****************** }
        end;

      while not filesexhausted do
        begin
          current := least; { point to appropriate
                                        table entry }
          WITH TABLE[CURRENT] DO
            BEGIN
              if end_of_infile
                then
                  begin
                    INREC := CONCAT('  ',INREC,' ');
                    INREC[1] := CHR(16);
                    INREC[2] := CHR(32);
                    INREC[LENGTH(INREC)] := CHR(13);
                    BL_WRITE(INREC,BLOCK_RESULTS);
                  END
                else writelnx(temp_outfile,inrec);
            end;
          recswritten := recswritten + 1;

          with table[current] do
            if not eofx(current) then  { replenish record }
              begin
                repeat
                  readlnx(current, inrec)
                until (inrec <> '') or eofx(current);
                if inrec = '' 
                  then hasdata := false
                  else intread := intread + 1;
              end
            else hasdata := false;
                       { remove from further consideration }
        end;  { while }

    { Empty the table after filesexhausted }

      repeat
        current := least;
        if current > 0 then  { some left }
          with table[current] do
            begin
              if end_of_infile
                then
                  begin
                    INREC := CONCAT('  ',INREC,' ');
                    INREC[1] := CHR(16);
                    INREC[2] := CHR(32);
                    INREC[LENGTH(INREC)] := CHR(13);
                    BL_WRITE(INREC,BLOCK_RESULTS);
                  end
                else writelnx(temp_outfile,inrec);
              recswritten := recswritten + 1;
              hasdata := false
            end  { with }
      until current = 0;  { none left }
      
      if filesused > 0 then
        begin
          ERASE_EOL(40,23);
          write('STATUS: Purging intermediate files...');
          for i := 1 to filesused do closex(i,'p');
          if one_mo_time then closex(mergefile,'p');
        end;
      if not end_of_infile then closex(temp_outfile,'l');
    end;   { merge }
    
  PROCEDURE BL_OPEN; (*VAR BLOCK_FILE  :STR;           File name
                     VAR BLOCK_RETURN:INTEGER);      Return Code  *)
                  
  BEGIN
  {$I-}
    BLOCK_RETURN := -1;
    REWRITE(OUTPUT_FILE,BLOCK_FILE);
    IF IORESULT = 0
      THEN
        BEGIN
          ARRAY_INDEX := 0;
          BLOCK_NUMBER := 0;
          FILLCHAR(BLOCK_ARRAY[0],SIZEOF(BLOCK_ARRAY),CHR(0));
          BLOCKS_WROTE := BLOCK_WRITE(OUTPUT_FILE,BLOCK_ARRAY,2,
            BLOCK_NUMBER);
          IF BLOCKS_WROTE = 2
            THEN 
              BEGIN
                BLOCK_RETURN := 0;
                BLOCK_NUMBER := BLOCK_NUMBER + 2;
              END;
        END;
   {$I+}
  END;
  
PROCEDURE BL_WRITE; (* VAR BLOCK_RECORD:STRINGREC;     String to write
                       VAR BLOCK_RETURN:INTEGER);      Return Code     *)
                  
  BEGIN
    
    BLOCK_RETURN := 1;
    
    IF (ARRAY_INDEX + LENGTH(BLOCK_RECORD)) > 1023
      THEN
        BEGIN
          BLOCKS_WROTE := BLOCK_WRITE(OUTPUT_FILE,BLOCK_ARRAY,2,
            BLOCK_NUMBER);
          IF BLOCKS_WROTE = 2
            THEN
              BEGIN
                BLOCK_RETURN := 0;
                BLOCK_NUMBER := BLOCK_NUMBER + 2;
              END;

          ARRAY_INDEX := 0;
          FILLCHAR(BLOCK_ARRAY[0],SIZEOF(BLOCK_ARRAY),CHR(0));
          MOVELEFT(BLOCK_RECORD[1],BLOCK_ARRAY[ARRAY_INDEX],
            LENGTH(BLOCK_RECORD));
          ARRAY_INDEX := LENGTH(BLOCK_RECORD);
        END
      ELSE
        BEGIN
          MOVELEFT(BLOCK_RECORD[1],BLOCK_ARRAY[ARRAY_INDEX],
            LENGTH(BLOCK_RECORD));
          ARRAY_INDEX := ARRAY_INDEX + LENGTH(BLOCK_RECORD);
          BLOCK_RETURN := 0;
        END;
  END;

PROCEDURE BL_CLOSE; (* VAR BLOCK_RETURN:INTEGER);      Return Code     *)
                  
  BEGIN
        
    BLOCK_RETURN := -1;
    
    BLOCKS_WROTE := BLOCK_WRITE(OUTPUT_FILE,BLOCK_ARRAY,2,
      BLOCK_NUMBER);
    IF BLOCKS_WROTE = 2
      THEN
        BEGIN
          BLOCK_RETURN := 0;
          CLOSE(OUTPUT_FILE,LOCK);
        END;

  (*$I+*)
  END;

  {----------------------------------------------------}
  
  procedure checkio{(str1, str2 : str; var ioerr : boolean)};
  
  var
    iores : integer;
    
  begin
    iores := ioresult;
    if iores > 0 then
      begin
        if (iores = 9) or (iores = 10) then
          BEGIN
            ERASE_EOL(40,23);
            write(bell,'ERROR: Can''t find file: ',str2);
          END
        else if iores = 8 then
          BEGIN
            ERASE_EOL(40,23);
            write(bell,'ERROR: No room on disk');
          END
        else
          BEGIN
            ERASE_EOL(30,23);
            write(bell,'ERROR: I/O error (',iores, ') for file: ',str2);
          END;
        if str1 = 'abort' then 
          begin
            error := 2;
            exit(psort) { ********** }
          end
        else ioerr := true
      end
    else
      ioerr := false
  end;   { checkio }
  
  {------------------------------------------------------}
  
  procedure openoutputfile;
  
  var
    i, iores : integer;
    ch : char;
    volname : string[15];
    
  begin
    repeat
      BL_OPEN(OFILENAME,BLOCK_RESULTS);
      iores := ioresult;
      if iores = 9 then   { vol. not on line }
        begin
          i := pos(':', ofilename);
          if i > 0 then
            volname := copy(ofilename, 1,i)
          else
            volname := 'default prefix';
          ERASE_EOL(30,23);
          write(bell,'ACTION: Put in disk ', volname,
                     ', type <space>');
          read(ch);
          ERASE_EOL(30,23);
          if ch = chr(27) {ESC} then
            begin
              error := 2;
              exit(psort)   { *************************** }
            end;
        end;
    until IORES <> 9;
    if IORES <> 0 then
      begin
        ERASE_EOL(30,23);
        write(bell,'ERROR: Open error (',iores,') for: ',
        ofilename);
        error := 2;
        exit(psort)  {***************************}
      end
  end;   { openoutputfile }
  
  {----------------------------------------------------}
  
  procedure getfield{(fieldnum:integer; source:stringrec;
                  var thefield:key)};

  var
    numch,
    numdelim,
    slength,
    finposn,
    startposn,
    varkeylen : integer;
    ch : char;
  
  begin
      if keytype = fixed then
        thefield := copy(source,
         fielddata[fieldnumber].keystart,
         fielddata[fieldnumber].keylen)
      else
        begin
          slength :=length(source);
          numdelim := 0;
          finposn := 0;
          numch := 0;
          
          repeat
            numch := numch + 1;
            ch := source [numch];
            if ch = keydelim then
              begin
                startposn :=finposn;
                finposn := numch;
                numdelim := numdelim + 1;
              end;
          until (numdelim = fieldnum) or (numch = slength);
          
          if (numch = slength) and (numdelim <> fieldnum) then
            if numdelim < fieldnum - 1 then
              begin
                ERASE_EOL(30,23);
                write(bell,
                      'ERROR: Insufficient key delimiters in: ');
                write(source);
                error := 3;
                exit(psort);  { ************************ }
              end
            else
              begin
                startposn := finposn;
                finposn := numch + 1;
              end;
            varkeylen := finposn - startposn - 1;
            if varkeylen > maxkeylen then
              varkeylen := maxkeylen;
            thefield := copy(source, startposn + 1, varkeylen)
        end
  end;  { getfield }
  
  {-----------------------------------------------------}
  
  function relation{(item1, item2 : stringrec;
                     stkey : integer) : comparison};
  
  var
    i : integer;
    key1, key2 : key;
    getresult : boolean;
    
  
  begin
    i := stkey;   { start at appropriate key }
    getresult := false;
      while (i <= numkeys) and (not getresult) do
        begin
          getfield(keydata[i].fieldnum, item1, key1);
          getfield(keydata[i].fieldnum, item2, key2);
          if key1 > key2 then
            begin
              if keydata[i].keydirection = ascending
                then
                  relation := greaterthan
              else
                relation := lessthan;
              getresult := true
            end
          else
            begin
              if key1 < key2 then
                begin
                  if keydata[i].keydirection = ascending then
                    relation := lessthan
                  else
                    relation := greaterthan;
                  getresult := true
                end
              else  { equal }
                i := i + 1  { next key }
            end
        end;
        
    if not getresult then relation := equal
    
  end;  { relation }
  
  {-----------------------------------------------------}
  
  begin   { psort }
    error := 0;
    bell := chr(7);
    memorycontained := false;
    toomanyfiles := false;
    filesused := 0;
    one_mo_time := false;
    temp_outfile := maxfiles;
    end_of_infile := false;
    recsread := 0;  recswritten := 0; 
    intread := 0;
    paramname := concat(paramname, '.TEXT');
    getparm(paramname);
    (*$I-*) { turn I/O checking off }
    reset(infile, ifilename);
    checkio('abort', ifilename, ioerr);
    (*$I+*)
    while not end_of_infile do
      begin
        mergefile := temp_outfile;
        if temp_outfile = maxfiles-1
          then temp_outfile := maxfiles
          else temp_outfile := maxfiles-1;
        distribute;
        if end_of_infile
          then
            begin
              ERASE_EOL(40,22);
              write('STATUS: Records read: ', recsread);
            end;
        if (filesused <> 0) or (one_mo_time) then merge;
        if not end_of_infile then one_mo_time := true
        else BL_CLOSE(BLOCK_RESULTS);
      end;
  end;   { psort }


begin  { main program }
    ERROR := 0;  ACCESS_FLAG := false;
    ACCESS_DATA_BASE(ACCESS_FLAG);
    if ACCESS_FLAG then PSORT('TEMPSORT',ERROR,RECSREAD,RECSWRIT);
    if ERROR <> 0
      then
        begin
          ERASE_EOL(0,MAX_ROW-1);
          gotoxy(0,MAX_ROW);
          write(ALARM_BELL,'Press SPACE to continue: ');
          read(KEYBOARD,CH);
          exit(UDE_SORT);
        end;
end.   { main program }


========================================================================================
DOCUMENT :usus Folder:VOL25:ud.ude.text
========================================================================================

 PROGRAM UDE;
{$l#5:ud.udelst.text}
USES {$U COMMANDIO.CODE} COMMANDIO;

CONST
  CLEAR_SCREEN = 12;
  ESC_KEY = 27;
  
VAR
  CH   : CHAR;
  LINE : STRING;
  I    : INTEGER;

BEGIN
  WRITE(CHR(CLEAR_SCREEN));
  GOTOXY(26,0);
  WRITE('UNIVERSAL DATA ENTRY');
  GOTOXY(26,1);
  WRITE('====================');
  GOTOXY(26,2);
  WRITE('Version IV.0');
  LINE := 'Define a UDE data file';
  FOR I := 2 TO LENGTH(LINE) DO
    LINE[I] := CHR(ORD(LINE[I])+128);
  GOTOXY(20,8);
  WRITE(LINE);
  LINE := 'Maintain a UDE data file';
  FOR I := 2 TO LENGTH(LINE) DO
    LINE[I] := CHR(ORD(LINE[I])+128);
  GOTOXY(20,10);
  WRITE(LINE);
  LINE := 'Sort a UDE data file';
  FOR I := 2 TO LENGTH(LINE) DO
    LINE[I] := CHR(ORD(LINE[I])+128);
  GOTOXY(20,12);
  WRITE(LINE);
  LINE := 'List a UDE data file';
  FOR I := 2 TO LENGTH(LINE) DO
    LINE[I] := CHR(ORD(LINE[I])+128);
  GOTOXY(20,14);
  WRITE(LINE);
  LINE := 'Copy a UDE or GENLIST data file';
  FOR I := 2 TO LENGTH(LINE) DO
    LINE[I] := CHR(ORD(LINE[I])+128);
  GOTOXY(20,16);
  WRITE(LINE);
  GOTOXY(0,23);
  WRITE('Enter selection or <ESC> :');
  REPEAT
    GOTOXY(27,23);
    READ(CH);
    IF CH = CHR(ESC_KEY) THEN EXIT(PROGRAM);
    CASE CH OF
      'D','d' : CHAIN('#4:SD/DEFINE');
      'M','m' : CHAIN('#4:UD/MAINT');
      'S','s' : CHAIN('#4:UD/SORT');
      'C','c' : CHAIN('#4:UD/COPY');
      'L','l' : CHAIN('#4:UD/LIST');
    END;
  UNTIL CH IN ['D','d','M','m','S','s','C','c','L','l'];
  GOTOXY(40,23);
  WRITE('One Moment Please');
  CHAIN('#4:UD/UDE');
END.




========================================================================================
DOCUMENT :usus Folder:VOL25:ud.udelst.text
========================================================================================



Pascal Compiler IV.0 C1a-4                                                            Page   1 
16 November 1981

    2   2    1:d    1  {$l#5:ud.udelst.text}
    3   2    1:d    1  
    4   2    1:d    1  type bigstring=string[255];
    5   2    1:d    1  var havechain,inredirect,outredirect,monitoropen,inmonitor:boolean;
    6   2    1:d    6    function redirect(command:bigstring):boolean;
    7   2    1:d    1    procedure exception(stopchaining:boolean);
    8   2    1:d    1    procedure chain(command:bigstring);
    9   2    1:d    1    
   10   2    1:d    1    procedure initcommand;
   11   2    1:d    1    procedure startmonitor;
   12   2    1:d    1    procedure stopmonitor(saveit:boolean);
   13   2    1:d    1    procedure getchainline(var command:bigstring);
   14   2    1:d    1    
   15   2    1:d    1  USES {$U COMMANDIO.CODE} COMMANDIO;
   16   2    1:d    1  
   17   2    1:d    1  CONST
   18   2    1:d    1    CLEAR_SCREEN = 12;
   19   2    1:d    1    ESC_KEY = 27;
   20   2    1:d    1    
   21   2    1:d    1  VAR
   22   2    1:d    1    CH   : CHAR;
   23   2    1:d    2    LINE : STRING;
   24   2    1:d   43    I    : INTEGER;
   25   2    1:d   44  
   26   2    1:0    0  BEGIN
   27   2    1:1    0    WRITE(CHR(CLEAR_SCREEN));
   28   2    1:1    9    GOTOXY(26,0);
   29   2    1:1   13    WRITE('UNIVERSAL DATA ENTRY');
   30   2    1:1   26    GOTOXY(26,1);
   31   2    1:1   30    WRITE('====================');
   32   2    1:1   43    GOTOXY(26,2);
   33   2    1:1   47    WRITE('Version IV.0');
   34   2    1:1   60    LINE := 'Define a UDE data file';
   35   2    1:1   68    FOR I := 2 TO LENGTH(LINE) DO
   36   2    1:2   84      LINE[I] := CHR(ORD(LINE[I])+128);
   37   2    1:1  106    GOTOXY(20,8);
   38   2    1:1  110    WRITE(LINE);
   39   2    1:1  121    LINE := 'Maintain a UDE data file';
   40   2    1:1  129    FOR I := 2 TO LENGTH(LINE) DO
   41   2    1:2  145      LINE[I] := CHR(ORD(LINE[I])+128);
   42   2    1:1  167    GOTOXY(20,10);
   43   2    1:1  171    WRITE(LINE);
   44   2    1:1  182    LINE := 'Sort a UDE data file';
   45   2    1:1  190    FOR I := 2 TO LENGTH(LINE) DO
   46   2    1:2  206      LINE[I] := CHR(ORD(LINE[I])+128);
   47   2    1:1  228    GOTOXY(20,12);
   48   2    1:1  232    WRITE(LINE);
   49   2    1:1  243    LINE := 'List a UDE data file';
   50   2    1:1  251    FOR I := 2 TO LENGTH(LINE) DO
   51   2    1:2  267      LINE[I] := CHR(ORD(LINE[I])+128);
   52   2    1:1  289    GOTOXY(20,14);
   53   2    1:1  293    WRITE(LINE);
   54   2    1:1  304    LINE := 'Copy a UDE or GENLIST data file';
   55   2    1:1  312    FOR I := 2 TO LENGTH(LINE) DO
   56   2    1:2  328      LINE[I] := CHR(ORD(LINE[I])+128);
   57   2    1:1  350    GOTOXY(20,16);
   58   2    1:1  354    WRITE(LINE);


Pascal Compiler IV.0 C1a-4                                                            Page   2 
16 November 1981

   59   2    1:1  365    GOTOXY(0,23);
   60   2    1:1  369    WRITE('Enter selection or <ESC> :');
   61   2    1:1  382    REPEAT
   62   2    1:2  382      GOTOXY(27,23);
   63   2    1:2  386      READ(CH);
   64   2    1:2  395      IF CH = CHR(ESC_KEY) THEN EXIT(PROGRAM);
   65   2    1:2  404      CASE CH OF
   66   2    1:2  407        'D','d' : CHAIN('#4:SD/DEFINE');
   67   2    1:2  416        'M','m' : CHAIN('#4:UD/MAINT');
   68   2    1:2  425        'S','s' : CHAIN('#4:UD/SORT');
   69   2    1:2  434        'C','c' : CHAIN('#4:UD/COPY');
   70   2    1:2  443        'L','l' : CHAIN('#4:UD/LIST');
   71   2    1:2  452      END;
   72   2    1:1  455    UNTIL CH IN ['D','d','M','m','S','s','C','c','L','l'];
   73   2    1:1  465    GOTOXY(40,23);
   74   2    1:1  470    WRITE('One Moment Please');
   75   2    1:1  483    CHAIN('#4:UD/UDE');
   76   2     :0    0  END.

End of Compilation.

========================================================================================
DOCUMENT :usus Folder:VOL25:vol25.doc.text
========================================================================================

                                 USUS Volume 25
                          Universal Data Entry Sources
                  (Documentation and Code files on Volume 26)

VOL25:
UD.UDE.TEXT        6 A program package to allow the generation, and
UD.COPY.TEXT      92  maintainance of data input screens and data files
UD.LIST.TEXT      84 
UD.MAINT.TEXT     70 
UD.SORT.TEXT      70 
UD.UDELST.TEXT    10 
SD.DEFINE.TEXT    56 
SH.CALC.TEXT      10 
SH.DISPLAY.TEXT    8 
SH.FIELD.TEXT     14 
SH.INIT.TEXT       8 
SH.SAVE.TEXT       6 
SH.SCREEN.TEXT    30 
README.1ST.TEXT    8 Read this file first!!!
VOL25.DOC.TEXT     4 You're reading it
---------------------------------------------------------------------------
Please transfer the text below to a disk label if you copy this volume.

    USUS Volume 25 -***- USUS Software Library
                         
   For not-for-profit use by USUS members only.
  May be used and distributed only according to 
      stated policy and the author's wishes.



This volume was assembled by George Schreyer from material collected by
the Library committee.
__________________________________________________________________________




========================================================================================
DOCUMENT :usus Folder:VOL26:readme.1st.text
========================================================================================

Some notes from the reviewer:

     I have made UDE marginally work.  I am not really very impressed
with the entire package, but it shows some interesting programming constructs
and is very possibly useful to somebody.  The documentation, although extensive
is unclear and hard to follow.  The example given in the last part of the
documentation has some errors, but after a couple of hours of playing around,
you too will figure it out.  

     The program requires that the code files reside on #4:.  You can easily
change this in UD.UDE.TEXT.  The program has the built in and annoying
tendency to chain back to itself, so you may find that it restarts when you
don't want it to.  Simply remove the last call to CHAIN in UD.UDE.TEXT and re-
compile it.

     There is some rather clever code in SH.INIT.TEXT to to obtain the
cursor control characters for the user's terminal.  Unfortunatly, it don't
work.  If your terminal uses two character control sequences for the arrow keys
you will have to go in and hard wire stuff.  The function SC_MAP_CRT_COMMAND
is kind of odd and can't really be used in the way shown with two character
sequences.  

     SC_MAP_CRT_COMMAND (in screenops) expects you to read characters from
the terminal and pass all of them through it.  If your terminal has two
character control sequences, some of the characters that you read will
be the prefix characters.  When SC_MAP_CRT_COMMAND is passed a prefix
character, IT GOES OUT AND READS THE TERMINAL, EXPECTING TO FIND ANOTHER
CHARACTER!!  If the next character is one of the ones for the special keys,
it will return the enumerated type of the special key and the value of the
character that it read.  This means that the method used in UDE hangs
whenever this procedure is called.  UNLESS THE CORRECT CHARACTERS ARE TYPED IN
THE CORRECT ORDER the program will not be able to determine the values of the 
arrow keys.  With one character command sequences, the method should work fine.

     The author has also done something which will cause a lot of users, 
especially those with APC's and PC's a lot of grief.  Most of the prompt 
lines are written to the screen with the 8th bit set.  This is probably
some special video attribute for his terminal, but many terminals use
the characters between 128 and 255 as graphics characters.  This means the
much of the prompting information will be displayed as graphic garbage.
This stuff is scattered throughout the program, and I didn't want to change
it.  If it causes you problems, you will have to go in and delete the
< +128 > expressions.

     Good luck  george w. schreyer

     p.s.  The submittor has requested that any changes, bug fixes, or
upgrades be submitted back to him.  If you improve on this program, other
than the items mentioned above, please contact me so that we can send
the upgrades back to him.

========================================================================================
DOCUMENT :usus Folder:VOL26:sd_define.code
========================================================================================

< binary file -- not listed >

========================================================================================
DOCUMENT :usus Folder:VOL26:sh.screen.code
========================================================================================

 { Screen handler compilation unit version II.2.B.40 }
 
 
 { THIS VERSION FOR UCSD PASCAL VERSION IV.0 }
 
 
 const END_SCREEN    = 9999;      { Signals end of a screen file }
&MAX_FLEN      = 40;        { Maximum length of prompt or data field }
&LEN_ID        = 8;         { Maximum length of an ID Name }
&SCREEN_FIELDS = 40;        { Maximum number of screen fields }
&PROMPT_FIELDS = 40;        { Maximum number of prompt fields }
!
 type STRINGFL = STRING[MAX_FLEN];
%STR_ID = STRING[LEN_ID];
%FIELD_DEFS = Packed Record
)S_ID : STR_ID;
)S_ROW,S_COL,S_LEN,S_MIN: Integer;
)S_TYP,S_JUS,S_NA : Char;
)S_SKIP: Boolean;
)S_DEF,S_FLD: STRINGFL;
'end;
%PROMPT_DEFS = Packed Record
)P_ROW,P_COL : Integer;
)P_FLD : STRINGFL;
'end;
%SCREEN_ARR = Packed Array[1..SCREEN_FIELDS] of FIELD_DEFS;
%PROMPT_ARR = Packed Array[1..PROMPT_FIELDS] of PROMPT_DEFS;
%SCREEN_REC = Packed record case TAG: Boolean of
5False : (S:FIELD_DEFS);
                                                                    5True  : (P:Packed array[1..2] of PROMPT_DEFS)
3end;
%T_THE_DATE = Packed Record
'month    : 0..12 ;
'day      : 0..31 ;
'year     : 0..99 ;
'end ;
 
 var 
"ALARM_BELL   : Char;
"CURSOR_DOWN  : Char;
"CURSOR_LEFT  : Char;
"CURSOR_RIGHT : Char;
"CURSOR_UP    : Char;
"DEL_KEY      : Char;
"ENTER_KEY    : Char;
"ERASE_FIELD  : Char;
"ERASE_INPUT  : Char;
"ESC_KEY      : Char;
"FORM_FEED    : Char;
"INS_KEY      : Char;
"LINE_KEY     : Char;
"RETURN_KEY   : Char;
"TAB_LEFT     : Char;
"TAB_RIGHT    : Char;
"TAB_SKIP     : Char;
"ULINE        : Char;
"
"FILE_TO_GET  : File of SCREEN_REC;
"MAX_ROW      : Integer;
"MAX_COL      : Integer;
"THE_DATE     : T_THE_DATE ;
"UNDERLINE    : STRINGFL;
$
&
&
 Function FIND(FIELD_ID: STR_ID;                     { Field ID to find }
.var FIND_SCREEN: SCREEN_ARR           { Screen array to search }
.): Integer;                           { Zero returned if field
Wnot found }
 
 Procedure EATSPL(var F_FLD: String);  { String to shorten }
  
 Procedure EATSPR(var F_FLD: String);  { String to shorten }
 
 Procedure FIELD(    F_ROW :Integer;   { Field row }
0var F_COL :Integer;   { Field column }
4F_E_ROW,          { Field error row }
4F_E_COL,          { Field error column }
4F_LEN,            { Field length }
4F_MIN :Integer;   { Minimum field length }
0var F_EXIT:Char;      { Exit character }
4F_JUS,            { Justify, L)eft, R)ight or N)one }
4F_AN: Char;       { L)etter, N)umeric, A)lpha, S)pecial }
0var F_FLD:STRINGFL;   { Input and output string }
4F_SKIP:Boolean);  { Exit at end of field flag }
0
 Procedure GET_FILE(    GET_NAME: String;          { File name to get }
3var GET_SCREEN: SCREEN_ARR;    { Screen to load }
3var GET_PROMPTS: PROMPT_ARR;   { Prompts to load }
3var GET_RESULT: Integer);      { IO return code }
 
 Procedure SAVE_FILE(    SAVE_NAME: String;          { File name to save }
4var SAVE_SCREEN: SCREEN_ARR;    { Screen to save }
4var SAVE_PROMPTS: PROMPT_ARR;   { Prompts to save }
                4var SAVE_RESULT: Integer);      { IO return code }
 
 Procedure SCREEN(var RUNING_SCREEN: SCREEN_ARR;{ Screen to run }
5WRAP: Boolean;            { Wrapping option On or Off }
5START_FIELD,              { Field to position cursor }
5ROW_OFFSET,               { Row offset }
5COL_OFFSET,               { Column offset }
5START_ROW,                { Starting data field row }
5END_ROW,                  { Ending data field row }
5ERROR_ROW,                { Error row }
5ERROR_COL: Integer;       { Error column }
1var F_EXIT: Char);            { Key pressed to exit }
 
 Procedure DISPLAY_SCREEN(var SHOW_SCREEN: SCREEN_ARR;  { Screen to display }
9ROW_OFFSET,               { Row offset }
9COL_OFFSET,               { Column offset }
9START_ROW,                { Starting data field row }
9END_ROW: Integer);        { Ending data field row }
 
 Procedure DISPLAY_PROMPTS(var P_ARRAY: PROMPT_ARR;     { Prompts to display }
:ROW_OFFSET,              { Row offset }
                                      :COL_OFFSET,              { Column offset }
:START_ROW,               { Starting prompt row }
:END_ROW: Integer);       { Ending prompt row }
 
 Procedure ERASE_SCREEN(var E_SCREEN: SCREEN_ARR;    { Screen to erase }
;ROW_OFFSET,          { Row offset }
;COL_OFFSET,          { Column offset }
;START_ROW,           { First data field row to erase}
;END_ROW: Integer);   { Last data field row to erase }
 
 Procedure ERASE_PROMPTS(var P_ARRAY: PROMPT_ARR;   { Prompts to erase }
<ROW_OFFSET,            { Row offset }
<COL_OFFSET,            { Column offset }
<START_ROW,             { First prompt row to erase }
; END_ROW: Integer);     { Last prompt row to erase }
 
 Procedure CLEAR_HOME ;
 Procedure ERASE_EOL( X:integer ; Y:integer ) ;
 Procedure ERASE_EOS( X:integer ; Y:integer ) ;
 Procedure HOME ;
 
 
 IMPLEMENTATION                                                                                                                                                                               z  SAVEPHIL  w       *a.Pa  t+ pć+x շ  tpuph (Z, (y'(hB ʅ, (  h, (  huph (9- (5'(h   ʅ- (5 5 huptp/                                                                                                                                                                                                                                                                                  GETPHILE       L -d1Pd t. pć.x 
 t p tu. p i h uծ  p . pĆ t p b (	. p h/ ( / (q h/ ( / (q"!(	. p!i0!(5 5u. pċI!(kj"#0"(5'"j (kj"#/"('"j t2                                                                                                                                                                                 SCREEN40       ) )`-P`,+*v.  ? )`-P`,+*s.   agh 
& (5'(a& (5   
 p ( p hȖ	        p 지  짅 w p Ӗ        p#   지    짅	   w p ͖   uu v	v(LN3 (wxPw`w` (SR  (w, (wxPw`w` (h 지 	ȭއ   #0 	p	 	 		 N	 L	 A	 S4x
	 	p%	ȭ$#3	o"!
0 	p up "Sh <( up09 up!G upU upր_( gtgȇ lx
 upx
n m$x$

x$
	u	p up=	&
 n(u(2$ $lm (3$퇀$lm (5($w 

(w
g)w
 ( (;'
 w
 (g($w"j\(⼅6>ۅ?481=m((9(ć}( p(7x ( l$"$j"jx
 (wxPw
"w
 up%p h
i!)!짅 h!i /n
0 	p~ up up n& L5 (wxPw
w
 (SR g(w. (wxPw
w
 (x

w
 up
l$)$짅$ $l䇀
w
 ((Ė  (ki!#O!(5l$'	 p-$ u$ڡ$ vڡ$$
$ $$  $   $
 ɀCs$ 지[$ $  지]Q $ e$  we +$ $ e$  we(5 (	$$  (	$$  ($ $(wxPwe$~we ($ mh %$ 지 $  h$ up!i  (ih !R' (j"y& u"y$#ڡ"x% vڡ"x%"y&
" up"y'
 p hb (ji!"d)!(5k#( u#&%ڡ#' vڡ(#'#(
#~lh $  	p h
#' p!i
 (ji!"c)!(k#y( u#y&%ڡ#x' vڡ*#x'#y(
# lh $  	p h#y' p!i
 	c  !$!x(5#x&!x($!x(5' p!!xĊ !x$ x(5"x& x($ x(5' p  xĊ x  xĊ p 

 %*x& &x%x)xՋ +%x(5k#
 ɀCn i# lh $# 짅
#  Ȋ!i h!#}:&(x'x
0 	p up#} up up& %%xċi%%xĖ 
V  !!x !x!ĭ'!x!ĭ'(!x(5
 ɀCӾ "%uu%"#% %#(#"ed%&%&&h o n( (5	($i(
 ɀCċ (( (  (
 ɀCI( 지[(  +(( ( 
(  w
((5 (	((  ((%a! (~(}(	(	 ((
ɑ' !x3?`Ex>2`0x1@( (5	(j(k` %j( (5"( (5#֋ x4C( (5	(j(k` $uj( (5"( (5#Ӌ x=)( (5j` % j( (5"rx8?%$	h ($( (5
)
 ɀC	)( hׇ(%$#"	&h-x%h!x6nx9 p
0 	p&(ed !g`' (   rr
   ! r  ! r
  r   ?6t     
 	  ͥͲM r3/(!
	ր r͆w) :΅ ɥvɥu


	vOuߥ_x (Ȇx(p t         h     `       h     ERROR:         P  Alphanumeric character required..Alphabetic letter required.Numeric character required.Illegal character.. A S                                     ERROR: Minimun input is  ERROR: Minimum input is  
 Character(s)         
    	m  }zupk3-   ` F "~ ***      GOTOXY  
 EXTRAIO 	 STRINGOP PASCALIO FILEOPS  SCREENOP                                        {    N : ] "' % '                            SCREEN40SAVEPHILGETPHILEUDESORT ACCESSDAPSORT   GETPARM DISTRIBUMERGE                                                                                                        
               (  
SCREEN40SCREEN40  2   UDESORT UDESORT UDESORT UDESORT UDESORT                                                                         .(c)Copyright 1982 Texas Instruments Inc. - ctw                                
========================================================================================
DOCUMENT :usus Folder:VOL26:sh_screen.unit
========================================================================================

 
  {                                                      SCREEN40SAVEPHILGETPHILE                                                                                                                                                                  (  
SCREEN40SCREEN40                                                                                                                               h     IV0     B\      BR MM= r MM   5B 
 { Screen handler compilation unit version II.2.B.40 }
 
 
 { THIS VERSION FOR UCSD PASCAL VERSION IV.0 }
 
 
 const END_SCREEN    = 9999;      { Signals end of a screen file }
&MAX_FLEN      = 40;        { Maximum length of prompt or data field }
&LEN_ID        = 8;         { Maximum length of an ID Name }
&SCREEN_FIELDS = 40;        { Maximum number of screen fields }
&PROMPT_FIELDS = 40;        { Maximum number of prompt fields }
!
 type STRINGFL = STRING[MAX_FLEN];
%STR_ID = STRING[LEN_ID];
%FIELD_DEFS = Packed Record
)S_ID : STR_ID;
)S_ROW,S_COL,S_LEN,S_MIN: Integer;
)S_TYP,S_JUS,S_NA : Char;
)S_SKIP: Boolean;
)S_DEF,S_FLD: STRINGFL;
'end;
%PROMPT_DEFS = Packed Record
)P_ROW,P_COL : Integer;
)P_FLD : STRINGFL;
'end;
%SCREEN_ARR = Packed Array[1..SCREEN_FIELDS] of FIELD_DEFS;
%PROMPT_ARR = Packed Array[1..PROMPT_FIELDS] of PROMPT_DEFS;
%SCREEN_REC = Packed record case TAG: Boolean of
5False : (S:FIELD_DEFS);
                                                                    5True  : (P:Packed array[1..2] of PROMPT_DEFS)
3end;
%T_THE_DATE = Packed Record
'month    : 0..12 ;
'day      : 0..31 ;
'year     : 0..99 ;
'end ;
 
 var 
"ALARM_BELL   : Char;
"CURSOR_DOWN  : Char;
"CURSOR_LEFT  : Char;
"CURSOR_RIGHT : Char;
"CURSOR_UP    : Char;
"DEL_KEY      : Char;
"ENTER_KEY    : Char;
"ERASE_FIELD  : Char;
"ERASE_INPUT  : Char;
"ESC_KEY      : Char;
"FORM_FEED    : Char;
"INS_KEY      : Char;
"LINE_KEY     : Char;
"RETURN_KEY   : Char;
"TAB_LEFT     : Char;
"TAB_RIGHT    : Char;
"TAB_SKIP     : Char;
"ULINE        : Char;
"
"FILE_TO_GET  : File of SCREEN_REC;
"MAX_ROW      : Integer;
"MAX_COL      : Integer;
"THE_DATE     : T_THE_DATE ;
"UNDERLINE    : STRINGFL;
$
&
&
 Function FIND(FIELD_ID: STR_ID;                     { Field ID to find }
.var FIND_SCREEN: SCREEN_ARR           { Screen array to search }
.): Integer;                           { Zero returned if field
Wnot found }
 
 Procedure EATSPL(var F_FLD: String);  { String to shorten }
  
 Procedure EATSPR(var F_FLD: String);  { String to shorten }
 
 Procedure FIELD(    F_ROW :Integer;   { Field row }
0var F_COL :Integer;   { Field column }
4F_E_ROW,          { Field error row }
4F_E_COL,          { Field error column }
4F_LEN,            { Field length }
4F_MIN :Integer;   { Minimum field length }
0var F_EXIT:Char;      { Exit character }
4F_JUS,            { Justify, L)eft, R)ight or N)one }
4F_AN: Char;       { L)etter, N)umeric, A)lpha, S)pecial }
0var F_FLD:STRINGFL;   { Input and output string }
4F_SKIP:Boolean);  { Exit at end of field flag }
0
 Procedure GET_FILE(    GET_NAME: String;          { File name to get }
3var GET_SCREEN: SCREEN_ARR;    { Screen to load }
3var GET_PROMPTS: PROMPT_ARR;   { Prompts to load }
3var GET_RESULT: Integer);      { IO return code }
 
 Procedure SAVE_FILE(    SAVE_NAME: String;          { File name to save }
4var SAVE_SCREEN: SCREEN_ARR;    { Screen to save }
4var SAVE_PROMPTS: PROMPT_ARR;   { Prompts to save }
                4var SAVE_RESULT: Integer);      { IO return code }
 
 Procedure SCREEN(var RUNING_SCREEN: SCREEN_ARR;{ Screen to run }
5WRAP: Boolean;            { Wrapping option On or Off }
5START_FIELD,              { Field to position cursor }
5ROW_OFFSET,               { Row offset }
5COL_OFFSET,               { Column offset }
5START_ROW,                { Starting data field row }
5END_ROW,                  { Ending data field row }
5ERROR_ROW,                { Error row }
5ERROR_COL: Integer;       { Error column }
1var F_EXIT: Char);            { Key pressed to exit }
 
 Procedure DISPLAY_SCREEN(var SHOW_SCREEN: SCREEN_ARR;  { Screen to display }
9ROW_OFFSET,               { Row offset }
9COL_OFFSET,               { Column offset }
9START_ROW,                { Starting data field row }
9END_ROW: Integer);        { Ending data field row }
 
 Procedure DISPLAY_PROMPTS(var P_ARRAY: PROMPT_ARR;     { Prompts to display }
:ROW_OFFSET,              { Row offset }
                                      :COL_OFFSET,              { Column offset }
:START_ROW,               { Starting prompt row }
:END_ROW: Integer);       { Ending prompt row }
 
 Procedure ERASE_SCREEN(var E_SCREEN: SCREEN_ARR;    { Screen to erase }
;ROW_OFFSET,          { Row offset }
;COL_OFFSET,          { Column offset }
;START_ROW,           { First data field row to erase}
;END_ROW: Integer);   { Last data field row to erase }
 
 Procedure ERASE_PROMPTS(var P_ARRAY: PROMPT_ARR;   { Prompts to erase }
<ROW_OFFSET,            { Row offset }
<COL_OFFSET,            { Column offset }
<START_ROW,             { First prompt row to erase }
; END_ROW: Integer);     { Last prompt row to erase }
 
 Procedure CLEAR_HOME ;
 Procedure ERASE_EOL( X:integer ; Y:integer ) ;
 Procedure ERASE_EOS( X:integer ; Y:integer ) ;
 Procedure HOME ;
 
 
 IMPLEMENTATION                                                                                                                                                                               z  SAVEPHIL  w       *a.Pa  t+ pć+x շ  tpuph (Z, (y'(hB ʅ, (  h, (  huph (9- (5'(h   ʅ- (5 5 huptp/                                                                                                                                                                                                                                                                                  GETPHILE       L -d1Pd t. pć.x 
 t p tu. p i h uծ  p . pĆ t p b (	. p h/ ( / (q h/ ( / (q"!(	. p!i0!(5 5u. pċI!(kj"#0"(5'"j (kj"#/"('"j t2                                                                                                                                                                                 SCREEN40       ) )`-P`,+*v.  ? )`-P`,+*s.   agh 
& (5'(a& (5   
 p ( p hȖ	        p 지  짅 w p Ӗ        p#   지    짅	   w p ͖   uu v	v(LN3 (wxPw`w` (SR  (w, (wxPw`w` (h 지 	ȭއ   #0 	p	 	 		 N	 L	 A	 S4x
	 	p%	ȭ$#3	o"!
0 	p up "Sh <( up09 up!G upU upր_( gtgȇ lx
 upx
n m$x$

x$
	u	p up=	&
 n(u(2$ $lm (3$퇀$lm (5($w 

(w
g)w
 ( (;'
 w
 (g($w"j\(⼅6>ۅ?481=m((9(ć}( p(7x ( l$"$j"jx
 (wxPw
"w
 up%p h
i!)!짅 h!i /n
0 	p~ up up n& L5 (wxPw
w
 (SR g(w. (wxPw
w
 (x

w
 up
l$)$짅$ $l䇀
w
 ((Ė  (ki!#O!(5l$'	 p-$ u$ڡ$ vڡ$$
$ $$  $   $
 ɀCs$ 지[$ $  지]Q $ e$  we +$ $ e$  we(5 (	$$  (	$$  ($ $(wxPwe$~we ($ mh %$ 지 $  h$ up!i  (ih !R' (j"y& u"y$#ڡ"x% vڡ"x%"y&
" up"y'
 p hb (ji!"d)!(5k#( u#&%ڡ#' vڡ(#'#(
#~lh $  	p h
#' p!i
 (ji!"c)!(k#y( u#y&%ڡ#x' vڡ*#x'#y(
# lh $  	p h#y' p!i
 	c  !$!x(5#x&!x($!x(5' p!!xĊ !x$ x(5"x& x($ x(5' p  xĊ x  xĊ p 

 %*x& &x%x)xՋ +%x(5k#
 ɀCn i# lh $# 짅
#  Ȋ!i h!#}:&(x'x
0 	p up#} up up& %%xċi%%xĖ 
V  !!x !x!ĭ'!x!ĭ'(!x(5
 ɀCӾ "%uu%"#% %#(#"ed%&%&&h o n( (5	($i(
 ɀCċ (( (  (
 ɀCI( 지[(  +(( ( 
(  w
((5 (	((  ((%a! (~(}(	(	 ((
ɑ' !x3?`Ex>2`0x1@( (5	(j(k` %j( (5"( (5#֋ x4C( (5	(j(k` $uj( (5"( (5#Ӌ x=)( (5j` % j( (5"rx8?%$	h ($( (5
)
 ɀC	)( hׇ(%$#"	&h-x%h!x6nx9 p
0 	p&(ed !g`' (   rr
   ! r  ! r
  r   ?6t     
 	  ͥͲM r3/(!
	ր r͆w) :΅ ɥvɥu


	vOuߥ_x (Ȇx(p t         h     `       h     ERROR:         P  Alphanumeric character required..Alphabetic letter required.Numeric character required.Illegal character.. A S                                     ERROR: Minimun input is  ERROR: Minimum input is  
 Character(s)         
    	m  }zupk3-   ` F "~ ***      GOTOXY  
 EXTRAIO 	 STRINGOP PASCALIO FILEOPS  SCREENOP                                       $CURSOR $EQUAL                                                                                                                                                                                                                                                                                                                                                                            O  . XX                                                                                                
========================================================================================
DOCUMENT :usus Folder:VOL26:ud.intrdoc.text
========================================================================================

[hf=5/he=1]|UNIVERSAL DATA ENTRY|
[he=2]|Introduction|
[he=3]|10/81|
[st=1/tabs=6,9,12,r65/ff=3/hg=3/hm=1,1.0/vm=0.25,0.5]
[hs=8/ce]|7. UNIVERSAL DATA ENTRY|
[ff=3/fo=1]7-@
[hs=10]
7.1 |INTRODUCTION|

7.1.1 |Overview|

	Universal Data Entry (|UDE|) enables users with little training to enter
data into computer files which can later be sorted, printed, or accessed by
other programs for data processing.  It provides prompts at fields in which
data is to be entered, and, if an error is detected, it advises the user.  The
screen prompts are created by the user with the help of the UDE Define
function.

	The UDE system is comprised of five programs: Define, Maintain, Sort, List
and Copy.  Define allows the user to set up the screen and record layout of a
data file.  Maintain collects data and enters it into a file which may be
scanned to change or delete a record.  Sort is used to sort the records by
field.  Up to ten fields may be used as keys, and each field may be sorted in
ascending or descending order.  The user may put the sorted results into a new
file if the data needs to be saved in its original form.  The keys used for
sorting may also be stored for subsequent use.

	List allows the user to list the records in the data file on a line or
letter-quality printer.  The list format is user-defined and allows choosing
the headings and footings which are to appear at the tops and bottoms of pages,
which fields and records are to be printed, and which headings are to appear
above each field.  Format information may be saved for use in printing other
data.  List also allows a user to "export" data file records into a text file
to do custom letter writing or address lists.

	Copy allows the user to copy data from selected fields and records of
either a UDE or GENLIST data file to a UDE data file.

	UDE may also be used in conjunction with other programs which read data
and process it by means of specially-prepared software.  Finally, UDE can
collect data for transmission to other computers for storage or processing.

	UDE can be used for name and address lists, inventory records, appointment
calendars, purchase order records, payroll records, and many other business
problems.

	To use UDE for a particular application, start the program by entering
/UDE from the main system menu or execute UD/UDE.CODE.  Define a data file
using the UDE Define function and specify the information (numbers, dates,
names, addresses, amounts, descriptions, etc.) needed in the data file.  This
process is very similar to designing a manual filing system and takes only a
few minutes to accomplish.

	Having defined a data file format, create the data file and enter
information using the Maintain function.  Once entered, any record can be
examined, changed or deleted.

	Information in the data file can be sorted, printed or copied as
required with the Sort, List and Copy functions.

[cp=18]	UDE for the PCIF system is made up of the following programs:
[in=5]
|UD/UDE.CODE| - Allows the user to choose the UDE function that is to be
performed.

|SD/DEFINE.CODE| - Defines the screen and record layout of a data file.

|UD/MAINT.CODE| - Creates a data file if necessary and maintains records in the
data file with add, examine, delete and modify commands.

|UD/SORT.CODE| - Sorts data file records.  This program requires the
file UD/SORT.SCRN be available on the prefixed disk.

|UD/LIST.CODE| - Lists the active records in the data file.  This program
requires the file UD/LIST.SCRN to be on the prefixed disk.

|UD/COPY.CODE| - Copies all or part of either a UDE or GENLIST data file to a
UDE data file.
[in]
[cp=4]7.1.2 |Screen Data Input|

	A defined UDE data file will appear on the screen as an number of prompts
followed by values.

[cp=10]***********************************************************************

[ce]|UDE Data File
[ce]Example 1

	1st prompt:_value1_          2nd prompt:_value2_
	3rd prompt:_value3_
	4th prompt:_value4_|

***********************************************************************

[cp=4]The underlined information is what the user enters into the data file.
The rest of the information is prompts that the user does not change.  For
instance, a UDE data file could be set up to store customer names, addresses
and telephone numbers.  The prompts on the screen might look like:

[cp=9]************************************************************************

[ce]|Customer Data File

	Name:_                    _   Telephone number:_            _
	Street:_                                  _
	City:_                _  State:_  _  Zip:_       _|

***********************************************************************

[cp=4]	Each piece of information the user enters on the screen is known as a
_field_.  So there is a name field, a telephone number field, and so on.  All
the fields on the screen, when taken together, are known as a _record_.  All
the records are called the _data file_.

[cp=4]	UDE collects all its records by presenting the screen to the user to
be filled in.  There is more information on entering records into UDE in the
Maintain section.  There are also some special keys that are used when entering
data.  These special keys are explained in Appendix D.

[cp=12]7.1.3 |Screen Messages|

	During the operation of UDE the following types of messages may be
displayed in the right half of the last line on the screen.
[in=5]
|STATUS:| Indicates the status of an operation.

|ERROR:| Indicates an error has occurred.

|WARNING:| Indicates the operator is about to perform a dangerous
operation.

|ACTION:| Indicates some action is required by the operator to
continue.
[in]
[cp=5]7.1.4 |Standard Screen Commands|

	Some of the screens displayed by UDE programs have the following standard
commands at the bottom of the screen.  All other commands, unique to a certain
UDE function, will be explained later in the manual.

[cp=4]7.1.4.1 |Execute Screen Functions|

	When the e|X|ecute command is in the lower left of the UDE
screen, press |<X>| to execute the function indicated by the screen display.
[cp=5]
7.1.4.2 |Changing Screen Data Fields|

	When the |C|hange command is in the lower left of the UDE screen, press
|<C>| to change the values in the data fields on the screen.  The cursor will be
put at the beginning of the first field.

[cp=4]7.1.4.3 |Quitting the Current Screen|

	When the |Q|uit command is in the lower left of the UDE screen, press
|<Q>| to exit the current operation.
[tf=#5:UD.SAVEDOC]                  

========================================================================================
DOCUMENT :usus Folder:VOL26:ud.sort.code
========================================================================================

   {    N : ] "' % '                            SCREEN40SAVEPHILGETPHILEUDESORT ACCESSDAPSORT   GETPARM DISTRIBUMERGE                                                                                                        
               (  
SCREEN40SCREEN40  2   UDESORT UDESORT UDESORT UDESORT UDESORT                                                                         .(c)Copyright 1982 Texas Instruments Inc. - ctw                                
 { Screen handler compilation unit version II.2.B.40 }
 
 
 { THIS VERSION FOR UCSD PASCAL VERSION IV.0 }
 
 
 const END_SCREEN    = 9999;      { Signals end of a screen file }
&MAX_FLEN      = 40;        { Maximum length of prompt or data field }
&LEN_ID        = 8;         { Maximum length of an ID Name }
&SCREEN_FIELDS = 40;        { Maximum number of screen fields }
&PROMPT_FIELDS = 40;        { Maximum number of prompt fields }
!
 type STRINGFL = STRING[MAX_FLEN];
%STR_ID = STRING[LEN_ID];
%FIELD_DEFS = Packed Record
)S_ID : STR_ID;
)S_ROW,S_COL,S_LEN,S_MIN: Integer;
)S_TYP,S_JUS,S_NA : Char;
)S_SKIP: Boolean;
)S_DEF,S_FLD: STRINGFL;
'end;
%PROMPT_DEFS = Packed Record
)P_ROW,P_COL : Integer;
)P_FLD : STRINGFL;
'end;
%SCREEN_ARR = Packed Array[1..SCREEN_FIELDS] of FIELD_DEFS;
%PROMPT_ARR = Packed Array[1..PROMPT_FIELDS] of PROMPT_DEFS;
%SCREEN_REC = Packed record case TAG: Boolean of
5False : (S:FIELD_DEFS);
                                                                    5True  : (P:Packed array[1..2] of PROMPT_DEFS)
3end;
%T_THE_DATE = Packed Record
'month    : 0..12 ;
'day      : 0..31 ;
'year     : 0..99 ;
'end ;
 
 var 
"ALARM_BELL   : Char;
"CURSOR_DOWN  : Char;
"CURSOR_LEFT  : Char;
"CURSOR_RIGHT : Char;
"CURSOR_UP    : Char;
"DEL_KEY      : Char;
"ENTER_KEY    : Char;
"ERASE_FIELD  : Char;
"ERASE_INPUT  : Char;
"ESC_KEY      : Char;
"FORM_FEED    : Char;
"INS_KEY      : Char;
"LINE_KEY     : Char;
"RETURN_KEY   : Char;
"TAB_LEFT     : Char;
"TAB_RIGHT    : Char;
"TAB_SKIP     : Char;
"ULINE        : Char;
"
"FILE_TO_GET  : File of SCREEN_REC;
"MAX_ROW      : Integer;
"MAX_COL      : Integer;
"THE_DATE     : T_THE_DATE ;
"UNDERLINE    : STRINGFL;
$
&
&
 Function FIND(FIELD_ID: STR_ID;                     { Field ID to find }
.var FIND_SCREEN: SCREEN_ARR           { Screen array to search }
.): Integer;                           { Zero returned if field
Wnot found }
 
 Procedure EATSPL(var F_FLD: String);  { String to shorten }
  
 Procedure EATSPR(var F_FLD: String);  { String to shorten }
 
 Procedure FIELD(    F_ROW :Integer;   { Field row }
0var F_COL :Integer;   { Field column }
4F_E_ROW,          { Field error row }
4F_E_COL,          { Field error column }
4F_LEN,            { Field length }
4F_MIN :Integer;   { Minimum field length }
0var F_EXIT:Char;      { Exit character }
4F_JUS,            { Justify, L)eft, R)ight or N)one }
4F_AN: Char;       { L)etter, N)umeric, A)lpha, S)pecial }
0var F_FLD:STRINGFL;   { Input and output string }
4F_SKIP:Boolean);  { Exit at end of field flag }
0
 Procedure GET_FILE(    GET_NAME: String;          { File name to get }
3var GET_SCREEN: SCREEN_ARR;    { Screen to load }
3var GET_PROMPTS: PROMPT_ARR;   { Prompts to load }
3var GET_RESULT: Integer);      { IO return code }
 
 Procedure SAVE_FILE(    SAVE_NAME: String;          { File name to save }
4var SAVE_SCREEN: SCREEN_ARR;    { Screen to save }
4var SAVE_PROMPTS: PROMPT_ARR;   { Prompts to save }
                4var SAVE_RESULT: Integer);      { IO return code }
 
 Procedure SCREEN(var RUNING_SCREEN: SCREEN_ARR;{ Screen to run }
5WRAP: Boolean;            { Wrapping option On or Off }
5START_FIELD,              { Field to position cursor }
5ROW_OFFSET,               { Row offset }
5COL_OFFSET,               { Column offset }
5START_ROW,                { Starting data field row }
5END_ROW,                  { Ending data field row }
5ERROR_ROW,                { Error row }
5ERROR_COL: Integer;       { Error column }
1var F_EXIT: Char);            { Key pressed to exit }
 
 Procedure DISPLAY_SCREEN(var SHOW_SCREEN: SCREEN_ARR;  { Screen to display }
9ROW_OFFSET,               { Row offset }
9COL_OFFSET,               { Column offset }
9START_ROW,                { Starting data field row }
9END_ROW: Integer);        { Ending data field row }
 
 Procedure DISPLAY_PROMPTS(var P_ARRAY: PROMPT_ARR;     { Prompts to display }
:ROW_OFFSET,              { Row offset }
                                      :COL_OFFSET,              { Column offset }
:START_ROW,               { Starting prompt row }
:END_ROW: Integer);       { Ending prompt row }
 
 Procedure ERASE_SCREEN(var E_SCREEN: SCREEN_ARR;    { Screen to erase }
;ROW_OFFSET,          { Row offset }
;COL_OFFSET,          { Column offset }
;START_ROW,           { First data field row to erase}
;END_ROW: Integer);   { Last data field row to erase }
 
 Procedure ERASE_PROMPTS(var P_ARRAY: PROMPT_ARR;   { Prompts to erase }
<ROW_OFFSET,            { Row offset }
<COL_OFFSET,            { Column offset }
<START_ROW,             { First prompt row to erase }
; END_ROW: Integer);     { Last prompt row to erase }
 
 Procedure CLEAR_HOME ;
 Procedure ERASE_EOL( X:integer ; Y:integer ) ;
 Procedure ERASE_EOS( X:integer ; Y:integer ) ;
 Procedure HOME ;
 
 
 IMPLEMENTATION                                                                                                                                                                                SCREEN40       ) )`-P`,+*v.  ? )`-P`,+*s.   agh 
& (5'(a& (5   
 p ( p hȖ	        p 지  짅 w p Ӗ        p#   지    짅	   w p ͖   uu v	v(LN3 (wxPw`w` (SR  (w, (wxPw`w` (h 지 	ȭއ   #0 	p	 	 		 N	 L	 A	 S4x
	 	p%	ȭ$#3	o"!
0 	p up "Sh <( up09 up!G upU upր_( gtgȇ lx
 upx
n m$x$

x$
	u	p up=	&
 n(u(2$ $lm (3$퇀$lm (5($w 

(w
g)w
 ( (;'
 w
 (g($w"j\(⼅6>ۅ?481=m((9(ć}( p(7x ( l$"$j"jx
 (wxPw
"w
 up%p h
i!)!짅 h!i /n
0 	p~ up up n& L5 (wxPw
w
 (SR g(w. (wxPw
w
 (x

w
 up
l$)$짅$ $l䇀
w
 ((Ė  (ki!#O!(5l$'	 p-$ u$ڡ$ vڡ$$
$ $$  $   $
 ɀCs$ 지[$ $  지]Q $ e$  we +$ $ e$  we(5 (	$$  (	$$  ($ $(wxPwe$~we ($ mh %$ 지 $  h$ up!i  (ih !R' (j"y& u"y$#ڡ"x% vڡ"x%"y&
" up"y'
 p hb (ji!"d)!(5k#( u#&%ڡ#' vڡ(#'#(
#~lh $  	p h
#' p!i
 (ji!"c)!(k#y( u#y&%ڡ#x' vڡ*#x'#y(
# lh $  	p h#y' p!i
 	c  !$!x(5#x&!x($!x(5' p!!xĊ !x$ x(5"x& x($ x(5' p  xĊ x  xĊ p 

 %*x& &x%x)xՋ +%x(5k#
 ɀCn i# lh $# 짅
#  Ȋ!i h!#}:&(x'x
0 	p up#} up up& %%xċi%%xĖ 
V  !!x !x!ĭ'!x!ĭ'(!x(5
 ɀCӾ "%uu%"#% %#(#"ed%&%&&h o n( (5	($i(
 ɀCċ (( (  (
 ɀCI( 지[(  +(( ( 
(  w
((5 (	((  ((%a! (~(}(	(	 ((
ɑ' !x3?`Ex>2`0x1@( (5	(j(k` %j( (5"( (5#֋ x4C( (5	(j(k` $uj( (5"( (5#Ӌ x=)( (5j` % j( (5"rx8?%$	h ($( (5
)
 ɀC	)( hׇ(%$#"	&h-x%h!x6nx9 p
0 	p&(ed !g`' (   rr
   ! r  ! r
  r   ?6t     
 	  ͥͲM r3/(!
	ր r͆w) :΅ ɥvɥu


	vOuߥ_x (Ȇx(p t         h     `       h     ERROR:         P  Alphanumeric character required..Alphabetic letter required.Numeric character required.Illegal character.. A S                                     ERROR: Minimun input is  ERROR: Minimum input is  
 Character(s)         
    	m  }zupk3-   ` F "~ ***      GOTOXY  
 EXTRAIO 	 STRINGOP PASCALIO FILEOPS  SCREENOP                                      z  SAVEPHIL  w       *a.Pa  t+ pć+x շ  tpuph (Z, (y'(hB ʅ, (  h, (  huph (9- (5'(h   ʅ- (5 5 huptp/                                                                                                                                                                                                                                                                                  GETPHILE       L -d1Pd t. pć.x 
 t p tu. p i h uծ  p . pĆ t p b (	. p h/ ( / (q h/ ( / (q"!(	. p!i0!(5 5u. pċI!(kj"#0"(5'"j (kj"#/"('"j t2                                                                                                                                                                                M  UDESORT   8      n    s03 5 ur uv tp upu	p p    TEMPSORTTPress SPACE to continue:   EXTRAHEA HEAPOPS  LONGOPS 
 FILEOPS 	 STRINGOP GOTOXY   PASCALIO EXTRAIO  SCREEN40                                                                                                                                                                                                                                                                           9  ACCESSDA       (ih !` (5j""'""" "
 V"	L"	 S"
 " ("( h(ih !%	 (j"'" "( hֈ(5i!!Ĉ(5i!!!
Ĉ	(i!!(	(i!!(r
#邀.ih !& 짃5  지 hih !& 짃;  지 hՖ` r tpA upup tpJ upup tp upup	   r
 	vS up   r	u b     uu(r
 p tr(5 r vr(5 
r h`w`yw`w`  h`w`zw`  h`w`}w` јوr 5
ݘ 	 p u(
	p pu( 0 r
,G@r tp upup tp upup>r tp upup tp upup	   r
 	v upu     r	    uu(r(ur  r(5 r r(5 
r h`w`w`w`w` ,G0ŘIqr u( p.ŘIqr u( p p 
Z )`+P-.v` up* tp.	]i#O	j  k 
v
^h ^ 
d
d __	w_d
w_  dIrj
I"(5 
r
r
  ձ  
ri! u(j" p  
d
d __w_d
w_  dIrj
I"(5 
r
r#k#
__!Ą
 
 
_DĊ_A h# u(j p#+  	 p u(2j p#S tp#up#ݘ up#up#T tp#upPI EIr(5 PrPrPG PK #O up#up XI TIr(5 
XrXrX #ݘ up#up?# ^^Pw^Ww^Xw^Xw^ up#up#T tp#upTI [Ir(5 TrTr# ^^Tw^_w^ up#up#T tp#up#Y tp#up#F tp#up#1 tp#uph (5 (5'# (5~ up#up(h hń#1 tp#up#0 tp#up#1 tp#up#A tp#up#^h ^3# 
x up#up# 
y tp#up hƄ#0 tp#up#N tp#up#	p# 	j
$4
9	`Iqr u(g p zr(5|( }r(5(?r
q   r
I   r	 uv upup up uvu	p
 p5 ćAauru(nfG_SU I   uu(r
5 p#I    uu(r
 pց 
 	5           VOLNAMEEVolume    :Name      :Get format,Save formattChange,eXecute,Quit ?
Version  IV.0                SORT A DATA BASEE=================Type      :    SCRN and TEXTT"<ENTER> to execute, <ESC> to aborttVOLNAMEE:.SCRN.TEXTERROR: No data file foundERROR: Unknown Data BaseeGET SORTING FORMATT===================SAVE SORTING FORMAT===================Type      :    SORT"<ENTER> to execute, <ESC> to aborttVOLNAMEE:.SORTERROR: Unknown sorting format$ERROR: Unable to save sorting formattIDDERROR: Invalid field IDADDDdERROR: No valid field ids found
TEMPSORT.TEXT%ERROR: No room for param file on diskVOLPRINTERprinterPRINTER::NAMEE:.TEXTWORKVOL:UD/SORT.SCRNN$ERROR: Unable to load "UD/SORT.SCRN""VOL NAMEE                      
ERROR: Invalid Selectionn C X                                                                                                                                                                                                                                                                                                                                                                                                                                                 \  PSORT          p   Ĉ!  	 p A    ˁ  p   t㭆  ĭ   ĭ! [   tp㭆  ĭ   ˁ  p! ! p! "! ! p!   Ė 8      tp㭆
  Ĉ	p a ph  խ  	 
)(r tp upa up_ (r tp up<r tp up  up% upa up, + pĊ Ė    ph 	x /wi! c!w c0r tp8 upc upC upbu	pr"
+ p 	q  Hr tpK up  upU up up+ p 	P /g܇*y܇*xwg (  k l j m%m%n&Q"i%j$l$%#%#$A$4r tpY up up+ p"i%j"!h ((hg! wg ( m,0-.-h , G,x0 x0 x-aa  0 y 2 2,)a  0 y  22, h},21	(,䄈		.Z	(T	U	+  I   W
S X* ć)  F wmw U 	pߐX^STS

S
S
X(rs up*x up WXW 	 	. 	( 	U 	-   ERROR: Can't find file:  ERROR: No room on diskkERROR: I/O error (() for file:  abort:default prefixxACTION: Put in disk  , type <space>>ERROR: Open error () for: 'ERROR: Insufficient key delimiters in: .TEXTabortSTATUS: Records read:   v  : 9                                                                                                                                                                                                                                                                                                                                       &  GETPARM       x \

 h`J
w`w` \

 h`J
w`w` \

 h`J
w`w` \

 h`J
w`w` \

 h`J
w`w` \

 h`J
w`w` \

 h`J
w`w` \

 h`J
w`w` \	

 h`J
w`w` \


 h`J
w`w` `Ta`-	`T 	 Tߕ(r# upup`0u
p`u
p0짤/ V`u
p`u
p`0u
p`u
p0짤//T/t[`u
p`u
p`0u
p`u
p0짤//T/tY`J
u
p`u
p`0u
p`u
p0짤//T/tZ`0u
p`u
p0짤//Y/yU`0u
p`u
p0짤/ PH=`.up`u
p. ;ܭH*SS.ćS=ć=.=HH. ԪHHG`.up`u
p. V0GSS.*`0u
p`u
p0짤//3	S ĊSĭGG. ԏGG`0u
p`u
p0짤/`	p` 	b    SRT11SRT22SRT33SRT44SRT55SRT66SRT77SRT88SRT99SRT10abortSTATUS: Reading parameter filee                                                                                                                                                                                                                                                                                                                                                                                                                                                                   DISTRIBU       1 `` upup L  \ 

  	 [  	p     瀀  0y  hh0y h h  "xh 1` i!瀖!瀕!. !瀀 (" ÊA 瀀    .   瀖 瀕   瀖 瀕  `h 怖IG  iawa wawa       
 ))xĊ  怕    Uuph `-	(r up(r    孅
ĄŔ (# GU.u
pUu
p. %**xĈ0x.Đ՜  孅 W^ڀ(r  up up+ upڐ p -0ߕĐŔ+I(r(v1 upĐŔŔI X` 	        STATUS: Distributing ....ude_sort,psort,distribute    Writing workfile # ...abort  "STATUS: Writing output file...        0 P (                                                                                                      MERGE    /        !  u
pu
p i u
piu
p < u
p<u
p  u
pu
p u
pu
pj u
pu
pU u
pu
p@[ u
p[u
p+. u
p.u
p u
pu
pրc   c ui\ iuiR <uiH ui> ui4 ui* ui  [ui .ui uiր Z    \

 	 i\

 	 <\

 	 \

 	 \

 	u\

 	^\

 	G[\

 	0.\	

 	\


 	րa   l!w	pni	pb<	pV	pJ	p>	p2	p&[	p.	p	pր&}!w	pni	pb<	pV	pJ	p>	p2	p&[	p.	p	pր2 B  !   upup i  upiup <  up<up   upup  upupj  upupU  upup@[  up[up+.  up.up  upupր>8    \

  	 i\

  	 <\

  	 \

  	 \

  	u\

  	^\

  	G[\

  	0.\	

  	\


  	րJm i
ˮ
kh #!  i hﮆW	! Ti!l d 
h 
׀x ڳ 
h 
׀x՟  b 
׀  
ˮ
ˤi!8!
׀x b 
!b !iîT
׀x(îT
׀ b TîT
׀xT  
P`-	.Z	[			ℇ	;	<h	i		)  ϭXS p VYߕ(rXZ up%k upS upz up(r


ˤФ··вզ Ç
׀ ćέڲέTWxΐ|\

ߕϭߠτÇ
׀ѭ9·  ΐᇐ 
FFć΋P
+ p   	 
ˤ̈́Ç
׀ЭXd фтwчwтw ȇ ȇ 
ȇ
S))xĄÇ
׀ ͐=͇  ͐ᇐ  ĊFF ċ 	 
ˤ͇ Ց Ç
׀ЭXd фтwчwтw ȇ ȇ 
ȇ
S))xć ć U G(r up
˭
ˤФ··в΀pΊ筆WTpXSl` 	. 	[ 	 	 	 	 	< 	i 	 	P     
*@Vl  
  
,D\t  
  
  
*@Vl  
,D\tabort  !STATUS: Merging to output file...STATUS: Merging to workfile  ...noabort                %STATUS: Purging intermediate files...#/  | 5 	                                                                                     ' d  5   : 	 $  
 
    $ ,    COPYDATAINITIALIGETFILESGETDATAFRECORDLECREATEMAGETCOPYIFIELDSYNGETTESTAUSERTESTDISPLAYTUPDATETEREADTESTREADWRITLOADSCREBUILDREC                                 (   COPYDATACOPYDATACOPYDATACOPYDATACOPYDATACOPYDATACOPYDATACOPYDATACOPYDATACOPYDATACOPYDATACOPYDATACOPYDATACOPYDATACOPYDATA (                     h     IV0     DL  *    5DB OO? r OO   7D 
========================================================================================
DOCUMENT :usus Folder:VOL26:ude.1.text
========================================================================================



                               TABLE OF CONTENTS
                                        
                              UNIVERSAL DATA ENTRY



INTRODUCTION............................................................ 1.1

      Overview ......................................................... 1.1.1

      Screen Data Input................................................. 1.1.2

      Screen Messages................................................... 1.1.3

      Standard Screen Commands.......................................... 1.1.4

            Execute Screen Functions.................................... 1.1.4.1

            Changing Screen Data Fields................................. 1.1.4.2

            Quitting the Current Screen................................. 1.1.4.3

            Saving Screen Information on Disk........................... 1.1.4.4

            Getting Screen Information from Disk........................ 1.1.4.5

USING THE UDE MAIN MENU................................................. 1.2

      Getting Started................................................... 1.2.1
      
      Selecting a Program from the UDE Menu............................. 1.2.2
      
      Returning to the Main System Command Line......................... 1.2.3
      
DEFINING A UDE DATA BASE................................................ 1.3

MAINTAINING A UDE DATA FILE............................................. 1.4

      Accessing the Data File........................................... 1.4.1
      
      Performing Maintain Operations.................................... 1.4.2
      
      Setting the Record Number......................................... 1.4.3
      
      Adding New Records................................................ 1.4.4
      
      Examining Records................................................. 1.4.5
      
      Changing Records.................................................. 1.4.6
      
      Storing Records................................................... 1.4.7
      
      Deleting Records.................................................. 1.4.8
      
      Mashing the File.................................................. 1.4.9
      
      Performing Calculations........................................... 1.4.10
      
      
      
      
      
      
DEFINING A PRINTED LISTING FORMAT....................................... 1.5
      
      Accessing the Data File........................................... 1.5.1
      
      Creating a Printed Listing Format................................. 1.5.2
      
            Specifying an Output File................................... 1.5.2.1
            
            Listing Records with Certain Values......................... 1.5.2.2
            
            Listing the Records......................................... 1.5.2.3
            
            Exporting the Records....................................... 1.5.2.4
            
            Creating an Export File..................................... 1.5.2.5
            
            Export File Example......................................... 1.5.2.6
            
SORTING A DATA FILE..................................................... 1.6

      Accessing the Data File........................................... 1.6.1
      
      Creating a Sorting Specification.................................. 1.6.2
      
COPYING A UDE DATA FILE................................................. 1.7

      Definition of Terms............................................... 1.7.1
      
      Screen Definition Requirements.................................... 1.7.2
      
      Accessing the Data Files.......................................... 1.7.3
      
      Status Messages................................................... 1.7.4
      
      Copying All Fields of All Records into a New Data File............ 1.7.5
      
      Copying Only Certain Fields into a New Data File.................. 1.7.6
      
      Copying Only Certain Records into a New Data File................. 1.7.7
      
      Copying Additional Records to an Existing Data File............... 1.7.8
      
      Merging Selected Fields into an Existing Data File................ 1.7.9
      
      Deleting Unwanted Records From a Data File........................ 1.7.10
      
DEFINING A SCREEN FORMAT................................................ 1.8

      Introduction...................................................... 1.8.1
      
            Main Option Menu............................................ 1.8.1.1
            
      Clear Current Screen Definition................................... 1.8.2
      
      Edit Screen Definition File....................................... 1.8.3
      
            Field Definition Input Mask................................. 1.8.3.1
            
            Prompt Definition Input Mask................................ 1.8.3.2
            
            Edit Options................................................ 1.8.3.3
            
      Get Old Screen Definition......................................... 1.8.4
      
            Screen Definition Example................................... 1.8.4.1
            
      Print Screen Definition File...................................... 1.8.5
      
            Printing the Current Screen Definition...................... 1.8.5.1
            
      Quit.............................................................. 1.8.6
      
      Save the Current Screen Definition File........................... 1.8.7
            
            
            
            
            
            
            
            
            
            
            
            
            
            
            
            
            
            
            
            
            
            
            
            
            
            
            
            
            
            
            
            
            
            
            
            
            
            
            
            
            
            
            
            
            
            
            
            
            
            
            
            UNIVERSAL DATA ENTRY 
8/82 
 
 
                            1. UNIVERSAL DATA ENTRY 
 
 
1.1 INTRODUCTION 
 
1.1.1 Overview 
 
     Universal Data Entry (UDE) enables users with little training to enter
data into computer files which can later be sorted, printed, or accessed by
other programs for data processing.  This applications program is designed to
run only under the UCSD p-SYSTEM (TM).  Prompts are provided at fields in
which data is to be entered; and, if an error is detected, the user is advised.
 The screen prompts are created by the user with the help of the UDE Define
function (see section 1.8). 
 
     The UDE system is comprised of five programs: Define, Maintain,
Sort, List and Copy.  Define allows the user to set up the screen and
record layout of a data file.  Maintain collects data and enters it into a file
which may be scanned to change or delete a record.  Sort is used to sort the
records by field.  Up to ten fields may be used as keys, and each field may be
sorted in ascending or descending order.  The user may put the sorted results
into a new file if the data needs to be saved in its original form.  The keys
used for sorting may also be stored for subsequent use. 
 
     List allows the user to list the records in a UDE data file on a line or
letter-quality printer.  The list format is user-defined and allows choosing
the headings and footings which are to appear at the tops and bottoms of pages,
which fields and records are to be printed, and which headings are to appear
above each field.  Format information may be saved for use in printing other
data.  List also allows a user to "export" data into a text file to do custom
letter writing or address lists. 
 
     Copy allows the user to copy data from selected fields and records of
a UDE data file to another UDE data file. 
 
     UDE may also be used in conjunction with other programs which read data
and process it by means of specially-prepared software.  Finally, UDE can
collect data for transmission to other computers for storage or processing. 
 
     UDE can be used for name and address lists, inventory records, appointment
calendars, purchase order records, payroll records, and many other business
problems. 
 
     To use UDE for a particular application, start the program by executing
the program UD/UDE.CODE.  Define a data file using the UDE Define function and
specify the information (numbers, dates, names, addresses, amounts,
descriptions, etc.) needed in the data file.  This process is very similar to
designing a manual filing system and takes only a few minutes to accomplish. 
 
     Having defined a data file format, create the data file and enter
information using the Maintain function.  Once entered, any record can be
examined, changed or deleted. 
 
     Information in the data file can be sorted, printed or copied as
required with the Sort, List and Copy functions. 
 
 
 
 
 
 
 
 
 
   UDE for the p-SYSTEM is made up of the following programs: 
 
   UD/UDE.CODE - Allows the user to choose the UDE function that is to be
                 performed. 
               
   SD/DEFINE.CODE - Defines the screen and record layout of a data file. 
    
   UD/MAINT.CODE - Creates a data file if necessary and maintains records in the
                   data file with add, examine, delete and modify commands. 
                    
   UD/SORT.CODE - Sorts data file records.  This program requires the
                  file UD/SORT.SCRN be available on the prefixed disk. 
                   
   UD/LIST.CODE - Lists the active records in the data file.  This program
                  requires the file UD/LIST.SCRN to be on the prefixed disk. 
                   
   UD/COPY.CODE - Copies all or part of a UDE data file to another UDE data
                  file. 
 
 
 
 
1.1.2 Screen Data Input 
 
     A defined UDE data file will appear on the screen as a number of prompts
followed by values. 
 
*********************************************************************** 
 
                                 UDE Data File 
                                   Example 1 
 
             1st prompt:value1          2nd prompt:value2 
             3rd prompt:value3 
             4th prompt:value4 
 
*********************************************************************** 
 


The rest of the information is prompts that the user does not change.  For
instance, a UDE data file could be set up to store customer names, addresses
and telephone numbers.  The prompts on the screen might look like: 
 
************************************************************************ 
 
                              Customer Data File 
 
     Name: _________________     Telephone number: ___________________
     Street: _________________________________
     City: _______________  State:___ Zip: __________
 
*********************************************************************** 
 
 
 
 
 
    Each piece of information the user enters on the screen is known as a
field.  So there is a name field, a telephone number field, and so on.  All
the fields on the screen, when taken together, are known as a record.  All
the records are called the data file. 
 
    UDE collects all its records by presenting the screen to the user to
be filled in.  There is more information on entering records into UDE in the
Maintain section.  There are also some special keys that are used when entering
data.  These special keys are explained in section 1.8. 
 



1.1.3 Screen Messages 
 
     During the operation of UDE the following types of messages may be
displayed in the right half of the last line on the screen. 
 
          STATUS: Indicates the status of an operation. 
           
          ERROR: Indicates an error has occurred. 
           
          WARNING: Indicates the operator is about to perform a dangerous
                   operation. 
                    
          ACTION: Indicates some action is required by the operator to
                  continue. 
 



1.1.4 Standard Screen Commands 
 
     Some of the screens displayed by UDE programs have the following standard
commands at the bottom of the screen.  All other commands, unique to a certain
UDE function, will be explained later. 
 
1.1.4.1 Execute Screen Functions 
 
     When the eXecute command is in the lower left of the UDE screen,
pressing <X> will execute the function indicated by the screen display. 
 
1.1.4.2 Changing Screen Data Fields 
 
     When the Change command is in the lower left of the UDE screen,
pressing <C> will allow changing the values in the data fields on the
screen.  The cursor will be put at the beginning of the first field. 
 
1.1.4.3 Quitting the Current Screen 
 
     When the Quit command is in the lower left of the UDE screen, pressing
<Q> allows the user to exit the current operation. 
 
                  
                  
                  
                  
                  
                  
                  
                  
                  
                  
 
1.1.4.4 Saving Screen Information on Disk 
 
     When the Save command is available in the lower left of a UDE screen,
pressing <S> will save the screen data.  By keeping this information and
using it when the same operation needs to be done again, time is saved and the
possibility of error is reduced.  The Save screen looks like: 
 
 
*************************************************************** 
 
 
              SAVE SORTING (or PRINTING) FORMAT 
              ================================= 
 
Volume     : ___________

Name       : _________________
 
Type       : SORT (or LIST) 
 
 
 
 
<ENTER> to execute, <ESC> to abort 
 
 
*************************************************************** 
 
 
 
    If Volume is left blank it will default to the prefixed volume. 
Name can be any valid file name.  Type is either LIST or SORT depending on
what is to be saved.  These fields may already be filled from a previous Get
or Save operation. 
 
    Press <enter> to perform the save operation.  If the data in the
screen was not saved due to a full disk, damaged disk or other error, a message
will be displayed.  Press <esc> to abort the Save operation and return to the
previous menu. 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 

 
1.1.4.5 Getting Screen Information from Disk 
 
     The Get command assumes that a format has already been saved using a
Save command.  When the Get command is available at the lower left of a UDE
screen, pressing <G> loads the screen with data.  It can then be used,
changed or corrected.  The Get screen looks like this: 
 
 
*************************************************************** 
 
 
               GET PRINTING (or SORTING) FORMAT 
               ================================ 
 
Volume     : ___________

Name       : _______________
 
Type       : LIST (or SORT) 
 
 
 
 
<ENTER> to execute, <ESC> to abort 
 
 
*************************************************************** 
 
 
 
    If Volume is left blank it will default to the prefixed volume. 
Name can be any valid file name.  Type is either LIST or SORT depending on
what is being loaded.  These fields may be already filled from a previous Get
or Save operation. 
 
     Press <enter> to perform the Get operation.  If the data in the screen
was not loaded due to an incorrect file name, damaged disk or other error, a
message will be displayed.  Press <esc> to abort the Get operation and return
to the previous menu. 
 




















 
 
 
1.2 USING THE UDE MAIN MENU 
 
1.2.1 Getting Started 
 
     UDE may be started by executing the file UD/UDE.CODE. 
 
1.2.2 Selecting a Program from the UDE Menu 
 
     The UDE menu displays a list of programs on the screen and allows the
operator to choose the program desired.  All programs are described in detail
in the appropriate sections of this manual. 
 
 
*************************************************************** 
 
 
                UNIVERSAL DATA ENTRY 
                ==================== 
 
 
               Define a UDE data file 
 
               Maintain a UDE data file 
 
               Sort a UDE data file 
 
               List a UDE data file 
 
               Copy a UDE data file 
 
 
Enter selection or <ESC> : 
 
 
*************************************************************** 
 



1.2.3 Returning to the Main System command line 
 
     Return to the main system command line by pressing <esc>. 
 
 

========================================================================================
DOCUMENT :usus Folder:VOL26:ude.2.text
========================================================================================

1.3 Defining a UDE Data File 
 
     The format of a data file must be defined by the user.  To define a data
file format, press <D> from the UDE menu.  An explanation of the Define
function is found in section 1.8.  The format may consist of up to 40 fields,
as long as the total number of characters in the format is 250 or less. 
Because the last two lines of the screen are used for messages, they should not
be used in the format. 
 
 


 
 
 
 
 
 
 
 
 
1.4 MAINTAINING A UDE DATA FILE 
 
     Maintaining a UDE data file includes adding, changing, or deleting records
that have been defined. 
 
1.4.1 Accessing the Data File 
 
     When an <M> is pressed while in the main UDE display, the following
screen appears: 
 
 
***************************************************************** 
 
 
                     MAINTAIN A DATA BASE 
                     ==================== 
 
 
Volume   : _________

Name     : ____________

Type     : SCRN and TEXT



<ENTER> to execute, <ESC> to abort 
 
 
***************************************************************** 
 
     The UDE data is kept in two different files: a file ending in .TEXT
for storing data, and a file ending in .SCRN for storing the UDE screen
description. 
 
     After entering the volume and name fields, press <enter>.  If the SCRN
file is not found, an error message is displayed.  If the TEXT file is not
found, the program asks if it should create a new data file.  If the answer is
yes, the next prompt is: 
 
          Maximum number of records ?_0_______
 
The absolute maximum number of records in a data file is 32767.  Enter whatever
number is most appropriate for that data file, keeping in mind that the only way
to expand a data file with all its records filled is to copy it into a new,
larger data file.  Entering an unacceptable number will result in an error
message. 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
     When the TEXT file is available for storing data, the UDE screen
layout, created with the Define program, is displayed and the following
prompt appears at the lower left of the screen: 
 
Rec # <1__>, Add, Mash, 
Store, Examine, Change, Delete, Quit ? 
 
1.4.2 Performing Maintain Operations 
 
     Select the operation to be performed by pressing the appropriate key,
either <R>, <A>, <M>, <S>, <E>, <C> or <D>.  When all operations
have been performed, <Q> will return the user to the main menu. 
 
1.4.3 Setting the Record Number 
 
     Select the Rec # command by pressing <R>.  This allows access to the
data file by record number.  The current record number is displayed in this
field as the data file is being maintained.  When a new record number is
entered, press <return> to get to the main prompt line.  To view the record,
press <E> to examine.  If an incorrect number is entered, an error message is
displayed. 
 
1.4.4 Adding New Records 
 
     Select the Add command by pressing <A>.  This puts the operator in the
Add mode of operation, finds the first blank record after the current record
number and clears all the data fields to blanks or to the proper default
values.  When all the data fields have been properly filled in, press <enter>
to add the record to the data file and automatically find the next blank
record.  This will also perform any calculations defined in the record and put
the results in the proper fields.  Press <esc> to leave the Add operation. 
 
    If the end of available space is reached, Add terminates with a
message.  There may, however, be more empty records available for input.  To
find them, return to record number one by using the <R> command and press
<A> to add. 
 
1.4.5 Examining Records 
 
     Select the Examine command by pressing <E> to display the record whose
number is in the Rec # field.  That number can be changed by using the
Rec # command.  Continuing to press the <E> increments the record number by
one, allowing examination of successive records. 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
1.4.6 Changing Records 
 
     The user may change the contents of any record by displaying the record
on the screen and pressing the <C> to Change.  This will move the cursor to
the beginning of the first field and the user may go from field to field,
changing whatever information is desired.  When complete, press the <enter>
key to return to the UDE Maintain prompts.  The calculations defined for that
record will be performed and the results displayed.  In order to save the
changed information in the file, the Store command must be performed. 
 
1.4.7 Storing Records 
 
     Select the Store command by pressing <S> to store the data on
the screen in the record number indicated.  This command is used to modify
existing records or to add single records to the data file without going into
add mode. 
 
1.4.8 Deleting Records 
 
     Select the Delete command by pressing <D> to delete the record pointed
to by the record number.  The fields of the deleted record are filled with
blanks on the screen and a blank record is written on the disk.  It is not
possible to recover data that has been deleted with this command. 
 
1.4.9 Mashing the File 
 
     When the user wants to move all non-blank records to the beginning of the
file, this can be done by pressing <M>.  This will consolidate all empty
records at the end of the file.  It is very important that the user not
disturb this operation until it is complete. 
 
1.4.10 Performing Calculations 
 
     If a field is defined as calculated, the calculation will be performed
when the record is Added or Changed.  A few things must be kept in mind when a
field is calculated.  The maximum size of a number that can be calculated is
nine digits to the left of the decimal point and four digits to the right. 
 This means that it is not possible to calculate numbers smaller than .0001 or
greater than 999999999.  An overflow message will appear if too large a number
is calculated and the result will be set to 0. 
 
   The field size must be large enough to store the integer part of the
calculated value or an error message will appear and the field value will be
set to 0.  There will always be at least one digit to the left of the decimal
point, ie. 1/3 is calculated as 0.3333.  If the field is not wide enough to
hold the calculated number and there are any digits to the right of the
decimal point, the program will attempt to store it anyway.  For instance, if
the calculated value is 100.2365 and the field width is only six, the program
will truncate digits to the right of the decimal point until the value fits in
the field.  In this case, 100.23 will be the stored value.  No rounding of the
number is attempted.  To avoid the problem, define fields with enough width to
contain the calculated numbers. 
 
  

 
 
 
 
 
 
1.5  DEFINING A PRINTED LISTING FORMAT 
 
     The format for listing UDE data records includes the fields to be
listed, their order, and the titles and footings to be put on each page. 
 
1.5.1  Accessing the Data File 
 
     When an <L> is pressed while in the UDE main display, the following
screen will appear: 
 
 
******************************************************** 
 
 
                   PRINT A DATA FILE 
                   ================= 
 
 
Volume    : ________

Name      : ____________

Type      : SCRN and TEXT


 
 
 
<ENTER> to execute, <ESC> to abort 
 
 
******************************************************** 
 
 
 
     Two types of files are required to print a data list: a TEXT file for
storing data, and a SCRN file for storing the UDE definition. 
 
     Input the volume and name fields, then press <enter>.  If the SCRN file
or TEXT file is not found, an error message is displayed. 
 
 
 
 
 
 
 
 
 
 












1.5.2 Creating a Printed Listing Format 
 
     When the desired data list has been found, the following screen will
appear: 
 
 
************************************************************* 
 
 
               PRINTED LISTING FORMAT 
               ====================== 
 
Printer Width    : 132 
Heading Number 1 : _____________________________________________
Heading Number 2 : _____________________________________________
Heading Number 3 : _____________________________________________
 
Col #    Field Id                   Column Title 
 
 1       ________     ________________________________________
 2       ________     ________________________________________
 3       ________     ________________________________________
 4       ________     ________________________________________
 5       ________     ________________________________________
 6       ________     ________________________________________
 7       ________     ________________________________________
 8       ________     ________________________________________
 
Footing Number 1 : _____________________________________________
Footing Number 2 : _____________________________________________
Footing Number 3 : _____________________________________________
 
Get,Save format,Output file, 
Change,Export,List,Tests,Quit ?  
 
************************************************************* 
 
 
     Printer Width specifies the maximum number of characters that may be
printed across the page.  If the field widths or column title widths add up to
more than this value, an error message is given. 
 
    Up to three page headings may be specified in the Heading data
fields.  These headings will appear centered on the top of each report page. 
 
    The Field ID's to be listed and the Column Title's to appear
above each column of printed data are entered in their respective columns.  If
a "#" is placed instead of a Field ID, the record number will be printed when
the report is generated. 
 
     Up to three page footings may be specified in the Footing data fields.
If a "#" is entered in place of a normal footing, the pages of the report will
be numbered at the bottom when the report is generated.  The footings and page
number are centered at the bottom of each page. 
 
    
    
    
    
    
    
    
    
    The commands available at the bottom of the screen allow the user to
save the data on the screen, get data to fill in this screen from disk, change
the data fields on the screen and return to the main system.  The Get, Save,
Change and Quit commands are described in section 1.1.4 of this document. 
 
1.5.2.1 Specifying an Output File 
 
     The Output file command allows the user to name the file in which to
place the listing.  It needs to be performed only if the user wants to send the
listing to a file, rather than directly to the printer.  If no Output file
command is performed, the List output will be sent to the printer.  If the user
presses <O>, the following display appears: 
 
***************************************************************** 
 
 
                   OUTPUT FILE NAME 
                   ================ 
 
 
Volume    : ________

Name      : ____________

Type      : ____________





<ENTER> to execute, <ESC> to abort

 
***************************************************************** 
 
 
Any file name or type is acceptable here.  However, it is possible to
destroy files that already exist; it would be very easy at this point to copy
over the UDE data file.  BE CAREFUL!  The user may perform the Output file
command any number of times.  To make the output go directly to the printer
after a file has been defined, perform the Output file command and clear all
the fields of the file name. 
 

========================================================================================
DOCUMENT :usus Folder:VOL26:ude.3.text
========================================================================================

1.5.2.2 Listing Records with Certain Values 
 
     It is also possible to list or export only certain records of a data file.
 If <T> for Tests is pressed, the following screen will appear: 
 
***************************************************************** 
 
Comparison tests to be made on fields of each record:         Choose from the 
                                                              following fields: 
FIELD ID   OPERATOR                   VALUE 
 
________    _____     _____________________________________
________    _____     _____________________________________
________    _____     _____________________________________
________    _____     _____________________________________
________    _____     _____________________________________
________    _____     _____________________________________
________    _____     _____________________________________
________    _____     _____________________________________
________    _____     _____________________________________
________    _____     _____________________________________
________    _____     _____________________________________
________    _____     _____________________________________
________    _____     _____________________________________

Valid operators are: < , > , = , <= , >= , or <> 

Currently viewing tests 1 - 13 
 
Get, Save tests, Change, Next, Back, Quit: 
 
***************************************************************** 
 
    Up to 52 tests can be performed on the fields of each record to
determine whether or not that record should be listed (or exported).  If the
Tests command is not used before a List or an Export, or if the user
leaves all of the 52 tests blank, the program will assume it is to list or
export all records. 
 
   Each test consists of a field id, an operator and a value.  On the
right hand side of the screen is a list of all valid field ids.  Any of the
field ids in that list may be used in the tests and any may be used more than
once.  The valid operators given on the screen have the following meanings: 
 
                    <    less than 
                    >    greater than 
                    =    equal to 
                    <=   less than or equal to 
                    >=   greater than or equal to 
                    <>   not equal to 
 
 
 
 
 
 
 
 
 
 
 
 
 
As an example, the field id ZIPCODE could be tested for 
 
                       ZIPCODE > 10000 
                             and 
                       ZIPCODE < 20000 
 
These tests would select all records with ZIPCODE fields between 10000
and 20000.  An error message will be displayed if an invalid field id or
operator is entered or if the length of an entered value exceeds the maximum
allowable.  To recover from an error, reenter the correct field id, operator or
value. 
 
    Only thirteen tests appear on the screen at one time, the rest may be
entered or examined by using the Next and Back commands.  When first
displayed, tests 1 - 13 are available for viewing and the line "Currently
viewing tests 1 - 13" is displayed.  If the user presses N for Next, tests
14 - 26 appear.  If B for Back is pressed, tests 1 - 13 reappear. 
 
    The Get and Save commands allow tests to be saved to a disk file
for subsequent reuse.  The operation of these commands is the same as that of
the commands described in sections 1.1.4.4. and 1.1.4.5. 
 
     When all of the tests have been entered, press <Q>.  If two or more tests
have been entered, the following screen will be displayed: 
 
***************************************************************** 
 
List or export each record if: 
 
1) All of the above tests have been met 
 
2) Any of the above tests has been met 
 
Enter 1 or 2 : 
 
***************************************************************** 
 
The user must respond correctly to the above prompt to get the desired
result.  For example, to select all records with ZIPCODE fields between 10000
and 20000, as in a previous example, the following tests would be entered: 
 
                     ZIPCODE  >  10000 
                               and 
                     ZIPCODE  <  20000 
 
The proper response to the above prompt would be a 1 in this case because
both tests should be true if the record is to be copied.  If a 2 were entered,
all records would be listed because all records would pass either one or the
other or both of the tests.   
 
 
 
 
 
 
 
 
 
 
 
 
 
 
    To select all records with ZIPCODE fields equal to either 10000 or
20000 the following tests would be entered: 
 
                            ZIPCODE  =  10000 
                                 and 
                            ZIPCODE  =  20000 
          
Since a record should be listed if either of the two tests is met, the
proper response to the above prompt would be a 2.  A response of 1 would result
in no records being listed because no record could have a ZIPCODE field equal
to both 10000 and 20000. 
 
    After a response is received to the above prompt, the program will
return to the "Printed Listing Format" screen.  A subsequent List or Export
will use only those records that pass the comparison tests. 
 
1.5.2.3 Listing the Records 
 
     Pressing <L> to execute the List command will list all active data
list records or the records determined by the tests.  The listing will go to
the printer unless a file name was specified in the Output file command.  If
the width of all the user fields is longer than the Print Width, an error is
given.  The user may then change the number of fields to be listed, or if
possible, change the printer width field.  If the output is sent to a file, the
file is closed and saved when the command is complete.  It may be printed
later.  If this file name is used again as an output file, the contents of the
first list will be overwritten by the contents of the second. 
 
 
 


 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
1.5.2.4 Exporting the Records 
 
     By pressing <E> for Export, the user can take selected fields from the
data file and print them as part of another form or letter.  The format in
which the exported records are printed is determined by a special text file
which must have been created previously by the user with the text editor.
 
   Upon entering the Export command the user will be prompted with: 
 
***************************************************************** 
 
 
                   EXPORT FILE NAME 
                   ================ 
 
 
Volume    : _________

Name      : -------------
 
Type      : TEXT 
 
 
 
 
 
<ENTER> to execute, <ESC> to abort 
 
 
***************************************************************** 
 
 
Enter the name of the export format file.  Its name must end in .TEXT. 
When <enter> is pressed the export will begin.  If the Output file
command was used, the exported output will be written to the file specified,
otherwise it will be sent to the printer.  When the export is complete, the
user will be returned to the Printed Listing Format display. 
 
1.5.2.5 Creating an Export file. 
 
     Prior to executing Export the user must create a special file using the
text editor. The file may contain anything desired from a business letter to
a simple format for an insertion file. 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
1.5.2.6 Export File Example 
 
An example of an export file that is a format for a business letter is: 
 
 
     June 20,19__
      
      
     {*FIRST*} {*LAST} 
     {*CONAME} 
     {*ADDR} 
     {*CITY*}, {STATE}  {ZIP} 
      
     Dear {*FIRST}, 
      
           Thank you for inquiring about the line of quality 
     products.  I'm sure that you will find that our line of
     {*ITEM*}  is just what you need.  Enclosed is a current 
     price list  along with a general  description  of  each 
     item on the list. I look forward to doing business with 
     you, {*FIRST*}  and  {*CONAME*} in the near future.  If 
     you  need any futher  information,  please feel free to
     call me.
      
      
                              Bob Updyke{12} 
      
      
      
The output then, might look like this: 
      
      
     June 20,19__
      
      
     John Customer 
     INT.ENT. 
     1111 N.W. Hwy 
     Dallas, Tx  75211 
      
     Dear John, 
      
           Thank you for inquiring  about our line of quality
     products.  I'm sure that you will find  that our line of 
     microscopes is just what you need. Enclosed is a current 
     price list along with a general description of each item 
     on the list.  I look forward to doing business with you, 
     John and INT.ENT. in  the near  future.  If you need any 
     futher information, please feel free to call me. 
      
      
                              Bob Updyke 
            
            
            
            
            
            
            
            
            
            
            
The names in the curly braces indicate that the value of the field by the name 
enclosed should be inserted in the text at that point.  On the third line, the 
first and last name of the customer was to be printed one line below the date.  
An asterisk before the ID name indicates that any blanks before the field 
should not be printed ("    John    " would be printed "John").  An asterisk 
after the ID name indicates that any blanks to the right of the field should 
not be printed ("    John    " would be printed "    John").  An asterisk 
before and after the ID name indicates that blanks on either side of the field 
should not be printed ("    John    " would be printed "John").  Placing a 
number inside a set of curly braces causes the insertion of a character whose 
ASCII code is that number.  It is primarily used to generate special characters 
required by other computers for communications.  It is used here to send a top 
of form character to the printer after each letter is printed. 
 

 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
1.6  SORTING A DATA FILE 
 
1.6.1  Accessing the Data File 
 
     When <S> is pressed while in the UDE main display, the following
screen appears: 
 
 
******************************************************** 
 
 
                   SORT A DATA BASE 
                   ================ 
 
 
Volume    : _________

Name      : ______________
 
Type      : SCRN and TEXT 
 
 
 
 
 
<ENTER> to execute, <ESC> to abort 
 
 
 
 
******************************************************** 
 
 
 
     Two types of files are required to sort a data file, a TEXT file that
contains data, and a SCRN file containing the UDE definition. 
 
     Enter the volume and name, then press <enter>.  If the file ending in
.SCRN or the file ending in .TEXT is not found, an error message is displayed. 
 
 
 
 
 
 




















1.6.2 Creating a Sorting Specification 
 
     After the data file has been located, the following screen will appear: 
 
 
*********************************************************** 
 
 
               SORT A DATA BASE 
               ================ 
 
Sort Seq.     Field Id     Asc/Dsc          OUTPUT FILE 
                                           (If different) 
   1          _______         A
   2          _______         A          Volume : _______
   3          _______         A
   4          _______         A          Name   : __________
   5          _______         A
   6          _______         A          Type   : TEXT
   7          _______         A
   8          _______         A
   9          _______         A         VOLUME FOR WORK FILES
  10          _______         A            (If different)

                                        Volume : ________

Get format, Save format
Change, eXecute, Quit ?
 
*********************************************************** 
 
 
    The Field ID's to be sorted and the sort sequence are defined in the
Field Id column.  The names entered must be spelled exactly the way they were
in the Define program.  The sorting sequence for each data field, either
ascending order or descending order, is specified in the Asc/Dsc column.  A
D (or d) indicates descending order.  An A, a blank or any other
character indicates ascending order. 
 
    A new UDE data file of the sorted material can be created by entering
the OUTPUT FILE information.  The volume entered under OUTPUT FILE does not
need to be on-line when the program is executed.  When it is time for the
output file to be written, the program will ask the user to put the volume that
is to receive the output file into the disk drive.  In any case, the workfiles,
if any, must be written to a disk that is to remain on line at all times.  If
the OUTPUT FILE fields are left blank, the new sorted data file replaces the
old unsorted file. 
 
    It should be noted, however, that the program does not create a new
SCRN file.  To use the new data file, the user must make a copy of the old SCRN
file by transferring it to a file with the new output file name and a SCRN
type. 
 
 
 
 
 
 
 
 
 
 
 
    The standard commands available at the bottom of the screen allow the
operator to save the data on this screen, get data to fill in this screen from
disk, change the data fields on the screen and return to the main command line.
 These standard UDE commands are described in section 1.1.4 of this document. 
 
     While sorting, the computer may not be able to store all the
records in memory.  When this occurs, temporary work files must be written to a
disk.  If the prefixed disk is short on space, specify another disk as the work
file volume using the VOLUME FOR WORK FILES field.  The workfiles require
approximately as much space as that taken up by the file to be sorted. 
 
     Press the <X> to execute the sort operation.  Approximately 200 records
can be sorted in 15 minutes and 1000 records in one hour.  The maximum file
size that can be sorted is limited only by disk space.  There must be sufficient
space for the workfiles on their destination disk and for the output file on
its destination disk.  The final sorted file will be the same size as the
previously unsorted database. 
 












































 
1.7 COPYING A UDE DATA FILE 
 
     The Copy Data File program has the following features: 
 
           * Data may be copied from a UDE data file into a UDE data file 
            
           * Data may be copied from any or all records of a data file 
            
           * Data may be copied from any or all fields of a record 
            
           * Fields may be tested for certain values before copying 
            
           * Additional records may be copied to an existing data file 
            
           * Fields from records of one data file may be combined with fields
             from records of another 
 
The data file that is to be copied from must, of course, already exist. 
The UDE data file that is to be copied into must be defined before the copy is
begun.  This is done with the UDE Define function.  Data may be copied into a
file with no existing data records or into one that already has data. 
 

========================================================================================
DOCUMENT :usus Folder:VOL26:ude.4.text
========================================================================================

   
1.7.1 Definition of terms 
 
      The following terms are used frequently in describing Copy Data File. 
       
   Data file -     A set of two files, one thats name ends with .SCRN and one
                   that ends with .TEXT, used by the UDE programs to store data.
                
   UDE SCRN file - A file created by the UDE Define program thats name ends with
                   .SCRN. This file contains all the necessary information 
                   describing the screen prompts and the size, number, type and 
                   length of data fields in a UDE data file. 
    
   UDE TEXT file - A file created by the UDE maintain program ending with .TEXT.
                   This file contains the actual data of a UDE data file,
                   arranged in records. 
    
   Data field -    The individual pieces of data that the user enters into the
                   UDE data file from the screen.  The user defines the
                   characteristics of a data field in the screen definition 
                   program which is described in Section 1.8. 
    
   Record -        All the data fields together on the screen make up one UDE
                   record.  A record may have up to forty data fields. 
    
   Field id -      The name given to a data field in the screen definition
                   program.  These names are used in the List, Sort and Copy 
                   routines. 
    
    
    
    
    
    
    
    
    
    
    
    
    
    
1.7.2 Screen definition requirements 
 
     Data from a field in one data file can be copied to a field in another
data file only if the two fields have the same field id.  This does not mean
that the screen definitions of the two data files must be identical.  Each of
the data files may contain field ids not present in the other, but only fields
common to both of the data files will be eligible for copying.  
 
   Data may be copied between two fields of different types as long as
the actual data to be copied is of the proper type.  For example, numeric data
from an alphanumeric type field may be copied to a numeric type field.  An error
message will be displayed and the program will terminate if an attempt is made
to copy improper type data to a field.  Data may also be copied between two
fields of different lengths.  If a field is not large enough to hold all of the
data being copied to it, the following prompt will appear: 
 
     One or more of the fields is not large enough to hold all of the 
     data being copied to it.  Proceed anyway? (Y/N): 
 
If the response is <Y>, as many characters as the field will hold will
be copied, starting from the left.  All excess characters on the right will be
ignored.  If the response is <N> the program will terminate.  This prompt
will be displayed only once during the execution of the program. 
 
1.7.3 Accessing the data files 
 
     Before the copy is started, the user will normally define a new UDE form
by using the UDE Define function.  After the new form has been defined, press a
<C> while in the main UDE display and the following screen appears: 
 
**************************************************************** 
 
                         COPY A DATA FILE 
                         ================ 
 
DATA FILE TO COPY FROM 
 
Volume   : ________
Name     : ____________
Type     :   SCRN and TEXT
 
 
DATA FILE TO COPY TO 
 
Volume   : ________
Name     : ____________
Type     :   SCRN and TEXT 
 
 
<ENTER> to execute, <ESC> to abort 
 
**************************************************************** 
 
 
 
 
 
 
 
 
 
 
 
 
    After entering the volume and name fields for each data file, press
<enter>.  If the program cannot find the "from" text file or either of the
files ending in .SCRN, an error message is displayed.  If the data file to be
copied to contains no TEXT file, the program asks if it should create one.  If
the answer is yes, the next prompt is: 
 
     Maximum number of records? _0__________
 
The absolute maximum number of records in a data file is 32767.  The maximum
number of records in the new TEXT file may be greater than, less than, or equal
to the number of records in the TEXT file to be copied from. 
 
1.7.4 Status messages 
 
     When the program begins copying, the following message will appear as
each record is copied: 
 
     STATUS: Copying record# X 
 
where X is the number of the record that data is currently being copied from. 
By watching the messages, the user will be able to estimate the amount of time
the copy will take.  The amount of time required is heavily dependent upon the
size and number of fields in the data file records.  When finished copying, the
program will display a message indicating the number of records copied.  If
there was not room to copy all records to the output file, the program will
display a message indicating the number of records copied before the output
file became full. 
 
1.7.5 Copying all fields of all records into a new data file 
 
     This section describes how to copy one data file, as is, into a new,
larger or smaller data file.  The user begins by either creating a new .SCRN
file with UDE Define, or, if the definition of the new file will be exactly
the same as the old, the Filer may be used to make a copy of the .SCRN file
into another file that ends in .SCRN. 
 
    Because this is a new data file, the user will be asked how many
records are to be in the data file; it will then create that many records in a
file thats name ends in .TEXT.  The program will display the following prompt: 
 
     Do you wish to copy all fields common to both data files? (Y/N): Y 
 
Since all fields are to be copied, press either <return> or <Y>.  The
next prompt will be: 
 
     Are fields to be tested for certain values before record 
     is copied? (Y/N):N 
 
Press either <return> or <N> since all records are to be copied.  The
following prompt will then appear: 
 
     Copy blank records? (Y/N): N 
 










In a UDE file, blank records are defined to be those records deleted with
the Delete function of the UDE maintain program or those records of a file
that have never been used.  If the reponse to the above prompt is a <Y>, the
program will copy blank records to the output file, if the response is an <N>
it will not.  If the data file being copied from has no blank (deleted) records
among the non-blank records, this operation will have no effect.  Upon
recieving a response to the above prompt the program will begin copying. 
 
 
 
























































1.7.6 Copying only certain fields into a new data file 
 
     To copy only certain fields of all records into a new data file, follow
this procedure.  Any fields that are not copied to will be left blank.  Again,
begin by defining a new .SCRN file with UDE Define.  Then begin the Copy
command and tell how many records are to be in the data file.  After creating
the new .TEXT file, the program will display the following prompt: 
 
     Do you wish to copy to all fields common to both data files? (Y/N): 
 
Press <N> and the following screen will appear: 
 
**************************************************************** 
 
The following fields are common to both data files. Indicate 
those fields whose information is to be copied (Y/N) 
 
FIELD1   Y     FIELD2   Y 
FIELD3   Y     FIELD4   Y 
    .              . 
    .              . 
    .              . 
 
 
 
 
 
 
<ENTER> to execute, <ESC> to abort 
 
**************************************************************** 
 
If the information in the field is to be copied into the new file, there
must be a Y in the the space next to the field id.  Otherwise the information
in that field will not be copied.  The remaining prompts will be the same as
those for copying all fields as described in section 1.7.5. 
 
























1.7.7 Copying only certain records into a new data file 
 
     The prompts are the same as those described in section 1.7.5 for copying
all fields.  Respond the same way but with one exception.  When the following
prompt appears: 
 
     Are fields to be tested for certain values before record 
     is copied? (Y/N): 
 
Respond <Y> and the following screen will appear: 
 
***************************************************************** 
 
Comparison tests to be made on fields of each record:     Choose from the 
                                                          following fields: 
FIELD ID  OPERATOR                VALUE 
 
________    ____     _______________________________
________    ____     _______________________________
________    ____     _______________________________
________    ____     _______________________________
________    ____     _______________________________
________    ____     _______________________________
________    ____     _______________________________
________    ____     _______________________________
________    ____     _______________________________
________    ____     _______________________________
________    ____     _______________________________
________    ____     _______________________________
________    ____     _______________________________

Valid operators are: < , > , = , <= , >= , or <> 

Currently viewing tests 1 - 13 

Get, Save tests, Change, Next, Back, Quit: 

***************************************************************** 
 
    Up to 52 tests can be performed on the fields of each record to
determine whether or not that record should be copied.  It should be emphasized
that these tests determine whether or not the record is copied, they do not
determine which fields of the record are copied.  Refer to section 1.7.6 for
instructions on indicating which fields of a record are to be copied.  The
operation of these tests is the same as that of the tests described in detail
in section 1.5.2.2 on the UDE List function. 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
   When all of the tests have been entered, press <Q>.  If two or more
tests have been entered the following screen will be displayed: 
 
***************************************************************** 
 
Copy each record if: 
 
1) All of the above tests have been met 
2) Any of the above tests has been met 
 
Enter 1 or 2 : 
 
***************************************************************** 
 
The user must respond correctly to the above prompt to get the desired
result.  Please refer to section 1.5.2.2 for an explanation of this prompt. 
 
    The remaining prompts in the series will be the same as those
described in section 1.7.5. 
 
1.7.8 Copying additional records to an existing data file 
 
     The program allows additional records to be appended to the end of an
existing UDE data file.  After the program accesses the data files, the
following prompt will be displayed: 
 
     Data file has existing records.  Do you wish to delete them? (Y/N): 
 
Enter an <N> so that the records will not be deleted.  The next prompt
will be: 
 
     Do you wish to add the new records at the end of the  
     data file? (Y/N): Y 
 
Press either <return> or <Y>.  The additional records will be copied
to a location in the data file just after the last non-blank record
(regardless of any blank records that are mixed in with the non-blank records).
 Blank records are defined to be those records deleted with the Delete
function of UDE Maintain or those records of a file that have never been used. 
 
    The remaining prompts will be the same as those described in section
1.7.5.  If there is not enough room to copy all records to the file, a message
will be displayed indicating the number of records copied before the file
became full. 
 
1.7.9 Merging selected fields into an existing data file 
 
     The program will allow data to be copied to selected fields of an
existing UDE data file, leaving those fields not copied into undisturbed.  Be
very careful when using this feature.  When using the program for this
purpose, the user should be sure that each record to be copied from the first
data file will merge with the proper record from the second data file. 
 
    
    
    
    
    
    
    
    
    
    
    After accessing the data files, the program will display the same two
prompts as described in the section on copying additional records to an
existing data file, section 1.7.8 above.  Respond with an <N> to both of the
prompts and the following note will appear: 
 
     NOTE: Any fields of the existing data file that are not copied to will 
     be left intact.  Do you wish to proceed? (Y/N): 
 
Press <Y> to continue, <N> to terminate the program.  The remaining
prompts will be the same as those described in section 1.7.5.  Respond as
necessary to copy the desired fields and records to the existing data file. 
 
1.7.10 Deleting unwanted records from a data file 
 
     The program may be used to remove unwanted records by copying to and from
the same UDE data file.  After accessing the data files, the program will
display the following prompt: 
 
     Data file being copied to has existing records.  Do you wish to delete 
     them? (Y/N): 
 
It is appropriate to respond <Y> to this prompt even when copying to
and from the same data file.  None of the original records of the file will be
deleted until all of the desired records have been copied.  The program copies
the new records to the beginning of the data file, writing over any of the
original records.  Only after copying all of the desired records are the
remaining original records deleted.  Refer to section 1.7.7 for instructions on
testing fields of records for certain values. 
 
Warning: Copying to and from the same file is a dangerous operation.  It 
         is not possible to recover accidentally deleted records. 
 
See section 1.7.4 for an explanation of the STATUS messages displayed while the
program is copying. 
 
 


 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
1.8 DEFINING A SCREEN FORMAT 
 
1.8.1 Introduction 
 
     The define program may be run by executing the file SD/DEFINE.CODE. 
This program will allow the user to define an input mask by entering a
description of the input fields required and their position on the screen. 
This definition also serves as the model for creating data files in the
Universal Data Entry program. 
 
1.8.1.1 Main Option Menu 
 
 
                               SCREEN DEFINITION 
                               ================= 
                                 Version IV.0 
                                        
                                        
                        Clear current screen definition 
                        Edit screen definition file 
                        Get old screen definition file 
                        Print screen definition file 
                        Quit 
                        Save current screen definition 
 
 
     SELECTION : _
 
     The Define program has a Main menu that allows access to the various
functions neccessary to define, maintain, and store a screen definition file. 
The bold capital letters in the Main menu and lower level prompt lines indicate
the keys which must be pressed to execute the options at that level.  A
description of each function follows. 
 
1.8.2 Clear current screen definition
 
     Pressing the <C> key from the Main menu clears all files and variables
in the define program as if the user had just executed the program.  It is
recommended that users execute the clear function after saving a screen
definition before defining another. 


========================================================================================
DOCUMENT :usus Folder:VOL26:ude.5.text
========================================================================================

1.8.3 Edit screen definition file

1.8.3.1 Field definition input mask
 
     The Edit option uses the following Data Field input mask to input
information required for defining a data field: 
 
                               DEFINE DATA FIELD 
                               - - - - - - - - -

     Field ID Name            : _______   Auto Skip (T/F)         : _____
     Field Type (C/D/I/V)     : __        Justify (L/R/N)         : __
     Row / Column Number      : __/__     Alpha-Numeric (A/L/N/S) : __
     Field Length             : __        Minimum Input           : ___
     Default/Calculation : ________________________
 
 
     The field ID name is a mnemonic used to identify the various data fields
in a screen definition file.  The ID name may be any combination of 8 letters
or numbers but must be unique for each data input field. 
 
     The auto skip option determines whether the cursor should automatically
skip to the next field in the screen file when the last character in that
field is input or whether the cursor should stop on that last character and
signal that the end of the field has been reached by ringing the alarm bell. 
 
     A data field may be one of four possible types: Calculation,
Duplicate, Index, Variable.  A Variable field allows the information in
the the field to vary as the user likes.  An Index field allows the field
value to vary.  Some programs, such as the Data Base Manager, use this field as
an index into the data base, requiring that the value of this field be unique
for each record.  A Duplicate field is an index field that is not required to
be unique for the data base.  A Calulation field does not allow input but
reflects the result of a numeric expression involving other numeric data fields
in the file.  All fields in a screen definition file should be Variable
unless another type is specifically required. The default field type is
Variable. 
 
     The data field contents may be displayed right or left justified within
the field by specifying jusification as Left, Right, or None.
Numeric fields are usually right justified while alphabetic fields are
normally left justified.  Be aware that justification of numbers, especially
decimal values, may affect sorting. 
 
     The row and column numbers indicate the location of the field on the
console screen and are restricted by the console screen size.  Row numbers are
normally between 0 and 23 inclusive while column numbers are between 0 and 79
inclusive. 
 
    Information accepted by the data field may be restricted by
specifying the input type as follows: 
 
          Alphanumeric - Accepts any Numeric or Letter character. 
          Numeric - Accepts number 0-9,a decimal point, or a plus or minus sign.
          Letters - Accepts letters of the alphabet, a hyphen, or a period. 
          Special - Accepts any character on the keyboard except vector keys. 
 
 
 
 
 
 
 
     The field length indicates the maximum number of characters the field may
accept.  The maximum data field length is forty(40), the default is zero(0). 
The user may also specify the minimum number of characters the field must
accept which may not be less than zero or more than the field length.  The
default minimum is zero (0). 
 
     The user may specify a constant default value for the Variable, Index, and
Duplicate fields by entering a string whose length is less than the maximum
field length in the Default/Calculation input field. The value of another data
field may be used as the default by entering the name of the default field
enclosed in square brackets in the Default/Calculation input field instead of a
constant default string.  Numeric expressions for Calculation fields may be any
valid algebraic expression using the four basic operators: addition (+),
subtraction (-), multiplication (*), and division (/), the ID names of any
numeric data fields in the current file, numeric constants, and parenthesis.
The value of a data field ID name in the expression is assumed to be zero if
the data field ID name is not a member of the screen file or is not a valid
number. 
 
     When all the necessary information has been entered, the user may press
the <ENTER> key to return to the edit option level.  If the <ESC> key is
pressed, the information entered is ignored and the previous field definition
is redisplayed. 
 
1.8.3.2 Prompt definition input mask
 
                              DEFINE PROMPT FIELD 
                              - - - - - - - - - -
 
          Prompt Number : __
          Row Number    : __
          Column Number : __
          Prompt : __________________________________________
 
 
     The prompt definition input screen functions similarly to the data field
definition input screen.  The prompts are numbered according to their positions
on the console screen and may be referenced by this number. 
 
     The row and column numbers indicate the location of the prompt field on
the console screen and are restricted by the console screen size.  Row numbers
are normally between 0 and 23 inclusive while column numbers usually are
between 0 and 79 inclusive. 
 
     The prompt text may be any string of up to forty(40) characters.  Prompt
fields may be used for any purpose the user desires (i.e. as prompts for data
fields, titles, borders, or decoration).  They do not affect the value of the
data fields in any manner but may affect their display if their locations
overlap.  Pressing the <ENTER> key returns the user back to the edit option
prompt line.  Pressing the <ESC> key causes the information to be erased and
replaced with the previously displayed prompt field definition. 
 
 
 
 
 
 






1.8.3.3 Edit options
 
     The input mask displayed on the screen at run time indicates whether the
user is in the Field or Prompt mode.  Just below either one is the edit
prompt line whose bold letters indicate which keys must be pressed to execute
the various edit options.  The edit prompt line appears as follows : 
 
          Upper Field  Add    Back Examine Test 
          Lower Prompt Delete Next Change  Quit: 
 
The edit options are described as follows: 
 
            Add -   Instructs the program to add the prompt or field definition
                    shown to the screen definition file. 
                    
            Back -  Displays the previous prompt or field definition. 
             
            Change - Allows the user to change the prompt or field definition
                    shown. 
                      
            Delete - Instructs the program to search for the ID name or prompt
                    number shown and remove it from the screen definition file.
                    However, the field or prompt definition remains on the
                    screen, allowing the user to change it and then add it 
                    back to the file. 

            Examine - Instructs the program to display the definition of the
                    ID name or prompt number currently showing on the console
                    screen.  (i.e. Press the <C> key, change the field name, 
                    press the <ENTER> key, then press the <E> key to examine 
                    the field definition for the ID name just entered). 
                     
            Field - Instructs the program to display the field definition input
                    mask. 
                      
            Lower - Instructs the program to position the field or prompt input
                    mask on the upper half of the console screen thus allowing
                    the user to view the lower half of the screen file 
                    currently being defined. 
         
            Next -  Displays the next prompt or field definition.
              
            Prompt - Instructs the program to display the prompt definition
                    input mask. 
                     
            Quit -  Instructs the program to return to the Main menu level.
              
            Test -  Allows the user to see how the screen definition file will 
                    run when used by an outside program.  The input mask is 
                    removed from the console screen and the user may test the 
                    current screen definition.  When the <ENTER> or <ESC> key 
                    is pressed the input mask is redisplayed and more prompts or
                    fields may be added, changed or deleted. 
                     
            Upper - Instructs the program to position the field or prompt input
                    mask on the lower half of the console screen thus allowing 
                    the user to view the upper half of the screen file 
                    currently being defined. 
 
 
 
 
 
 
 
1.8.4 Get old screen defintion
 
     When the <G> key is pressed at the Main menu level the following screen
will be displayed: 
 
                             GET SCREEN DEFINITION 
                            ======================= 
 
 
                         Volume    :  _______ 
                         File      :  __________ 
                         Type      :  SCRN 
 
 
 
          <ENTER> to execute,<ESC> to abort 
 
The cursor will be placed at the begining of the Volume input field, the user
may then change the file information on the screen.  Pressing the <ENTER> key
causes the program to locate the file specified and copy its contents into a
temporary file that may be edited.  If the file is found and the copy
successful, the program will return to the Main menu level after displaying the
message : 
 
                             STATUS: File loaded. 
 
Otherwise an error message will be displayed explaining the problem in finding
or copying the file.  If the <ESC> key is pressed, the program returns to the
Main menu level. 
 
 






























1.8.4.1  Screen Definition Example
 
     The following is an example of the inputs normally required to create,
test, and update an input screen definition file: 
 
(1)     Press the <E> key from the Main menu to Edit the screen
        definition.  The Data Field input mask will be displayed on the upper
        half of the screen, the lower half should be blank. 
         
(2)     Press <C> key to change the field definition.  The cursor will be
        placed in the first input field. 
         
(3)     Enter the Data Field definition as follows: 
        <F> <I> <R> <S> <T> <RETURN>  {Identifies the field name as "FIRST".} 
        <TAB> <L> <RETURN>  {Uses default field type of Variable and sets
        justification (left).} 
        <space> <4> <TAB>  {Sets field row location.} 
        <space> <8> <TAB>  {Sets field column location.} 
        <A> <RETURN>  {Requires alphabetic input only.} 
        <1> <0> <TAB>  {Allows up to 10 characters input but uses default
        minimum of zero and default value of blanks.} 
        <ENTER>  {returns to the edit option prompt line.} 
         
(4)     Press the <A> key to Add the field to the current screen definition
        file. 
 
(5)     Press the <U> key to show the upper half of the current screen
        definition file.  The field previously defined will appear on the forth
        row and the eighth column as fifteen blanks represented by underscores.
        The Data Field definition input mask will be displayed on the lower 
        half of the console screen. 
         
(6)     Press the <P> key to display the Prompt Field definition input mask
        on the lower half of the screen. 
         
(7)     Press the <C> key to change the prompt definition shown (blank). 
 
(8)     Enter the Prompt Field definition as follows: 
        <RETURN>  {Prompt field number is not required.} 
        <space> <4> <RETURN>  {Sets row location.} 
        <space> <0> <RETURN>  {Sets column location.} 
        <N> <A> <M> <E> <space> <:> <ENTER>  {Inputs prompt text and returns to
        edit option prompt line.} 
 
(9)     Press the <A> key to add the prompt field to the current screen
        definition file.  The prompt will be displayed at the row and column 
        location defined. 
         
         
         
         
         
         
         
         
         
         
         
         
         
         
         
         
         
(10)    Enter the rest of the prompt field definitions.  Press the <C>
        key to change the information as before and then the <ERASE INPUT> and 
        <RETURN> keys; enter the location and text as follows: 
 
                           Row  Column     Prompt 
                            5      0      GREETING: 
                            6      0      COMPANY : 
                            7      0      ADDRESS : 
                            8      0      CITY : 
                            8     22      STATE : 
                            8     34      ZIP : 
                           10      0      ITEM OF INTEREST : 
 
(11)    Press the <F> key to display the Data Field definition input
        mask on the lower half of the screen.  The upper half of the console
        screen should still show the prompts and data field previously defined. 
 
(12)    Enter the rest of the data field descriptions.  Press the <C> key to 
        change the information as before and then the <ERASE INPUT> key; enter 
        the information as follows: 
         
                ID Name      Just.     Row/Col.  A/L/N/S   Length  
                   LAST        L       4 / 26     L          15 
                   GREET       L       5 / 10     L          20
                   CONAME      L       6 / 10     S          15 
                   ADDR        L       7 / 10     S          20 
                   CITY        L       8 / 10     L          10 
                   STATE       N       8 / 30     L           2 
                   ZIP         R       8 / 39     N           7 
                   ITEM        L      10 / 15     S          15 
                                        
                                        
(13)    To change the default in GREETING to contain the value of "FIRST: " 
        <C>  {Puts the cursor on the first data field definition input field.} 
        <ERASE INPUT>  {Clears input mask.} 
        <G> <R> <E> <E> <T>  <ENTER>  {Identifies field and returns to edit
        option prompt line.} 
        <E>  {Examines data field.  The lower half of the console screen should
        now show the definition of the GREET field.} 
        <D>  {Deletes the field from the screen file.} 
        <C>  {Puts the cursor on the first Data Field definition input field.} 
        <RETURN> <RETURN>  
        <RETURN>  {Moves cursor to default/calculation input field.} 
        <[> <F> <I> <R> <S> <T> <]>  <ENTER>  {Sets the default to the value of
        FIRST.} 
        <A>  {Adds the new field definiton back into the current screen file.} 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
(14)    To change the "NAME :" prompt: 
        <P>  {Displays the Prompt Field definition input mask.} 
        Press the <N> and/or <B> keys until the "NAME :" prompt definition is
        displayed. 
        <D>  {deletes the prompt from the current screen definition file.} 
        <C>  {Puts the cursor on the first input field in the Prompt Field
        definition input mask.} 
        <RETURN> <RETURN> 
        <RETURN>  {Moves the cursor to the prompt text input field.} 
        Insert four (4) blanks just before the colon using the <right arrow> to
        position the cursor and the <INS CHAR> key to insert the blanks. 
        <ENTER>  {Returns to the edit option prompt line.} 
        <A>  {Adds the new prompt back into the current screen file.} 
         
(15)    The console screen should now look like this: 
 
 
 
        NAME      : _______  ___________
        GREETING  : _______________
        COMPANY   : ___________
        ADDRESS   : ______________
        CITY      : _______  STATE :___ ZIP : _______

        ITEM OF INTEREST : ________________


                              DEFINE PROMPT FIELD
                              - - - - - - - - - -

        Prompt Number  :_1
        Row Number     :_4
        Column Number  :_0
        Prompt : NAME__:_______________


        Upper Field  Add    Back  Examine Test
        Lower Prompt Delete Next  Change  Quit: A

 
(16)    Pressing the <F> key will cause the console screen to
        look like this: 
         
         
         
        NAME      : ______  ___________
        GREETING  : ______________
        COMPANY   : ___________
        ADDRESS   : ______________
        CITY      : _______  STATE :___ ZIP : _______

        ITEM OF INTEREST : _________________



========================================================================================
DOCUMENT :usus Folder:VOL26:ude.6.text
========================================================================================



                               SCREEN DEFINITION
                               - - - - - - - - -
         
        Field ID Name            : ZIP_____    Auto Skip (T/F)          : F
        Field Type (C/D/I/V)     : V           Justify (L/R/D)          : R
        Row / Column Number      : _7/ 39      Alpha-Numeric (A/N/D)    : N
        Field Length             : _7          Minimum Input            : _0
        Default/Calculation : ______________________________
         
        Upper Field  Add    Back  Examine Test 
        Lower Prompt Delete Next  Change  Quit: F 
         
         
(17)    Pressing the <T> key will erase the Data Field Definition
        input mask from the console and allow input into the current screen 
        definition file until the <ENTER> or <ESC> key is pressed. 
 
(18)    Pressing the <Q> key returns the user back to the Main menu level. 
 
1.8.5  Print screen definition file

1.8.5.1 Printing the current screen definition
     When the <P> key is pressed at the Main menu, the program will ask: 
 
          Printer width (80/132):132 
 
The user should then enter the number of characters the line printer is
capable of printing on one line.  One hundred-thirty two (132) characters is
assumed.  The current screen definition will then be sent to the line printer.
When the printout is complete, the user is returned to the Main menu level. 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
1.8.6 Quit
 
     When the <Q> key is pressed from the Main menu level the user is
returned to the System command line.  The current temporary file will be lost
unless the save option is used prior to the exit.  To prevent the user from
accidentially leaving the program before saving the current file, the program
will ask: 
 
          Do you want to save the current definition file? 
 
The user may then press the <Y> key to save the file or the <N> key to
leave the program. 
 
1.8.7  Save current screen definition file
 
     When the <S> key is pressed at the Main menu level the following screen
will be displayed: 
 
                            SAVE SCREEN DEFINITION 
                           ======================== 
 
 
               Volume    :  _______
               File      :  ___________
               Type      :  SCRN
 
 
 
     <ENTER> to execute,<ESC> to abort 
 
The user may now change the file information shown on the screen.  Pressing the
<ENTER> key causes the program to copy the current temporary file onto the
volume and file specified.  If a file by the name specified already exists its
contents will be replaced by the current temporary file.  If the copy is
successful, the program will return to the Main menu level after displaying the
message : 
 
          STATUS: File saved. Total length : ##. 
 
Otherwise an error message will be displayed explaining the problem in copying
the file.  If the <ESC> key is pressed the program returns to the Main menu
level. 


========================================================================================
DOCUMENT :usus Folder:VOL26:ud_copy.code
========================================================================================

< binary file -- not listed >

========================================================================================
DOCUMENT :usus Folder:VOL26:ud_list.code
========================================================================================

< binary file -- not listed >

========================================================================================
DOCUMENT :usus Folder:VOL26:ud_list.scrn
========================================================================================

< binary file -- not listed >

========================================================================================
DOCUMENT :usus Folder:VOL26:ud_maint.code
========================================================================================

< binary file -- not listed >

========================================================================================
DOCUMENT :usus Folder:VOL26:ud_sort.code
========================================================================================

< binary file -- not listed >

========================================================================================
DOCUMENT :usus Folder:VOL26:ud_sort.scrn
========================================================================================

< binary file -- not listed >

========================================================================================
DOCUMENT :usus Folder:VOL26:ud_ude.code
========================================================================================

< binary file -- not listed >

========================================================================================
DOCUMENT :usus Folder:VOL26:userlib.text
========================================================================================

sh.screen.code

========================================================================================
DOCUMENT :usus Folder:VOL26:vol26.doc.text
========================================================================================

                                 USUS Volume 26
               Universal Data Entry Documentation and Code Files
                            -->Version VI.x ONLY<--
                              
                              Sources on Volume 25

VOL26:
UD.INTRDOC.TEXT   16 UDE Documentation
UDE.1.TEXT        32 
UDE.2.TEXT        26 
UDE.3.TEXT        32 
UDE.4.TEXT        34 
UDE.5.TEXT        32 
UDE.6.TEXT         8 
SD/DEFINE.CODE    30 UDE Sub-programs
SH.SCREEN.CODE    21 
UD.SORT.CODE      45 
UD/COPY.CODE      41 
UD/LIST.CODE      39 
UD/MAINT.CODE     23 
UD/SORT.CODE      25 
UD/UDE.CODE        3 UDE Main Program
SH/SCREEN.UNIT    21 A necessary unit
USERLIB.TEXT       4 Install this as your USERLIB.TEXT
UD/LIST.SCRN       8 A couple of data files
UD/SORT.SCRN       8 
README.1ST         8 Read this FIRST!!!
VOL26.DOC.TEXT     6 You're reading it
---------------------------------------------------------------------------
Please transfer the text below to a disk label if you copy this volume.

    USUS Volume 26 -***- USUS Software Library
                         
   For not-for-profit use by USUS members only.
  May be used and distributed only according to 
      stated policy and the author's wishes.



This volume was assembled by George Schreyer from material collected by
the Library committee.
__________________________________________________________________________





========================================================================================
DOCUMENT :usus Folder:VOL27:ff.basics1.text
========================================================================================

SEGMENT PROCEDURE SETPREFIX;
VAR  ANS: INTEGER;
BEGIN
  REPEAT
    IF DISKDRIVE = '' THEN ANS := -1
    ELSE VALUE(TRUE,COPY(DISKDRIVE,2,LENGTH(DISKDRIVE)-1),FAKE,ANS);
    (*$B 40COL- *)
    GETNUM(4,30,ANS,'Enter Prefix Disk Drive # ',ANS)
    (*$E 40COL  *)
    (*$B 40COL+ *)
    GETNUM(4,30,ANS,'Enter Prefix Drive # ',ANS)
    (*$E 40COL  *)
  UNTIL ANS IN [4,5,9..30];
  ENCODE(ANS,DISKDRIVE);
  DISKDRIVE := CONCAT('#',DISKDRIVE)
END;   (* of setprefix *)

SEGMENT PROCEDURE PRINT_MENU;     (* Prints main menu to screen *)
BEGIN
  {WRITE(OUTPUT,CLEAR);}
  sc_clr_screen;
  
  MEMORY;
  
  WRITELN(OUTPUT);
  
  WRITELN(OUTPUT);
  WRITELN(OUTPUT);
  (*$B 40COL- *)
  WRITELN(OUTPUT,'F R E E F O R M   The Electronic Worksheet  [F.4reals]');
  WRITELN(OUTPUT,'==========================================');
  WRITELN(OUTPUT,'                              ',VERSIONDATE);
  (*$E 40COL  *)
  (*$B 40COL+ *)
  WRITELN(OUTPUT,'FREEFORM  The Electronic Worksheet [F.4]');
  WRITELN(OUTPUT,'========================================');
  WRITELN(OUTPUT,'                            ',VERSIONDATE);
  (*$E 40COL  *)
  WRITELN(OUTPUT);
  WRITELN(OUTPUT);
  WRITELN(OUTPUT,'    0. Data Entry Procedure');
  WRITELN(OUTPUT,'    1. Define new FORM controls');
  WRITELN(OUTPUT,'    2. Modify FORM controls');
  WRITELN(OUTPUT,'    3. Display or List directory');
  WRITELN(OUTPUT,'    4. Display or List FORM controls');
  WRITELN(OUTPUT,'    5. Consolidate Procedure');
  WRITELN(OUTPUT,'    6. Roll a FORM');
  WRITELN(OUTPUT,'    7. Copy a FORM');
  WRITELN(OUTPUT,'    8. Delete a FORM');
  WRITELN(OUTPUT,'    9. Help and User''s Guide');
END;     (* of print_menu *)


SEGMENT PROCEDURE CHOOSE_OPTION;       (* Elect desired option *)
BEGIN
  REPEAT
    (*$B 40COL- *)
    GETRESPONSE(TRUE,'Enter desired option #  ','',
                '       Press ESC to leave',1,IS);
    (*$E 40COL  *)
    (*$B 40COL+ *)
    GETRESPONSE(TRUE,'Enter option #  ','','  Press ESC to exit',1,IS);
    (*$E 40COL  *)
    IF (IS='@') THEN IS := '10';       (* Debug switch, char is @  SDA 11/17 *)
    IF (IS='P') OR (IS='p') THEN IS := '11';
  UNTIL (IS='0') OR (IS='1') OR (IS='2') OR (IS='3') OR (IS='4')
   OR (IS='5') OR (IS='6') OR (IS='7') OR (IS='8') OR (IS='9') OR (IS='10')
     OR (IS='11') OR (IS='ESCAPE');
  IF IS='ESCAPE' THEN 
    BEGIN
      PROMPT('Returning to Pascal O/S',MSG_LINE);
      EXIT(FREEFORM);
    END;
  VALUE(TRUE,IS,FAKE,OPTION);
END;     (* of choose_option *)

(*$R- *)
SEGMENT FUNCTION FIGURE{ VAR Z: NUMBERTYPE; X, Y: NUMBERTYPE;
                                                           OP: CHAR ): BOOLEAN};
(*                      Dale  Ander   May  28,  1980
     This Function calculates Z given X and Y and the operation in Op.  If an
     overflow occurs it returns false and sets Z to OVERFLOW.  Otherwise it
     returns true.
*)
VAR
     ANS: BIGNUMTYPE;
     I, POWER: INTEGER;

PROCEDURE LEAVE(ANS: NUMBERTYPE);
BEGIN
  Z := ANS;
  FIGURE := ANS <> OVERFLOW;
  EXIT(FIGURE)
END;

BEGIN
  (* Look for special math cases  SDA 11/13/80 *)
  IF (X = OVERFLOW) OR (Y = OVERFLOW) THEN LEAVE(OVERFLOW) ELSE
  IF (X = EMPTY) AND (Y = EMPTY) THEN      LEAVE(EMPTY)    ELSE
  IF Y = EMPTY THEN
    IF (OP = '+') OR (OP = '-') THEN Y := 0 ELSE LEAVE(EMPTY) ELSE
  IF X = EMPTY THEN
    IF (OP = '+') OR (OP = '-') THEN X := 0 ELSE LEAVE(EMPTY);
  
  CASE OP OF
    '=': ANS := Y;
    '+': ANS := X + Y;
    '-': ANS := X - Y;
    '*': ANS := X * Y;
    '/': IF Y <> 0 THEN ANS := X / Y ELSE ANS := MAX;
    'S': ANS := SIN( Y );
    'C': ANS := COS( Y );
    'T': BEGIN
           X := COS( Y );
           IF X <> 0 THEN ANS := SIN( Y ) / X  ELSE  ANS := MAX
         END;
    'A': ANS := ATAN( Y );
    'L': IF Y > 0 THEN ANS := LOG( Y ) ELSE ANS := MAX;
    'N': IF Y > 0 THEN ANS := LN ( Y ) ELSE ANS := MAX;
    '^': BEGIN
           IF ABS(Y) > MAXINT THEN ANS := MAX (* Will not take power *)
           ELSE
             IF Y = 0 THEN ANS := 1
             ELSE
               BEGIN
                 POWER := TRUNC( ABS(Y) );
                 I := 1;
                 ANS := X;
                 WHILE (I < POWER) AND (ANS < MAX) DO
                   BEGIN
                     ANS := ANS * X;
                     I := I + 1
                   END;
                 IF Y < 0 THEN ANS := 1 / ANS
               END
         END
  END;
  IF (ANS >= MAX) OR (-ANS >= MAX) THEN LEAVE (OVERFLOW) ELSE LEAVE (ANS)
END  (* of figure *);
(*$R^ *)

(*$R- *)
SEGMENT PROCEDURE NUMTOSTR { VAR ANS: ASTRING;  NUM: NUMBERTYPE;
                       BEFORE, AFTER: INTEGER              };
(*                   Dale  Ander    Mar  27,  1981
     Numtostr takes the Real number in Num and creates a string representation
     of it and puts this string into Ans.  The form of the string is dependant
     upon the values of Before and After.  Before is the number of digits
     to put before the decimal point and After is the number after.
*)
VAR
     MAGNITUDE, ROUND: NUMBERTYPE;
     I, L, PT, PLACES, ORDZERO: INTEGER;
     NEGATIVE, MINUSZERO: BOOLEAN;
     SIGN: CHAR;

BEGIN
  IF NOT (BEFORE IN [1..MAXWHOLE]) THEN BEFORE := MAXWHOLE;
  BEFORE := BEFORE+1;  (* Allow room for Sign *)
  IF NOT (AFTER  IN [0..MAXFRAC])  THEN AFTER  := MAXFRAC;

  IF NUM = EMPTY THEN  (* return a dash !  SDA 11/13/80 *)
    BEGIN
    { Old way of doing things              SDA 04/02/81
      ANS := COPY(BLANKS,1,BEFORE+AFTER+1);
      IF AFTER > 0 THEN ANS := CONCAT(ANS,' ');  (* blank for dec pt    *)
      ANS[LENGTH(ANS)-1] := '-';   (* put dash in next to last position *)
      and the New way
    } 
      IF AFTER > 0 THEN PT := BEFORE + AFTER + 2 ELSE PT := BEFORE + AFTER + 1;
      FILLCHAR(ANS[1],PT,' ');
      ANS[PT - 1] := '-';
      ANS[0] := CHR( PT );
      
      EXIT(NUMTOSTR)
    END;
  
  NEGATIVE := NUM < 0;
  
  (* Round off NUM to precision neccessary, make NUM positive and set SIGN *)
  ROUND := 0.5 / PWROFTEN( AFTER );
  IF NEGATIVE THEN
    BEGIN  SIGN := '-';  NUM := NUM - ROUND;  NUM := ABS( NUM )  END
  ELSE
    BEGIN  SIGN := ' ';  NUM := NUM + ROUND                      END;

  (* Get all the significant digits to the left of the decimal point *)
  NUM := NUM * PWROFTEN( AFTER );

  (* Get NUMs order of magnitude *)
  PLACES := MAXWHOLE + AFTER - 1;
  WHILE ( PWROFTEN( PLACES ) > NUM ) AND ( PLACES > 0 ) DO PLACES := PLACES - 1;

  ORDZERO := ORD('0');  PT := 1;
  ANS[1] := SIGN;
  FOR I := PLACES DOWNTO 0 DO
    BEGIN
      MAGNITUDE := PWROFTEN( I );
      L := TRUNC( NUM / MAGNITUDE );  (* Get digit at that pwr of 10 *)
      PT := PT + 1;
      ANS[PT] := CHR( L + ORDZERO );  (* Put the digit into Ans      *)
      NUM := NUM - ( L * MAGNITUDE)   (* Remove the digit from Num   *)
    END;
  ANS[0] := CHR(PT);                  (* Set the length byte in Ans  *)

  L := LENGTH( ANS ) - AFTER;
  PT := 2 - L;
  IF PT > 0 THEN                      (* Need to insert leading zeros *)
    BEGIN
    { The old way                        SDA 4/2/81
      INSERT( COPY( ZEROS, 1, 3-L ), ANS, 2);
      and the new
    }
      PLACES := LENGTH( ANS );
      MOVERIGHT(ANS[2],ANS[PT+2],PLACES);
      FILLCHAR( ANS[2],PT,'0');
      ANS[0] := CHR( PLACES + PT );

      L := LENGTH( ANS ) - AFTER
    END;

  PT := BEFORE - L;
  IF PT > 0 THEN                        (* insert leading blanks *)
    BEGIN
      { The old way
      INSERT( COPY( BLANKS, 1, BEFORE-L+1), ANS, 1 )
        and the new
      }
      PLACES := LENGTH( ANS );
      MOVERIGHT(ANS[1],ANS[PT+1],PLACES);
      FILLCHAR( ANS[1],PT,' ');
      ANS[0] := CHR( PLACES + PT )
    END
  ELSE
    (* if field given not wide enough for number then return *'s *)
    IF PT < 0 THEN
      BEGIN
        { The old way
        ANS := COPY( STARS, 1, BEFORE+AFTER );
          and the New
        }
        FILLCHAR(ANS[1],BEFORE+AFTER,'*');
        ANS[0] := CHR( BEFORE + AFTER )
      END;

  IF NEGATIVE THEN          (* look for -0 case *)
    BEGIN
      I := 1;
      L := LENGTH(ANS);
      REPEAT
        I := I + 1;
        MINUSZERO := ANS[I] In ['0',' ','-']
      UNTIL (I=L) OR NOT MINUSZERO;
      IF MINUSZERO THEN ANS[ POS('-',ANS) ] := ' '
    END;

  IF AFTER > 0 THEN        (* put in decimal point *)
    BEGIN
      { The old way
      INSERT( '.', ANS, LENGTH( ANS )-AFTER+1 );
        and the New
      }
      PT := LENGTH( ANS ) - AFTER + 1;
      MOVERIGHT(ANS[PT],ANS[PT+1],AFTER);
      ANS[PT] := '.';
      ANS[0] := CHR( LENGTH( ANS ) + 1 )
    END
END;  (* of numtostr *)
(*$R^  *)

SEGMENT PROCEDURE MOVEFORMDATA { AROW: BOOLEAN;  PAGE, SOURCE, DEST: INTEGER };
VAR
     I: INTEGER;
     ANUM: NUMBERTYPE;
     ERR: BOOLEAN;

BEGIN
  WITH DIRECTORY^ DO
    IF AROW THEN
      FOR I := 1 TO NO_COLS DO
        BEGIN
          NUMBER(FORM_DAT_FILE,FORM_DAT_DESC,PAGE,SOURCE,I,ANUM,ANDGET,ERR);
          NUMBER(FORM_DAT_FILE,FORM_DAT_DESC,PAGE,DEST  ,I,ANUM,ANDPUT,ERR)
        END
    ELSE
      FOR I := 1 TO NO_ROWS DO
        BEGIN
          NUMBER(FORM_DAT_FILE,FORM_DAT_DESC,PAGE,I,SOURCE,ANUM,ANDGET,ERR);
          NUMBER(FORM_DAT_FILE,FORM_DAT_DESC,PAGE,I,DEST,  ANUM,ANDPUT,ERR)
        END
END;   (* of moveformdata *)

SEGMENT PROCEDURE SETPRINTER;
BEGIN
  IF NOT PRINTER_ON THEN
    BEGIN
      UNITCLEAR( 6 );              (* Addition  SDA  12/16/81 *)
      REWRITE(PRINTER,'PRINTER:');
      PRINTER_ON := IORESULT = 0;
    END;
  IF PRINTER_ON THEN
    BEGIN
      GETNUM(1,999,PAPER_LENGTH,'How many lines long is the paper ?',
                     PAPER_LENGTH);
      (*$B 40COL- *)
      PRESSRETURN('Set Printer Alignment, then',MSG_LINE)
      (*$E 40COL  *)
      (*$B 40COL+ *)
      PRESSRETURN('Align Printer paper then',MSG_LINE)
      (*$E 40COL  *)
    END
  ELSE  ERROR(3)
END;

SEGMENT FUNCTION DISK_DIR{: BOOLEAN};
(* Returns true if it finds a freeform directory and returns false and sets
   Quit to true if it doesn't find a directory.
*)
VAR  ANS: INTEGER;
BEGIN
  REPEAT
    QUIT := FALSE;
    OPEN_DIR;
    IF NOT FILEOPEN THEN
      BEGIN
        ERROR(6);
        QUIT := NOT YESNO('Try another disk','Y');
        IF NOT QUIT THEN
          BEGIN     (* prompt to insert another disk *)
            REPEAT  (* Changed range of legal drive numbers  SDA 4/6/81 *)
              GETNUM(4,30,-1,'Enter Disk Drive # ',ANS)
            UNTIL ANS IN [4,5,9..30];
            ENCODE(ANS,DISKDRIVE);  DISKDRIVE := CONCAT('#',DISKDRIVE);
            (*$B 40COL- *)
            PRESSRETURN(CONCAT('Insert FREEFORM disk in drive ',DISKDRIVE,
               ' and'),MSG_LINE);
            (*$E 40COL  *)
            (*$B 40COL+ *)
            PRESSRETURN(CONCAT('Put disk in ',DISKDRIVE,' and'),MSG_LINE);
            (*$E 40COL  *)
            sc_clr_screen;
            {WRITE(OUTPUT,CLEAR);}
          END;
      END;     (* IF NOT FILEOPEN *)
  UNTIL FILEOPEN OR QUIT;
  DISK_DIR := FILEOPEN
END;     (* of disk_dir *)

SEGMENT FUNCTION NAME_FORM{ VAR REQUESTED_FORM: STRING;
                                  VAR RECNUMBER: INTEGER ): BOOLEAN };
(* Prompts for a form name and sets REQUESTED_FORM.  If it finds the form it
   returns true and sets RECNUMBER, otherwise it returns false and sets QUIT
   to true.  If possible it leaves directory^ pointing to requested record.
*)
VAR  DIRINDEX: INTEGER;

BEGIN
  NAME_FORM := FALSE;
  DIRINDEX := 0;
  WITH DIRECTORY^ DO
    REPEAT
      REPEAT
        (*$B 40COL- *)
        GETRESPONSE(FALSE,'Form Name (8 alpha max.)  ',REQUESTED_FORM,
        '                Press ESC to leave',L_NAME,REQUESTED_FORM);
        (*$E 40COL  *)
        (*$B 40COL+ *)
        GETRESPONSE(FALSE,'Enter Form Name  ',REQUESTED_FORM,
        '   ESC exits',L_NAME,REQUESTED_FORM);
        (*$E 40COL  *)
      UNTIL (REQUESTED_FORM<>'') AND (REQUESTED_FORM<>'INVALID');
      IF REQUESTED_FORM = 'ESCAPE' THEN                 (* SDA 4/21/81 *)
        BEGIN  REQUESTED_FORM := '';  QUIT := TRUE  END
      ELSE
        BEGIN  (* search for requested form *)
          LCTOUC(REQUESTED_FORM);
          QUIT := SEARCH(RECNUMBER,REQUESTED_FORM) AND (THEVERSION = VERSION);
          IF QUIT THEN
            BEGIN
              NAME_FORM := TRUE;
              PROMPT(CONCAT('Form Name is => ',REQUESTED_FORM),3);
            END
          ELSE
            BEGIN
              IF REQUESTED_FORM = '?' THEN   (* give a default from the dir *)
                BEGIN
                  QUIT := FALSE;
                  REPEAT
                    SEEKDIR(DIRINDEX,ANDGET);
                    REQUESTED_FORM := FORM_NAME;
                    IF REQUESTED_FORM = '' THEN DIRINDEX := 0
                    ELSE DIRINDEX := DIRINDEX + 1
                  UNTIL ( VERSION = THEVERSION ) OR ( REQUESTED_FORM = '' )
                END
              ELSE
                BEGIN
                  PROMPT(CONCAT('FORM named ',REQUESTED_FORM,' not found...'),
                         MSG_LINE-1);
                  QUIT := NOT YESNO('Try another FORM name','Y');
                  ERASE(MSG_LINE-1)
                END
            END
        END
    UNTIL QUIT
END;     (* of name_form *)

SEGMENT FUNCTION GET_FORM_NAME{ VAR REQUESTED_FORM: STRING
                                      VAR RECNUMBER: INTEGER): BOOLEAN };
(* This function will return true if it gets a form name that can go into
   the freeform directory.  It also returns the spot in the directory for
   the entry to go into.  Also sets the variable REQUESTED_FORM.
   If no form name is given or the directory is full then false is returned.
*)
VAR POS: INTEGER;
  
BEGIN    (* GET_FORM_NAME *)
  GET_FORM_NAME := FALSE;
  IF NOT SEARCH(RECNUMBER,'') THEN  (* no empty hole in directory *)
    ERROR(1)
  ELSE
    BEGIN
      REPEAT
        (*$B 40COL- *)
        GETRESPONSE(FALSE,'Form Name (8 alpha max.)  ',REQUESTED_FORM,
        '                Press ESC to leave',L_NAME,REQUESTED_FORM);
        (*$E 40COL  *)
        (*$B 40COL+ *)
        GETRESPONSE(FALSE,'Enter Form Name  ',REQUESTED_FORM,
        '   ESC exits',L_NAME,REQUESTED_FORM);
        (*$E 40COL  *)
      UNTIL (REQUESTED_FORM<>'') AND (REQUESTED_FORM<>'INVALID') AND
                         (REQUESTED_FORM<>'?');
      QUIT := REQUESTED_FORM = 'ESCAPE';       (* BUG FIX SDA 8/28/80 *)
      IF QUIT THEN REQUESTED_FORM := ''        (* SDA  4/21/81        *)
      ELSE
        BEGIN
          GET_FORM_NAME := TRUE;
          LCTOUC(REQUESTED_FORM);  (* make form name uppercase *)
          PROMPT(CONCAT('Form Name is => ',REQUESTED_FORM),3);
          (* Check for duplicate form on current diskette *)
          IF SEARCH(POS,REQUESTED_FORM) THEN  (* found duplicate *)
            BEGIN
              PROMPT(CONCAT('A FORM named ',REQUESTED_FORM,' already exists'),
                      MSG_LINE-1);
              IF YESNO('*** Replace existing FORM','N') THEN
                RECNUMBER := POS
              ELSE 
                GET_FORM_NAME := FALSE;
              ERASE(MSG_LINE-1)
            END
        END
    END
END;     (* of get_form_name *)



========================================================================================
DOCUMENT :usus Folder:VOL27:ff.basics2.text
========================================================================================

SEGMENT PROCEDURE ACCEPTNUM { ARROW: BOOLEAN;  MAX_LENGTH: INTEGER;
                                  VAR IS: STRING;  VAR CH: CHAR,
                                  var which_key : sc_key_command  };(**gws*)
VAR
  ACHAR: STRING[1];
  DONE, DECPT, PLUSMINUS: BOOLEAN;
  
PROCEDURE BAD;
BEGIN
  IS := 'INVALID';
  WRITE(OUTPUT,THEBELL);
END;

PROCEDURE PUTIN;
BEGIN
  IF LENGTH(IS) < MAX_LENGTH THEN
    BEGIN
      ACHAR[1] := CH;
      IS := CONCAT(IS, ACHAR);
      WRITE(OUTPUT,CH);
    END;
END;

PROCEDURE TAKEOUT;
BEGIN
  CASE IS[ LENGTH(IS) ] OF
    '+','-': BEGIN
               PLUSMINUS := FALSE;
               MAX_LENGTH := MAX_LENGTH-1
             END;
    '.':     BEGIN
               IF LENGTH(IS) = 1 THEN PLUSMINUS := FALSE;
               DECPT := FALSE;
             END;
  END;
  DELETE(IS,LENGTH(IS),1);
  WRITE(OUTPUT,CRT_CURSOR_LEFT,SPACE,CRT_CURSOR_LEFT);  (* SDA 12/17/81 *)
END;

PROCEDURE HANDLEIT;
BEGIN
  CASE CH OF
    '+','-': IF PLUSMINUS THEN BAD ELSE MAX_LENGTH := MAX_LENGTH + 1;
    '.'    : IF DECPT THEN BAD ELSE DECPT := TRUE;
  END;
  IF IS <> 'INVALID' THEN
    BEGIN  PUTIN;  PLUSMINUS := TRUE  END
END;  (* handleit *)

BEGIN   (* ACCEPTNUM *)
  IS := '';
  ACHAR := ' ';
  PLUSMINUS := FALSE;
  DECPT := FALSE;
  DONE := FALSE;
  
  {
  REPEAT
    READ(KEYBOARD, CH);
    IF EOF(KEYBOARD) OR EOLN(KEYBOARD) THEN
      BEGIN RESET(KEYBOARD); CH := CURSOR_DOWN END;
    IF CH = ABACKSPACE THEN CH := CURSOR_LEFT;        (* SDA 12/17/81 *)
    IF CH IN (DIGITS + ['+','-','.']) THEN HANDLEIT ELSE
    IF CH IN [' ',CURSOR_DOWN,CURSOR_RIGHT,CURSOR_UP,TAB,HOME,
                              ENTER,ESCAPE] THEN DONE := TRUE ELSE
    IF CH IN ['A','a','M','m'] THEN IF ARROW THEN DONE := TRUE ELSE BAD ELSE
    IF CH = CURSOR_LEFT THEN
      IF LENGTH(IS) > 0 THEN TAKEOUT ELSE DONE := ARROW ELSE
    IF CH IN [ERASEINPUT,ERASEFIELD] THEN
      WHILE LENGTH(IS) > 0 DO TAKEOUT ELSE BAD
  UNTIL DONE OR (IS = 'INVALID');
  }  (**taken out  gws*)
    
  REPEAT
    READ(KEYBOARD, CH);
    which_key := sc_map_crt_command ( ch );
    IF EOF(KEYBOARD) OR EOLN(KEYBOARD) THEN
      BEGIN RESET(KEYBOARD); which_key := sc_down_key; END;
    IF CH IN (DIGITS + ['+','-','.']) THEN HANDLEIT 
    ELSE if ( ch in [ ' ',tab ] ) or
            ( which_key IN [sc_escape_key,
                               sc_etx_key,
                               sc_down_key,
                               sc_right_key,
                               sc_up_key] ) THEN DONE := TRUE 
              ELSE IF CH IN ['A','a','M','m'] THEN 
                      IF ARROW THEN DONE := TRUE 
                      ELSE BAD 
                   ELSE IF which_key in [ sc_backspace_key, sc_left_key ] then
                           IF LENGTH(IS) > 0 THEN TAKEOUT ELSE DONE := ARROW 
                           ELSE IF which_key = sc_del_key THEN
                                   WHILE LENGTH(IS) > 0 DO TAKEOUT 
                                ELSE BAD
  UNTIL DONE OR (IS = 'INVALID');
  
  (* A minus sign ( a dash ) is now acceptable input sometimes.  SDA 11/13/80 *)
  
  IF (IS='+') OR ( (NOT ARROW) AND (IS='-') ) OR (IS='.') OR
                                                (IS='+.') OR (IS='-.') THEN BAD;
END;     (* of acceptnum *)


SEGMENT PROCEDURE ACCEPTSTR { ANY: BOOLEAN;  MAX_LENGTH, X, Y: INTEGER;
                                 DEFAULT: STRING;  VAR IS: STRING };
VAR          
     which_key : sc_key_command;
     ULINE: STRING[1];
     BOOL, INSMODE: BOOLEAN;
     CH: CHAR;
     PT: INTEGER;
  
PROCEDURE CHANGE;
BEGIN
  GOTOXY(X,Y);  WRITE(OUTPUT,IS);  GOTOXY(X+PT,Y)
END;

PROCEDURE INIT;
BEGIN
  ULINE := COPY(DASHES,1,1);        (* Set Uline to one dash *)
  IS := COPY(DASHES,1,MAX_LENGTH);  (* fill IS with Dashes   *)
  WHILE POS(' ',DEFAULT) <> 0 DO  (* Change spaces in default to dashes *)
    DEFAULT[POS(' ',DEFAULT)] := ULINE[1];
  IF DEFAULT <> '' THEN
    MOVELEFT(DEFAULT[1],IS[1],LENGTH(DEFAULT)); (* overlay default *)
  GOTOXY(X,Y);  WRITE(OUTPUT,IS);  GOTOXY(X,Y);
  PT := 0;
  INSMODE := FALSE;
END;

BEGIN   (* ACCEPTSTR *)
  INIT;
  REPEAT
    READ(KEYBOARD, CH);
    which_key := sc_map_crt_command ( ch );
    IF EOF(KEYBOARD) OR EOLN(KEYBOARD) THEN
      BEGIN RESET(KEYBOARD); which_key := sc_down_key; END;
    IF (CH >= SPACE) AND (ORD(CH) <= 127) and
       ( which_key = sc_not_legal ) then
      IF NOT ANY AND (CH IN ['?','/']) THEN  (* got ? while getting form name *)
        BEGIN  PT := 1;  IS := '?' END
      ELSE
      IF ANY OR (CH IN (['A'..'Z','a'..'z'] + DIGITS)) THEN
        BEGIN
          PT := PT + 1;
          IF INSMODE THEN  (* put extra char to write over *)
            IF PT < LENGTH(IS) THEN
              BEGIN
                DELETE(IS,LENGTH(IS),1);
                INSERT(' ',IS,PT)
              END;
          IF CH = SPACE THEN CH := ULINE[1];  (* put Dash instead of a space  *)
          IS[PT] := CH;
          CHANGE;
          IF (PT = LENGTH(IS)) AND (PT <> 1) THEN
            BEGIN                      (* Don't put cursor past end of string *)
              WRITE(OUTPUT,CRT_CURSOR_LEFT);  (* SDA  12/17/81  put in CRT_   *)
              PT := PT - 1
            END
        END
      ELSE WRITE(OUTPUT,THEBELL)
    ELSE
    IF which_key in [ sc_left_key, sc_backspace_key ] then   
      BEGIN
        INSMODE := FALSE;
        IF PT > 0 THEN
          BEGIN PT := PT - 1;  WRITE(OUTPUT,CRT_CURSOR_LEFT) END
      END
    ELSE
    IF which_key = sc_right_key THEN
      BEGIN
        INSMODE := FALSE;
        IF PT < (LENGTH(IS)-1) THEN
          BEGIN PT := PT + 1;  WRITE(OUTPUT,crt_cursor_left ) END
      END
    ELSE
    IF which_key in [ sc_down_key, sc_escape_key ] then
      BEGIN
        IF which_key = sc_escape_key THEN IS := 'ESCAPE';
        PT := LENGTH(IS)
      END
    ELSE
    IF which_key = sc_delete_key THEN
      BEGIN
        FILLCHAR(IS[PT+1],LENGTH(IS)-PT,DASHES[1]);
        CHANGE
      END
    ELSE
    {
    IF CH = ERASEFIELD THEN INIT ELSE
    IF CH = INSKEY THEN INSMODE := TRUE ELSE
    IF CH = DELKEY THEN
      BEGIN
        DELETE(IS,PT+1,1);
        IS := CONCAT(IS,ULINE);
        CHANGE
      END
    ELSE }  (**this stuff not supported by screenops *)
    WRITE(OUTPUT,THEBELL);
  UNTIL PT >= LENGTH(IS);
  
  (* change all Ulines to Spaces *)
  FOR PT := 1 TO LENGTH(IS) DO IF IS[ PT ] = ULINE[1] THEN IS[ PT ] := SPACE;
  
  (* delete trailing spaces *)
  BOOL := TRUE;
  WHILE (LENGTH(IS) > 0) AND BOOL DO
    BEGIN
      IF IS[ LENGTH(IS) ] = SPACE THEN DELETE(IS,LENGTH(IS),1)
      ELSE BOOL := FALSE
    END
END;     (* of acceptstr *)

(*$R- *)
PROCEDURE NUMBER{ VAR DAT_FILE: AFILE;  VAR DAT_DESC: FILEDESC;
                      PAGE, ROW, COL: INTEGER;  VAR NUM: NUMBERTYPE;
                         WHAT: ACTIONTYPE;  VAR ERR: BOOLEAN )};
VAR
     PTR: LISTRANGE;
     LOC: INTEGER;
     MISSING: BOOLEAN;

BEGIN
  WITH DAT_DESC DO BEGIN
    ERR := FALSE;
    MISSING := TRUE;
    PTR := LISTHEAD;  (* PTR will point to node in LIST with proper WINDOW *)
    LOC := (ROW-1) *  DIRECTORY^.THEMAXCOL + COL;

    (* Check in LIST for requested number *)
    WHILE MISSING AND (PTR <> 0) DO          (* PTR = 0 means at end of LIST *)
      WITH LIST[PTR] DO BEGIN
        IF DPAGE = PAGE THEN
          IF (START <= LOC) AND (LOC <= (START+WINDOWSIZE)) THEN
            BEGIN
              MISSING := FALSE;
              IF PTR <> LISTHEAD THEN    (* Adjust links so node can be moved
                                            to the top of the LIST *)
                BEGIN
                  IF PTR = LISTTAIL THEN (* Adj. Tail to point to prev. node *)
                    LISTTAIL := BEFORE;
                  LIST[ BEFORE ].AFTER  := AFTER;
                  LIST[ AFTER  ].BEFORE := BEFORE
                END
            END;
        IF MISSING THEN  PTR := AFTER    (* Go to the next node in LIST *)
      END;

    IF MISSING THEN  (* Number not in list so get it there *)
      BEGIN
        IF FREEHEAD <> 0 THEN  (* Empty nodes in LIST *)
          BEGIN
            PTR := FREEHEAD;
            FREEHEAD := LIST[FREEHEAD].AFTER
          END
        ELSE     (* No Empty nodes in LIST so a node in use must be used *)
          BEGIN
            PTR := LISTTAIL;  (* Use the Least Recently Used node *)
            LISTTAIL := LIST[LISTTAIL].BEFORE;
            LIST[LISTTAIL].AFTER := 0;         (* Set link to null *)
            WITH LIST[PTR] DO
              IF CHANGED THEN  (* Write window to disk *)
                ERR := BLOCKWRITE(DAT_FILE,WINDOW^,1,DBLOCK) <> 1
          END;

        WITH LIST[PTR] DO BEGIN
          (* # of Block to be read in *)
          DBLOCK := ( (PAGE-1) * BLKSPERPAGE ) + ( (LOC-1) DIV (WINDOWSIZE+1) );
          DPAGE := PAGE;
          START  := LOC - ( (LOC-1) MOD (WINDOWSIZE+1) );
          CHANGED := FALSE;
          ERR := BLOCKREAD(DAT_FILE,WINDOW^,1,DBLOCK) <> 1
        END
      END;  (* of If MISSING *)

    IF PTR <> LISTHEAD THEN  (* Put node used at the head of LIST *)
      BEGIN
        LIST[PTR].AFTER := LISTHEAD;
        LIST[LISTHEAD].BEFORE := PTR;
        LISTHEAD := PTR;
        LIST[LISTHEAD].BEFORE := 0;            (* Set link to null *)
        IF LISTTAIL = 0 THEN LISTTAIL := LISTHEAD
      END;

    WITH LIST[PTR] DO
      IF WHAT = ANDGET THEN
        NUM := WINDOW^[ LOC - START ]
      ELSE
        BEGIN
          WINDOW^[ LOC - START ] := NUM;
          CHANGED := TRUE
        END
  END
END   (* of number *);
(*$R^ *)

PROCEDURE VALUE{ RETURNINTEGER: BOOLEAN;  INSTRING: STRING;
                 VAR  REALANS: NUMBERTYPE;  VAR INTANS: INTEGER };

(* This routine was written by S. Dale Ander on Mar 26, 1981 to replace
   the original Value routine in Freeform.  It takes a string assumed to
   have a syntactically correct real number in it and puts the value into
   Realans in the form of a Real Number and the value into Intans in the
   form of an Integer.
*)

VAR
     WSUM, FSUM: NUMBERTYPE;
     NEGATIVE: BOOLEAN;
     PTR: INTEGER;
     CH:  CHAR;

PROCEDURE GETCHAR;
BEGIN
  CH := INSTRING[ PTR ];
  PTR := PTR + 1
END;

PROCEDURE SUM( VAR ANS: NUMBERTYPE;  NUMBERS: INTEGER );
VAR
     COUNT, ORDZERO: INTEGER;

BEGIN
  COUNT := 0;
  ANS := 0;
  ORDZERO := ORD('0');
  WHILE (CH IN DIGITS) AND (COUNT < NUMBERS) DO
    BEGIN
      COUNT := COUNT + 1;
      ANS := 10 * ANS + ORD(CH) - ORDZERO;
      GETCHAR;
    END;
END;

BEGIN
  
  (* A dash stands for EMPTY.  Added 11/13/80  SDA *)
  
  IF INSTRING = '-' THEN  (* this symbol stands for EMPTY *)
    BEGIN  REALANS := EMPTY;  EXIT(VALUE)  END;
    
  NEGATIVE := FALSE;
  FSUM := 0;
  WSUM := 0;
  INSTRING := CONCAT ( INSTRING, ' ' );
  PTR := 1;
  GETCHAR;

  IF CH IN ['+','-'] THEN             (* Check for a signed number *)
    BEGIN
      NEGATIVE := CH = '-';
      GETCHAR       (* Throw away sign *)
    END;

  SUM( WSUM, MAXWHOLE );              (* Get Whole part of number *)

  IF CH = '.' THEN                    (* Get Fractional part      *)
    BEGIN
      (* Put trailing zeros on *)
      INSERT( COPY( ZEROS, 1, MAXFRAC+1 ), INSTRING, LENGTH(INSTRING) );
      GETCHAR;      (* Skip period *)
      SUM( FSUM, MAXFRAC+1 )
    END;

  IF RETURNINTEGER THEN
    BEGIN
      
      (* BUG fix by SDA 11/25/80 *)
      IF WSUM > MAXINT THEN WSUM := MAXINT;
      
      INTANS  := TRUNC(WSUM);  REALANS := -77
    END
  ELSE
    BEGIN  REALANS := WSUM + (FSUM / PWROFTEN(MAXFRAC+1));  INTANS := -77  END;
  IF NEGATIVE THEN
    BEGIN  INTANS := -INTANS;  REALANS := -REALANS  END;

END  (* of value *);


========================================================================================
DOCUMENT :usus Folder:VOL27:ff.basics3.text
========================================================================================

PROCEDURE ERASE { LINE: INTEGER };
BEGIN
  {GOTOXY(0,LINE);
  WRITE(OUTPUT, ERASELINE);}
  sc_erase_to_eol ( 0, line );
END;

PROCEDURE PROMPT{ MSG: STRING;  Y: INTEGER };
BEGIN
  sc_erase_to_eol ( 0, y );
  GOTOXY(0,Y);
  WRITE(OUTPUT,{ERASELINE,}MSG);
END   (* of Prompt *);

PROCEDURE ONEMOMENT{ REASON: STRING };
BEGIN
  (*$B 40COL- *)
  PROMPT(CONCAT(REASON,'...one moment, please'),MSG_LINE);
  (*$E 40COL  *)
  (*$B 40COL+ *)
  PROMPT(CONCAT(REASON,'...please wait'),MSG_LINE);
  (*$E 40COL  *)
END;

PROCEDURE GETRESPONSE{ ANY: BOOLEAN;  LMSG, DEFAULT, RMSG: STRING;
                         LEN: INTEGER;  VAR RESPONSE: STRING };
(*  This procedure solicits for a response on line MSG_LINE with the
    question LMSG.  It puts up LMSG, the DEFAULT, and then RMSG, puts the
    cursor after LMSG, and then calls ACCEPTSTR  *)
BEGIN
  PROMPT(CONCAT(LMSG,COPY(DASHES,1,LEN),' ',RMSG),MSG_LINE);
  ACCEPTSTR(ANY,LEN,LENGTH(LMSG),MSG_LINE,DEFAULT,RESPONSE);
END;  (* of getresponse *)

FUNCTION YESNO{ MSG, DEFAULT: STRING ): BOOLEAN;   SDA 6/23/80 };
(* This function will keep asking whatever MSG is at the coordinates 
   0, MSG_LINE until getting a yes or no answer.  It returns true if the answer
   was yes.  It also sets the global variable IS.  *)
BEGIN
  REPEAT
    PROMPT(CONCAT(MSG,' ? (Y/N) '),MSG_LINE);
    ACCEPTSTR(TRUE,1,9+LENGTH(MSG),MSG_LINE,DEFAULT,IS);
    LCTOUC(IS);
  UNTIL (IS='N') OR (IS='Y');
  YESNO := (IS='Y');
END;

PROCEDURE LCTOUC{ VAR INSTRING: STRING };
VAR I: INTEGER;
BEGIN
  FOR I := 1 TO LENGTH(INSTRING) DO
    IF INSTRING[I] IN ['a'..'z'] THEN
      INSTRING[I] := CHR(ORD(INSTRING[I])-32);
END;
      
PROCEDURE PRESSRETURN{ MSG: STRING;  Y: INTEGER };
BEGIN
  PROMPT(CONCAT(MSG,' press RETURN'),Y);
  READLN(KEYBOARD);
  IF EOF(KEYBOARD) THEN RESET(KEYBOARD);
END;

PROCEDURE OPEN_DIR;     (* Opens Freeform directory *)
BEGIN
   IF FILEOPEN THEN CLOSE(DIRECTORY);
   RESET(DIRECTORY,CONCAT(DISKDRIVE,':',DIRNAME));
   FILEOPEN := IORESULT = 0;
END;     (* of open_dir *)

PROCEDURE FREEMEM{ VAR DAT_DESC: FILEDESC };
  
  PROCEDURE DODISPOSE( HEAD: INTEGER );
  VAR I: INTEGER;
  BEGIN
    WITH DAT_DESC DO BEGIN
      I := HEAD;
      WHILE I <> 0 DO
        WITH LIST[I] DO BEGIN
          DISPOSE(WINDOW);
          I := AFTER
        END
    END
  END;

BEGIN  (* FREEMEM *)
  DODISPOSE( DAT_DESC.LISTHEAD );
  DODISPOSE( DAT_DESC.FREEHEAD )
END;   (* of freemem *)

FUNCTION OPEN_DAT{(REQUESTED_FORM: STRING; VAR DAT_FILE: AFILE;
                       VAR DAT_DESC: FILEDESC;  ISEGS: STRING;
                           MAX: BOOLEAN ): BOOLEAN};
(* Will return true and set DAT_OPEN to true if it can open the DATA file
   associated with REQUESTED_FORM otherwise it will return false.  Also
   sets BLKSPERPAGE for the file and all the other variables associated with
   DAT_DESC.  If MAX is true all available heap will be used for
   the LIST table other wise just half  *)
VAR
     SIZE, I: INTEGER;
BEGIN
  RESET(DAT_FILE,CONCAT(DISKDRIVE,':',REQUESTED_FORM,'.DAT'));
  DAT_DESC.USEDHEAP := FALSE;
  IF IORESULT = 0 THEN
    BEGIN
      OPEN_DAT := TRUE;
      DAT_OPEN := TRUE;
      WITH DAT_DESC, DIRECTORY^ DO BEGIN
        LISTHEAD := 0;
        LISTTAIL := 0;
        FREEHEAD := 1;
        FOR I := 0 TO MAXLISTSIZE-1 DO LIST[I].AFTER := I + 1;
        
      { GOTOXY(0,4);
        WRITELN('OPEN_DAT called with ISEGS = |',ISEGS,'|');
        WRITE('Input Segment Names : ');
        READLN(ISEGS);
      }
        
        IS :=
  'FREEFORM,GOTOXY,FILEOPS,STRINGOP,EXTRAIO,PASCALIO,REALOPS,ACCEPTNU,ACCEPTST';
        I := VARAVAIL(IS);
        
        IF DEBUGMODE THEN
          BEGIN
            GOTOXY(0,4);
            WRITELN('VARAVAIL list below:');
            WRITELN(IS,' and ');
            WRITELN(ISEGS);
            WRITE('Enter any additions - ');
            READLN(IS);
            IF IS <> '' THEN ISEGS := CONCAT(ISEGS,',',IS)
          END;
        
        (* 2048 words of Slop *)
        SIZE := ( VARAVAIL( ISEGS ) + ( I - VARAVAIL( '' ) ) - 2048 ) DIV 256;
        
        IF NOT MAX THEN SIZE := SIZE DIV 2;
        IF SIZE > MAXLISTSIZE THEN SIZE := MAXLISTSIZE;

        IF DEBUGMODE THEN
          BEGIN  GOTOXY(37,0);  WRITE('SIZE OF LIST = ',SIZE:2)  END;
        
        LIST[SIZE].AFTER := 0;
        USEDHEAP := TRUE;                           (* SDA  Mar 31, 1981   *)
        
        IF SIZE = 0 THEN
          (*$B 40COL- *)
          PRESSRETURN('*** Not enough Memory for Form.  Abort after you',
                      MSG_LINE);
          (*$E 40COL  *)
          (*$B 40COL+ *)
          BEGIN
            PRESSRETURN('*** Not enough Memory,',MSG_LINE);
            PRESSRETURN('*** Abort after you',MSG_LINE);
          END;
          (*$E 40COL  *)
          
        FOR I := 1 TO SIZE DO NEW(LIST[I].WINDOW);  (* BUG fix I = 1 not 0 *)
        BLKSPERPAGE := ((THEMAXROW*THEMAXCOL)+WINDOWSIZE) DIV (WINDOWSIZE+1)
      END
    END
  ELSE OPEN_DAT := FALSE;
END;   (* of open_dat *)

PROCEDURE CLOSE_DAT {( VAR DAT_FILE: AFILE;  VAR DAT_DESC: FILEDESC;
                           VAR ERR: BOOLEAN )};
VAR  I,J: INTEGER;
BEGIN
  WITH DAT_DESC DO BEGIN
    ERR := FALSE;
    IF USEDHEAP THEN
      BEGIN
        I := LISTHEAD;
        WHILE I <> 0 DO
          WITH LIST[I] DO BEGIN
            IF CHANGED THEN
              IF BLOCKWRITE(DAT_FILE,WINDOW^,1,DBLOCK) <> 1 THEN ERR := TRUE;
            I := AFTER
          END;
        FREEMEM( DAT_DESC )
      END;
    CLOSE(DAT_FILE,LOCK);
    DAT_OPEN := FALSE
  END
END;   (* of close_dat *)

FUNCTION OPEN_CON{( REQUESTED_FORM: STRING ): BOOLEAN};
(* Will return true and set CON_OPEN to true if it can open the CONSTANT file
   associated with REQUESTED_FORM otherwise it will return false *)
BEGIN
  RESET(FORM_CON_FILE,CONCAT(DISKDRIVE,':',REQUESTED_FORM,'.CON'));
  IF IORESULT = 0 THEN
    BEGIN OPEN_CON := TRUE;  CON_OPEN := TRUE  END
  ELSE OPEN_CON := FALSE;
END;   (* of open_con *)

FUNCTION OPEN_CTL{(REQUESTED_FORM: STRING): BOOLEAN};
(* Will return true and set CTL_OPEN to true if it can open the CONTROL file
   associated with REQUESTED_FORM otherwise it will return true *)
BEGIN
  RESET(FORM_CTL_FILE,CONCAT(DISKDRIVE,':',REQUESTED_FORM,'.CTL'));
  IF IORESULT = 0 THEN
    BEGIN OPEN_CTL := TRUE;  CTL_OPEN := TRUE  END
  ELSE OPEN_CTL := FALSE;
END;   (* of open_ctl *)

FUNCTION OPEN_TIT{(REQUESTED_FORM: STRING): BOOLEAN};
(* Will return true and set TIT_OPEN to true if it can open the TITLE file
   associated with REQUESTED_FORM otherwise it will return true *)
BEGIN
  RESET(FORM_TIT_FILE,CONCAT(DISKDRIVE,':',REQUESTED_FORM,'.TIT'));
  IF IORESULT = 0 THEN
    BEGIN OPEN_TIT := TRUE;  TIT_OPEN := TRUE  END
  ELSE OPEN_TIT := FALSE;
END;   (* of open_tit *)

PROCEDURE SEEKDIR{ REC: INTEGER;  WHAT: ACTIONTYPE };
BEGIN
  SEEK(DIRECTORY, REC);
  IF WHAT = ANDGET THEN GET(DIRECTORY) ELSE
  IF WHAT = ANDPUT THEN PUT(DIRECTORY);
END;   (* of seekdir *)

PROCEDURE SEEKCON{ REC: INTEGER;  WHAT: ACTIONTYPE };
BEGIN
  SEEK(FORM_CON_FILE, REC);
  IF WHAT = ANDGET THEN GET(FORM_CON_FILE) ELSE
  IF WHAT = ANDPUT THEN PUT(FORM_CON_FILE);
END;   (* of seekcon *)

PROCEDURE SEEKCTL{ VAR CTL_FILE: CFILE;  COL: BOOLEAN;  REC: INTEGER;
                        WHAT: ACTIONTYPE };
BEGIN
  IF COL THEN REC := REC + DIRECTORY^.THEMAXROW;
  SEEK(CTL_FILE, REC);
  IF WHAT = ANDGET THEN GET(CTL_FILE) ELSE
  IF WHAT = ANDPUT THEN PUT(CTL_FILE);
END;   (* of seekctl *)

PROCEDURE SEEKTIT{ VAR TIT_FILE: TFILE;  REC: INTEGER;  WHAT: ACTIONTYPE };
BEGIN
  SEEK(TIT_FILE, REC);
  IF WHAT = ANDGET THEN GET(TIT_FILE) ELSE
  IF WHAT = ANDPUT THEN PUT(TIT_FILE);
END;   (* of seektit *)

PROCEDURE FINISH_UP;     (* Completes bookkeeping *)
VAR  ERR: BOOLEAN;
BEGIN
  IF FILEOPEN THEN CLOSE(DIRECTORY);
  FILEOPEN := FALSE;
  IF PRINTER_ON THEN CLOSE(PRINTER);
  PRINTER_ON := FALSE;
  IF CON_OPEN THEN CLOSE(FORM_CON_FILE);
  CON_OPEN := FALSE;
  IF CTL_OPEN THEN CLOSE(FORM_CTL_FILE);
  CTL_OPEN := FALSE;
  IF DAT_OPEN THEN CLOSE_DAT(FORM_DAT_FILE,FORM_DAT_DESC,ERR);
  DAT_OPEN := FALSE;
  IF TIT_OPEN THEN CLOSE(FORM_TIT_FILE);
  TIT_OPEN := FALSE
END;      (* of finish_up *)

PROCEDURE ERROR{INDEX:INTEGER};
VAR MSG: STRING;
BEGIN
  MSG := 'ERROR';
  CASE INDEX OF
   (*$B 40COL- *)
    1: MSG := 'FREEFORM directory is full';
    2: MSG := 'FREEFORM diskette is full';
    3: MSG := 'Printer is not on line';
    4: MSG := 'No Control file found';
    5: MSG := 'No Data file found';
    6: MSG := 'No directory on disk';
    8: MSG := 'No Title file found';
    9: MSG := 'ERROR on Read';
   10: MSG := 'ERROR on Write';
   11: MSG := 'Unable to open Temp file';
   12: MSG := 'No Constant file found';
   (*$E 40COL  *)
   (*$B 40COL+ *)
    1: MSG := 'FREEFORM dir full';
    2: MSG := 'FREEFORM disk full';
    3: MSG := 'Printer offline';
    4: MSG := 'No Control file';
    5: MSG := 'No Data file';
    6: MSG := 'No directory';
    8: MSG := 'No Title file';
    9: MSG := 'ERROR on Read';
   10: MSG := 'ERROR on Write';
   11: MSG := 'Can''t open Temp file';
   12: MSG := 'No Constant file';
   (*$E 40COL  *)
  END;
  PRESSRETURN(CONCAT('*** ',MSG,'... '),MSG_LINE);
  QUIT := TRUE;
END;   (* of error *)

FUNCTION SEARCH{VAR LOC: INTEGER;  NAME: STRING): BOOLEAN};
(* This function will return true if it finds NAME in the freeform directory
   and the location NAME was found at in LOC.  It returns false otherwise.
*)
BEGIN
  OPENDIR;
  LOC := 0;
  WITH DIRECTORY^ DO
    BEGIN
      WHILE (FORM_NAME <> NAME) AND (FORM_NAME <> '') AND (LOC < DIRSIZE-1) DO
        BEGIN  GET(DIRECTORY);  LOC := LOC + 1  END;
      SEARCH := FORM_NAME = NAME
    END
END;   (* of search *)

PROCEDURE GETNUM{MIN,THEMAX,DEFAULT: INTEGER; WHAT: STRING; VAR ANS: INTEGER};
VAR  MAXSTR,DEFSTR: STRING[7];
     DUMY: CHAR;
     xdummy : sc_key_command;
BEGIN
  (* If MIN = THEMAX just set ANS to one of them and exit  SDA  3/2/81 *)
  IF MIN = THEMAX THEN
    BEGIN  ERASE(MSG_LINE);  ANS := MIN;  EXIT(GETNUM)  END;
  ENCODE(THEMAX,MAXSTR);
  IF DEFAULT IN [MIN..THEMAX] THEN ENCODE(DEFAULT,DEFSTR)
  ELSE DEFSTR := COPY(DASHES,1,LENGTH(MAXSTR));
  REPEAT
    PROMPT(CONCAT(WHAT,' ',DEFSTR,'    (max. is ',MAXSTR,')'),MSG_LINE);
    GOTOXY(LENGTH(WHAT)+1,MSG_LINE);
    ACCEPTNUM(FALSE,LENGTH(MAXSTR),IS,DUMY,xdummy);
    IF (IS = '') OR (IS = 'INVALID') THEN ANS := DEFAULT
    ELSE VALUE(TRUE,IS,FAKE,ANS);
  UNTIL ANS IN [MIN..THEMAX]
END;   (* of getnum *)

PROCEDURE ENCODE{ NUM: INTEGER;  VAR ANS: STRING };
VAR
     CH: STRING[1];
     ORDZERO, I: INTEGER;

BEGIN
  ANS := '';   CH := ' ';  ORDZERO := ORD('0');
  REPEAT
    I := NUM MOD 10;
    CH[1] := CHR( I + ORDZERO );
    INSERT(CH, ANS, 1);
    NUM := NUM DIV 10
  UNTIL NUM = 0
END;   (* of encode *)

PROCEDURE MEMORY;
BEGIN
  IF DEBUGMODE THEN
    BEGIN
      GOTOXY(0,0);
      WRITE('MEMAVAIL = ',MEMAVAIL,'   VARAVAIL = ',VARAVAIL('FREEFORM'),'   ')
    END
END;


========================================================================================
DOCUMENT :usus Folder:VOL27:ff.copy1.text
========================================================================================

SEGMENT PROCEDURE COPYFORM;
CONST
     SEGSTOLOCK = 9;         (* Added 2 more Segments to lock  SDA  1/5/82 *)

TYPE
     MOVETYPE = (CTLROW, CTLCOL, DATAPAGE, DATAROW, DATACOL);

VAR
     TEMP, SOURCEDRIVE, DESTDRIVE: STRING[3];
     ERR, ZERO, JUSTPAGES: BOOLEAN;
     DESTFORM, SOURCEFORM: STRING[L_NAME];
     I, DESTREC, SOURCEREC, DESTPAGE, DESTROW, DESTCOL, ROW_CNT, COL_CNT,
       PAGE_CNT, PAGE, ROW, COL, ST_PAGE, ST_COL, ST_ROW, TOPAGE, TOROW,
         TOCOL: INTEGER;
     SOURCE: STRING[6];
     DEST: STRING[11];
     PAGELIST, COLLIST, ROWLIST: STRING[60];
     SEGLIST: ARRAY[0..SEGSTOLOCK] OF STRING[8];
     SOURCEDIRENTRY, DESTDIRENTRY: DIRRECORD;
     FORM_CON_TEMP: FILE OF NUMBERTYPE;
     FORM_TIT_TEMP: TFILE;
     FORM_CTL_TEMP: CFILE;
     FORM_DAT_TEMP: AFILE;
     TEMP_DAT_DESC: FILEDESC;

SEGMENT PROCEDURE INITIALIZE;      FORWARD;
SEGMENT PROCEDURE DOTHECOPY;       FORWARD;

SEGMENT PROCEDURE INITIALIZE;
VAR  I, J: INTEGER;

PROCEDURE GETDRIVE(WHERE: STRING;  VAR PLACE: STRING);
VAR  ANS: INTEGER;
BEGIN
  REPEAT            (* Changed range of legal drive numbers SDA 4/6/81 *)
    (*$B 40COL- *)
    GETNUM(4,30,-1,CONCAT('Enter ',WHERE,' disk drive # '), ANS)
    (*$E 40COL  *)
    (*$B 40COL+ *)
    GETNUM(4,30,-1,CONCAT('Enter ',WHERE,' drive # '), ANS)
    (*$E 40COL  *)
  UNTIL ANS IN [4,5,9..30];
  ENCODE(ANS,PLACE);           (* change drive # read in into a string *)
  PLACE := CONCAT('#',PLACE);  (* put pound sign in front of drive #   *)
END;

BEGIN
  TEMP := DISKDRIVE;
  SOURCE := 'Source';
  (*$B 40COL- *)
  DEST := 'Destination';
  (*$E 40COL  *)
  (*$B 40COL+ *)
  DEST := 'Dest';
  (*$E 40COL  *)

  DESTFORM := '';              (*  Bug Fix  SDA  5/19/81               *)
  SOURCEFORM := REQUESTED_FORM;
  
  sc_clr_screen;
  {WRITELN(OUTPUT,CLEAR);}
  WRITELN(OUTPUT,'F R E E F O R M   C O P Y');
  WRITELN(OUTPUT,'Copy existing Forms');
  
  MEMORY;
  
  IF NOT DISKDIR THEN EXIT(COPYFORM);
  
  SEGLIST[0] := 'EXTRAHEA';   SEGLIST[1] := 'HEAPOPS ';
  SEGLIST[2] := 'PASCALIO';   SEGLIST[3] := 'EXTRAIO ';
  SEGLIST[4] := 'STRINGOP';   SEGLIST[5] := 'FILEOPS ';
  SEGLIST[6] := 'REALOPS ';   SEGLIST[7] := 'GOTOXY  ';
  SEGLIST[8] := 'ACCEPTNU';   SEGLIST[9] := 'ACCEPTST';

  FOR I := 0 TO SEGSTOLOCK DO
    BEGIN
      IS := CONCAT('FREEFORM,COPYFORM,DOTHECOPY,',SEGLIST[I]);
      J := VARAVAIL(IS);
      IF DEBUGMODE THEN
        BEGIN
          GOTOXY(0,4+I);
          WRITE('VARAVAIL(''',IS,''') = ',J,'  PRESS <RET>');
          READLN(IS)
        END
      ELSE                        (* Don't Lock in Fileops and don't ask why, *)
        IF I = 5 THEN IS := 'N';  (* it just works.    SDA 4/7/81             *)
      IF (J>0) AND (IS<>'N') THEN MEMLOCK(SEGLIST[I]) ELSE SEGLIST[I] := '';
      MEMORY;
    END;

  IF YESNO('Copy from one disk to another','N') THEN
    BEGIN    (* set source and dest drives to different places *)
      GETDRIVE(SOURCE,SOURCEDRIVE);  (* get drive # for source *)
      REPEAT
        GETDRIVE(DEST,DESTDRIVE)     (* get drive # for dest.  *)
      UNTIL DESTDRIVE <> SOURCEDRIVE
    END
  ELSE         (* set source and dest drives to the same place *)
    BEGIN  SOURCEDRIVE := TEMP;  DESTDRIVE := TEMP  END;
  REPEAT
    GETRESPONSE(TRUE,'Copy a Form or just Pages ? (F/P) ','F','',1,IS);
    LCTOUC(IS);
  UNTIL (IS='F') OR (IS='P');
  JUSTPAGES := IS = 'P';
END;   (* of initialize *)

SEGMENT PROCEDURE DOTHECOPY;

PROCEDURE INSERTDISK(DRIVE, WHERE: STRING);
BEGIN
  DISKDRIVE := DRIVE;  (* set global used to point to Freeform disk *)
  
  MEMORY;
  
  IF DESTDRIVE <> SOURCEDRIVE THEN   (* copying between disks *)
    BEGIN
      (*$B 40COL- *)
      PRESSRETURN( CONCAT('Insert ',WHERE,' disk into drive ',DRIVE),MSG_LINE );
      (*$E 40COL  *)
      (*$B 40COL+ *)
      PRESSRETURN( CONCAT('Put ',WHERE,' disk in ',DRIVE),MSG_LINE );
      (*$E 40COL  *)
      ERASE(MSG_LINE)
    END
END;

PROCEDURE RETURNDISKS(WHY: STRING);
BEGIN
  (*$B 40COL- *)
  PRESSRETURN(CONCAT('Copy ',WHY,', return all disks to original drives and'),
                 MSG_LINE);
  (*$E 40COL  *)
  (*$B 40COL+ *)
  PRESSRETURN(CONCAT('Copy ',WHY,', return disks &'),
                 MSG_LINE);
  (*$E 40COL  *)
  FOR I := 0 TO SEGSTOLOCK DO MEMSWAP(SEGLIST[I])
END;

PROCEDURE LEAVE(ERR: INTEGER;  DONTDELETE: BOOLEAN);
BEGIN
  ERASE(MSG_LINE-1);  ERASE(MSG_LINE);  ERASE(MSG_LINE+1);
  IF ERR > 0 THEN ERROR(ERR);
  IF NOT DONTDELETE THEN       (* Delete all files belonging to Destform *)
    BEGIN
      DISKDRIVE := DESTDRIVE;
      OPEN_DIR;
      (* blank directory entry and remove control and data files *)
      DIRECTORY^.FORM_NAME := '';  SEEKDIR(DESTREC,ANDPUT);
      IS := CONCAT(DISKDRIVE,':',DESTFORM,'.');
      RESET(FORM_CTL_TEMP,CONCAT(IS,'CTL'));
      CLOSE(FORM_CTL_TEMP, PURGE);
      RESET(FORM_CON_TEMP,CONCAT(IS,'CON'));
      CLOSE(FORM_CON_TEMP, PURGE);
      RESET(FORM_TIT_TEMP,CONCAT(IS,'TIT'));
      CLOSE(FORM_TIT_TEMP, PURGE);
      RESET(FORM_DAT_TEMP,CONCAT(IS,'DAT'));
      CLOSE(FORM_DAT_TEMP, PURGE)
    END;
  DISKDRIVE := TEMP;          (* Close all source files *)
  OPEN_DIR;
  FINISHUP;
  RETURNDISKS('Aborted');
  EXIT(COPYFORM)
END;

PROCEDURE SETDEST( WHAT: STRING;  MAX: INTEGER;  VAR ANS: INTEGER );
BEGIN
  IF MAX = 1 THEN ANS := 1
  ELSE
    GETNUM(1,MAX,1,CONCAT('Enter ',WHAT,' # to start putting the Copy ->'),ANS)
END;   (* of setdest *)

PROCEDURE OPEN_NEW_FORM_FILES;
VAR
     ALLOK: BOOLEAN;
     AWINDOW: WINDOWTYPE;
     I, J: INTEGER;

PROCEDURE CHECKERR;
BEGIN
  IF IORESULT <> 0 THEN LEAVE(2,FALSE)
END;

BEGIN
  (* Initialize number of pages and where to start putting the pages, rows,
     and columns in the new form *)
  DESTPAGE := SOURCEDIRENTRY.NO_PAGES;
  STPAGE := 1;
  STCOL  := 1;
  STROW  := 1;
  
  MEMORY;
  
  (* Open up new FORM files *)
  REPEAT                           (* Get the size of the new Form            *)
    ALLOK := TRUE;                 (* Copy can't be smaller than the original *)
    WITH SOURCEDIRENTRY DO BEGIN
      DESTCOL := ( MAXINT-WINDOWSIZE ) DIV NO_ROWS;
      IF DESTCOL > MAXCOL THEN DESTCOL := MAXCOL;     (* BUG FIX  SDA 10/3/81 *)
      (*$B 40COL- *)
      GETNUM(NO_COLS,DESTCOL,THEMAXCOL,
        'How many Columns might ever be in the FORM ?', DESTCOL);
      DESTROW := ( MAXINT-WINDOWSIZE ) DIV DESTCOL;
      GETNUM(NO_ROWS,DESTROW,THEMAXROW,
        'How many Rows might ever be in the FORM ?',    DESTROW)
      (*$E 40COL  *)
      (*$B 40COL+ *)
      GETNUM(NO_COLS,DESTCOL,THEMAXCOL,'Max Cols in FORM ?', DESTCOL);
      DESTROW := ( MAXINT-WINDOWSIZE ) DIV DESTCOL;
      GETNUM(NO_ROWS,DESTROW,THEMAXROW,'Max Rows in FORM ?', DESTROW)
      (*$E 40COL  *)
    END;
    PROMPT('Maximum Cols = ',MSG_LINE+1);
    WRITE(OUTPUT,DESTCOL,', Rows = ',DESTROW);
    (*$B 40COL- *)
    ALLOK := YESNO('Are the dimensions ok as specified','Y');
    (*$E 40COL  *)
    (*$B 40COL+ *)
    ALLOK := YESNO('Are the dimensions ok','Y');
    (*$E 40COL  *)
    ERASE(MSG_LINE+1)
  UNTIL ALLOK;
  ONEMOMENT('Opening new FORM files');
  IS := CONCAT(DESTDRIVE,':',DESTFORM,'.');
  REWRITE(FORM_CTL_TEMP,CONCAT(IS,'CTL'));    (* The new Control file *)
  CHECKERR;
  FOR I := 0 TO DESTROW+DESTCOL DO
    BEGIN  PUT(FORM_CTL_TEMP);  CHECKERR  END;
  CLOSE(FORM_CTL_TEMP,LOCK);
  REWRITE(FORM_TIT_TEMP,CONCAT(IS,'TIT'));    (* The new Title file *)
  CHECKERR;
  FOR I := 0 TO MAXPAGES DO
    BEGIN  PUT(FORM_TIT_TEMP);  CHECKERR  END;
  CLOSE(FORM_TIT_TEMP,LOCK);
  REWRITE(FORM_CON_TEMP,CONCAT(IS,'CON'));    (* The new Constant file *)
  CHECKERR;
  FOR I := 0 TO MAXCONSTS DO
    BEGIN  PUT(FORM_CON_TEMP);  CHECKERR  END;
  CLOSE(FORM_CON_TEMP,LOCK);
  REWRITE(FORM_DAT_TEMP,CONCAT(IS,'DAT'));    (* The new Data file *)
  CHECKERR;
  FOR I := 0 TO WINDOWSIZE DO AWINDOW[I] := EMPTY;
  WITH TEMP_DAT_DESC DO BEGIN
    BLKSPERPAGE := ( (DESTROW*DESTCOL) + WINDOWSIZE ) DIV (WINDOWSIZE + 1);
    USEDHEAP := FALSE;
    FOR I := 1 TO DESTPAGE DO
      FOR J := 1 TO BLKSPERPAGE DO
        IF BLOCKWRITE(FORM_DAT_TEMP,AWINDOW,1) <> 1 THEN LEAVE(2,FALSE)
  END;
  CLOSE(FORM_DAT_TEMP,LOCK)
END;   (* of open new form files *)

PROCEDURE SETUP( VAR CNT: INTEGER;  VAR COPYLIST: STRING;  WHAT: STRING;
                      MAX, HIGH: INTEGER );
VAR
     FIRST, START, NUM, INC, PT, BEG: INTEGER;
     FIRSTONE, A_OK: BOOLEAN;
     INSTRING: STRING;
     
PROCEDURE SET_OUT(NUM: INTEGER);

  PROCEDURE SHOWERR(ERRNUM: INTEGER);
  BEGIN
    A_OK := FALSE;
    GOTOXY(PT-1,MSG_LINE+1);
    WRITE(OUTPUT,' <- ');
    DELETE(COPYLIST,LENGTH(COPYLIST),1);  (* Delete the inserted comma *)
    FOR I := PT TO LENGTH(COPYLIST) DO WRITE(OUTPUT,COPYLIST[I]);
    CASE ERRNUM OF
      1: PRESSRETURN('Sorry, too many',MSG_LINE+2);
      2: PRESSRETURN('Illegal value',MSG_LINE+2)
    END;
    ERASE(MSG_LINE+2)
  END;

BEGIN
  CNT := CNT + 1;
  IF CNT > MAX THEN SHOWERR(1)  ELSE
  IF NOT (NUM IN [1..HIGH]) THEN SHOWERR(2)
END;

BEGIN (* SETUP *)
  (* Default list to all rows or columns in the source or the number of pages *)
  (* chosen to be in the destination.                                         *)
  (* Note list of rows or cols may be more than will fit in the destination ! *)
  ENCODE(HIGH,COPYLIST);
  COPYLIST := CONCAT('1 - ',COPYLIST);
  
  MEMORY;
  
  INSTRING := '';
  
  (*$B 40COL- *)
  PROMPT(CONCAT('Enter sequences of ',WHAT,'s (XX-XX,YY-YY) to copy below'),
                 MSG_LINE);
  WRITE(OUTPUT,' (there are ',HIGH,')');
  (*$E 40COL  *)
  (*$B 40COL+ *)
  PROMPT(CONCAT('Enter ',WHAT,'s to copy'),MSG_LINE);
  WRITE(OUTPUT,' (max ',HIGH,')');
  (*$E 40COL  *)
  REPEAT
    CNT := 0;   PT := 1;
    FIRSTONE := TRUE;   A_OK := TRUE;
    ACCEPTSTR(TRUE,59,0,MSG_LINE+1,COPYLIST,INSTRING);
    IF INSTRING = 'ESCAPE' THEN LEAVE(0,JUSTPAGES) ELSE COPYLIST := INSTRING;
    COPYLIST := CONCAT(COPYLIST,',');   (* comma stopper at end of string *)
    REPEAT
      WHILE NOT ( (COPYLIST[PT] IN DIGITS) OR (COPYLIST[PT]=',') ) DO
        PT := PT + 1;
      IF COPYLIST[PT] = ',' THEN BEGIN  PT := PT + 1;  FIRSTONE := TRUE  END
      ELSE  (* must be a number *)
        BEGIN
          START := PT;
          WHILE COPYLIST[PT] IN DIGITS DO PT := PT+1; (* find end of number *)
          VALUE(TRUE,COPY(COPYLIST,START,PT-START),FAKE,NUM);
          IF FIRSTONE THEN
            BEGIN  SET_OUT(NUM);  BEG := NUM;  FIRSTONE := FALSE  END
          ELSE  (* second number so generate a sequence *)
            BEGIN
              FIRST := BEG;
              IF FIRST <> NUM THEN  (* legitimate sequence *)
                BEGIN
                  IF FIRST > NUM THEN INC := -1 ELSE INC := 1;
                  REPEAT
                    FIRST := FIRST + INC;
                    SET_OUT(FIRST)
                  UNTIL (NOT A_OK) OR (FIRST = NUM)
                END;
              FIRSTONE := TRUE
            END
        END
    UNTIL (NOT A_OK) OR (PT >= LENGTH(COPYLIST))
  UNTIL A_OK;
  IF CNT = 0 THEN LEAVE(0,JUSTPAGES);             (* Bug fix  SDA 3/4/81 *)
  ERASE(MSG_LINE+1)
END;  (* of setup *)


PROCEDURE ONEPAIR( VAR PT, BEG, LAST: INTEGER; COPYLIST: STRING );
VAR
     FIRSTONE, SECOND: BOOLEAN;
     NUM, START: INTEGER;
     
BEGIN
  FIRSTONE := TRUE;  SECOND := FALSE;  LAST := -1;
  REPEAT
    WHILE NOT ( (COPYLIST[PT] IN DIGITS) OR (COPYLIST[PT]=',') ) DO
      PT := PT + 1;
    IF COPYLIST[PT] = ',' THEN
      BEGIN  PT := PT + 1;  FIRSTONE := TRUE;  SECOND := LAST <> -1  END
    ELSE  (* must be a number *)
      BEGIN
        START := PT;
        WHILE COPYLIST[PT] IN DIGITS DO PT := PT + 1;  (* find end of number *)
        VALUE(TRUE,COPY(COPYLIST,START,PT-START),FAKE,NUM);
        IF FIRSTONE THEN
          BEGIN  BEG := NUM;  LAST := NUM;  FIRSTONE := FALSE  END
        ELSE
          BEGIN  SECOND := TRUE;  LAST := NUM  END
      END
    UNTIL (LAST <> -1) AND SECOND
END;   (* of onepair *)


========================================================================================
DOCUMENT :usus Folder:VOL27:ff.copy2.text
========================================================================================

PROCEDURE DOMOVE( VAR LOC, CNT: INTEGER;  WHAT: MOVETYPE;  LIST: STRING;
                     LOOPCNT: INTEGER );
VAR
     OFFSET, BEG, LAST, PT, ST: INTEGER;
     ANUMBER: NUMBERTYPE;

BEGIN
  
  MEMORY;
  
  CNT := 0;    PT := 1;
  IF WHAT = CTLCOL THEN ST := STCOL ELSE ST := STROW;
  REPEAT
    ONEPAIR(PT, BEG, LAST, LIST);
    IF BEG <= LAST THEN OFFSET := 1 ELSE OFFSET := -1;
    LOC := BEG - OFFSET;
    REPEAT
      LOC := LOC + OFFSET;
      CASE WHAT OF
        CTLROW, CTLCOL:
                   BEGIN
                     DIRECTORY^ := SOURCEDIRENTRY;
                     SEEKCTL(FORM_CTL_FILE, WHAT=CTLCOL, LOC, ANDGET);
                     FORM_CTL_TEMP^ := FORM_CTL_FILE^;
                     DIRECTORY^ := DESTDIRENTRY;
                     SEEKCTL(FORM_CTL_TEMP, WHAT=CTLCOL, ST+CNT, ANDPUT)
                   END;
        DATAPAGE:  BEGIN
                     ENCODE(LOC,IS);
                     ONEMOMENT(CONCAT('Copying Page # ',IS));
                     SEEKTIT(FORM_TIT_FILE,LOC,ANDGET);
                     FORM_TIT_TEMP^ := FORM_TIT_FILE^;
                     SEEKTIT(FORM_TIT_TEMP,CNT+STPAGE,ANDPUT);
                     IF NOT ZERO THEN             (* If zero no need to copy *)
                       DOMOVE(ROW, TOROW, DATAROW, ROWLIST, ROW_CNT)
                   END;
        DATAROW:   DOMOVE(COL, TOCOL, DATACOL, COLLIST, COL_CNT);
        DATACOL:   BEGIN
                     DIRECTORY^ := SOURCEDIRENTRY;
                     NUMBER(FORM_DAT_FILE, FORM_DAT_DESC, PAGE, ROW, LOC,
                              ANUMBER, ANDGET, ERR);
                     DIRECTORY^ := DESTDIRENTRY;
                     NUMBER(FORM_DAT_TEMP, TEMP_DAT_DESC, TOPAGE+STPAGE,
                              TOROW+STROW, CNT+STCOL, ANUMBER, ANDPUT, ERR)
                   END
      END;
      CNT := CNT + 1
    UNTIL LOC = LAST
  UNTIL CNT = LOOPCNT
END;   (* of domove *)

PROCEDURE COPYPAGES;
VAR  I: INTEGER;

BEGIN
  IF JUSTPAGES THEN ZERO := FALSE            (* Addition by SDA  9/22/81 *)
  ELSE
    BEGIN
      REPEAT
        GETRESPONSE(TRUE,'Copy or Empty data fields ? (C/E) ','','',1,IS);
        LCTOUC(IS);
      UNTIL (IS='E') OR (IS='C');
      ZERO := IS = 'E'
    END;
  DISKDRIVE := SOURCEDRIVE;
  IF NOT OPEN_TIT(SOURCEFORM) THEN LEAVE(8,JUSTPAGES);
  RESET(FORM_TIT_TEMP,CONCAT(DESTDRIVE,':',DESTFORM,'.TIT'));
  IF IORESULT <> 0 THEN LEAVE(8,JUSTPAGES);
  IF NOT ZERO THEN
    BEGIN
      DISKDRIVE := DESTDRIVE;
      DIRECTORY^ := DESTDIRENTRY;
      IF NOT OPEN_DAT(DESTFORM,FORM_DAT_TEMP,TEMP_DAT_DESC,'COPYFORM,DOTHECOPY',
                                                FALSE) THEN LEAVE(5, JUSTPAGES);
      DISKDRIVE := SOURCEDRIVE;
      DIRECTORY^ := SOURCEDIRENTRY;
      IF NOT OPEN_DAT(SOURCEFORM,FORM_DAT_FILE,FORM_DAT_DESC,
                            'COPYFORM,DOTHECOPY',TRUE) THEN LEAVE(5, JUSTPAGES)
    END;
  
  DOMOVE(PAGE, TOPAGE, DATAPAGE, PAGELIST, PAGE_CNT);
  
  IF NOT ZERO THEN
    BEGIN
      CLOSE_DAT(FORM_DAT_FILE, FORM_DAT_DESC, ERR);
      CLOSE_DAT(FORM_DAT_TEMP, TEMP_DAT_DESC, ERR)
    END;
  CLOSE(FORM_TIT_FILE);  CLOSE(FORM_TIT_TEMP);  TIT_OPEN := FALSE
END;   (* of copydata *)

PROCEDURE COPYCONTROLS;
VAR  I: INTEGER;

BEGIN
  ONEMOMENT('Copying Control file');
  DISKDRIVE := SOURCEDRIVE;
  IF NOT OPEN_CTL(SOURCEFORM) THEN LEAVE(4,FALSE);
  RESET(FORM_CTL_TEMP,CONCAT(DESTDRIVE,':',DESTFORM,'.CTL'));
  IF IORESULT <> 0 THEN LEAVE(4,FALSE);
  
  DOMOVE(I, TOROW, CTLROW, ROWLIST, ROW_CNT);
  DOMOVE(I, TOCOL, CTLCOL, COLLIST, COL_CNT);
  
  CLOSE(FORM_CTL_FILE);  CLOSE(FORM_CTL_TEMP);  CTL_OPEN := FALSE;
  ONEMOMENT('Copying Constants');
  IF NOT OPEN_CON(SOURCEFORM) THEN LEAVE(12,FALSE);
  RESET(FORM_CON_TEMP,CONCAT(DESTDRIVE,':',DESTFORM,'.CON'));
  IF IORESULT <> 0 THEN LEAVE(12,FALSE);
  FOR I := 1 TO MAXCONSTS DO
    BEGIN
      GET(FORM_CON_FILE);
      FORM_CON_TEMP^ := FORM_CON_FILE^;
      PUT(FORM_CON_TEMP)
    END;
  CLOSE(FORM_CON_FILE);  CLOSE(FORM_CON_TEMP);  CON_OPEN := FALSE;
  DISKDRIVE := DESTDRIVE;
  OPEN_DIR;
  DIRECTORY^ := DESTDIRENTRY;
  SEEKDIR(DESTREC,ANDPUT);
  CLOSE(DIRECTORY);  FILEOPEN := FALSE
END;   (* of copycontrols *)

BEGIN  (* DOTHECOPY *)
  INSERTDISK(DESTDRIVE,DEST);        (* put in dest disk *)
  OPEN_DIR;         (* attempt to open directory *)
  IF NOT (FILEOPEN OR JUSTPAGES) THEN   (* copying whole form so make a dir *)
    BEGIN
      ONEMOMENT('Creating Freeform Directory');
      REWRITE(DIRECTORY,CONCAT(DISKDRIVE,':',DIRNAME));
      IF IORESULT <> 0 THEN LEAVE(2,TRUE);
      DIRECTORY^.FORM_NAME := '';   (* initialize to empty *)
      FOR I := 0 TO DIRSIZE DO
        BEGIN
          PUT(DIRECTORY);
          IF IORESULT <> 0 THEN LEAVE(2,TRUE)
        END;
      CLOSE(DIRECTORY,LOCK);
      OPEN_DIR
    END;
  IF FILEOPEN THEN (* make sure a Freeform directory is on the disk *)
    BEGIN
      PROMPT(CONCAT(DEST,' Form Name'),MSG_LINE-2);
      IF JUSTPAGES THEN (* get name of existing Form to put page in *)
        IF NAME_FORM(DESTFORM,DESTREC) THEN (* set max dest page, row & col # *)
          WITH DIRECTORY^ DO BEGIN
            DESTDIRENTRY := DIRECTORY^;
            DESTPAGE := NO_PAGES;
            DESTCOL  := NO_COLS;
            DESTROW  := NO_ROWS
          END
        ELSE LEAVE(0,TRUE)
      ELSE
        BEGIN          (* get a new Form name to copy old form to *)
          REPEAT UNTIL GET_FORM_NAME(DESTFORM,DESTREC) OR QUIT;
          IF QUIT THEN LEAVE(0,TRUE)     (* BUG FIX  SDA 10/16/80 *)
        END
    END
  ELSE LEAVE(6,TRUE);      (* no directory could be found *)
  
  ERASE(MSG_LINE-2);
  INSERTDISK(SOURCEDRIVE,SOURCE);   (* put in source disk *)
  OPEN_DIR;
  IF FILEOPEN THEN (* make sure a Freeform directory is on the disk *)
    BEGIN
      PROMPT(CONCAT(SOURCE,' Form Name'),MSG_LINE-2);
      REPEAT
        IF NOT NAME_FORM(SOURCEFORM,SOURCEREC) THEN LEAVE(0,TRUE);
        IF (SOURCEFORM=DESTFORM) AND (SOURCEDRIVE=DESTDRIVE) AND (NOT JUSTPAGES)
         (*$B 40COL- *)
         THEN PRESSRETURN('Not Allowed to Copy the Source into itself',MSG_LINE)
         (*$E 40COL  *)
         (*$B 40COL+ *)
         THEN PRESSRETURN('Can''t Copy Source into itself',MSG_LINE)
         (*$E 40COL  *)
      UNTIL (SOURCEFORM<>DESTFORM) OR (SOURCEDRIVE<>DESTDRIVE) OR JUSTPAGES;
      ERASE(MSG_LINE-2);
      (* make sure that the source has control and data files *)
      ONEMOMENT('Searching for Source FORM files');
      IF OPEN_CTL(SOURCEFORM) THEN
        BEGIN  CLOSE(FORM_CTL_FILE);  CTL_OPEN := FALSE  END
      ELSE LEAVE(4,TRUE);
      IF OPEN_CON(SOURCEFORM) THEN
        BEGIN  CLOSE(FORM_CON_FILE);  CON_OPEN := FALSE  END
      ELSE LEAVE(12,TRUE);
      IF OPEN_TIT(SOURCEFORM) THEN
        BEGIN  CLOSE(FORM_TIT_FILE);  TIT_OPEN := FALSE  END
      ELSE LEAVE(8,TRUE);
      RESET(FORM_DAT_FILE,CONCAT(DISKDRIVE,':',SOURCEFORM,'.DAT'));
      IF IORESULT = 0 THEN
        BEGIN  CLOSE(FORM_DAT_FILE);  DAT_OPEN := FALSE  END
      ELSE LEAVE(5,TRUE);
      
      MEMORY;
    
      SOURCEDIRENTRY := DIRECTORY^;
      
      IF JUSTPAGES THEN (* Get destination for pages, rows and cols *)
        BEGIN
          SETDEST('Page',   DESTPAGE, STPAGE);
          SETDEST('Row',    DESTROW,  STROW);
          SETDEST('Column', DESTCOL,  STCOL)
        END
      ELSE  OPEN_NEW_FORM_FILES;    (* Open new files and set dests to 1 *)
      
      (* Set PAGELIST to pages to copy, set ROWLIST to rows to copy,
         and set COLLIST to columns to copy. *)
      WITH SOURCEDIRENTRY DO BEGIN
        SETUP(PAGE_CNT, PAGELIST, 'Page', DESTPAGE-STPAGE+1, NO_PAGES);
        SETUP(ROW_CNT,  ROWLIST,  'Row',  DESTROW-STROW+1,   NO_ROWS );
        SETUP(COL_CNT,  COLLIST,  'Col',  DESTCOL-STCOL+1,   NO_COLS )
      END;
      
      IF NOT JUSTPAGES THEN                (* Set dest dir record        *)
        WITH DESTDIRENTRY DO BEGIN
          DESTDIRENTRY := SOURCEDIRENTRY;  (* Set it to source entry     *)
          FORM_NAME    := DESTFORM;        (* Then modify certain parts  *)
          THEMAXROW    := DESTROW;
          THEMAXCOL    := DESTCOL;
          NO_PAGES     := PAGE_CNT;
          NO_ROWS      := ROW_CNT;
          NO_COLS      := COL_CNT
        END
    END
  ELSE LEAVE(6,TRUE);      (* no directory could be found *)
  COPYPAGES;
  IF NOT JUSTPAGES THEN COPYCONTROLS;
  DISKDRIVE := TEMP;
  (*$B 40COL- *)
  RETURNDISKS('Complete');
  (*$E 40COL  *)
  (*$B 40COL+ *)
  RETURNDISKS('Done');
  (*$E 40COL  *)
  FINISHUP
END;   (* of dothecopy *)

BEGIN  (* COPYFORM *)
  INITIALIZE;
  DOTHECOPY
END;   (* of copyform *)


========================================================================================
DOCUMENT :usus Folder:VOL27:ff.data1.text
========================================================================================

SEGMENT PROCEDURE DATAIN;
(*
     The Segment structure for Datain is as follows:

              |-- Help
              |                |-- Setup
              |                |          |-- Openoutputfile
              |-- ListorZero --|-- List --|-- Closefile
              |                |          |-- Listit --------|-- Headings
     Datain --|                |                             |-- Dobottom
              |                |-- Zeroit
              |-- Math
              |-- Init ----------- Openupdatafiles
              |-- Update
              |-- Anchor

*)
CONST
     GAP = 2;       (* spacing between columns                   *)
     TITLELINE = 1; (* line to display title on                  *)
     DESCLINE = 2;  (* line to put col headings on               *)
     MAXLINES = 63; (* Max num of lines and cols on a screen     *)
     T_LENGTH = 59;
     MAP_FORMAT = '#####';  (* Integer Format used for Map pages *)
     
TYPE
     FORMATDESC = PACKED RECORD
                    BEF: 0..L_CFORMAT;
                    AFT: 0..L_CFORMAT
                  END;

     VIEWS      = (NOTSET, ROWCOL, PAGECOL, ROWPAGE);
     
     TYPE_CALC  = (NO_C, INIT_C, FINL_C);
     
     CALC_ARRAY = PACKED ARRAY[0..0] OF TYPE_CALC;
     
     BOOL_ARRAY = PACKED ARRAY[0..0] OF BOOLEAN;
     
VAR
     BEFORE, AFTER: INTEGER;
     MAP_PAGE, WORK_PAGE, DIDDLED, ERR: BOOLEAN;
     ANUMBER: NUMBERTYPE;
     LEGAL: PACKED ARRAY[0..MAXLINES] OF BOOLEAN;
     CROSS_CALC: ^BOOL_ARRAY;
     CALC_LIST:  ^CALC_ARRAY;
     THEFORMAT: PACKED ARRAY[0..MAXLINES] OF FORMATDESC;
     COL_POS: ARRAY[0..MAXCOL] OF INTEGER;
     CALC_CASE, REAL_PAGE, CUR_PAGE, CUR_COL, CUR_ROW, ST_COL, LAST_COL,
       ST_ROW, LAST_ROW, XOFFSET, YOFFSET, SIZE_CROSS_CALC, SIZE_CALC_LIST,
         NUM_COLS, NUM_ROWS: INTEGER;
     PLANE: VIEWS;
     COMMAND: CHAR;
     LISTCOL, LISTROW, FOOTING, TITLE1, TITLE2, TITLE3: STRING[T_LENGTH];
     PAGE_TITLE: STRING[L_TITLE];
     TRUE_DAT_FILE: AFILE;
     
PROCEDURE SET_WORK_PAGE;                                    FORWARD;
PROCEDURE SAVEPAGE;                                         FORWARD;
PROCEDURE SET_TITLE;                                        FORWARD;
PROCEDURE GETPNUM( DEFAULT: INTEGER;  VAR ANS: INTEGER );   FORWARD;
PROCEDURE GETCTLREC( COL: BOOLEAN;  REC: INTEGER );         FORWARD;
PROCEDURE BEFOREAFTER( FORMAT: STRING );                    FORWARD;
PROCEDURE CALLNUMBER( Z,Y,X: INTEGER;  WHAT: ACTIONTYPE );  FORWARD;
PROCEDURE WRITENUM( ROW, COL: INTEGER );                    FORWARD;
PROCEDURE DISPLAY( CLEARFIRST: BOOLEAN );                   FORWARD;

SEGMENT PROCEDURE HELP;                                     FORWARD;
SEGMENT PROCEDURE LISTORZERO;                               FORWARD;
SEGMENT PROCEDURE MATH;                                     FORWARD;
SEGMENT PROCEDURE INIT;                                     FORWARD;
SEGMENT PROCEDURE UPDATE;                                   FORWARD;
SEGMENT PROCEDURE ANCHOR;                                   FORWARD;

SEGMENT PROCEDURE HELP;
BEGIN  (* HELP *)
  PROMPT('Help',MSG_LINE-1);
  (*$B 40COL- *)
  PRESSRETURN('A => Anchor:   Set screen display coordinates,',     MSG_LINE);
  PRESSRETURN('U => Update:   Enter data into FORM,',               MSG_LINE);
  PRESSRETURN('M => Math:     Perform prescribed calculations,',    MSG_LINE);
  PRESSRETURN('Z => Zero:     Set selected FORM elements to Zero,', MSG_LINE);
  PRESSRETURN('N => Nullify:  Set selected FORM elements to Null,', MSG_LINE);
  PRESSRETURN('L => List:     List selected FORM elements,',        MSG_LINE);
  PRESSRETURN('S => Save:     Save current page on diskette,',      MSG_LINE);
  (*$E 40COL  *)
  (*$B 40COL+ *)
  PRESSRETURN('Anchor:  Change Anchor,',   MSG_LINE);
  PRESSRETURN('Update:  Enter data,',      MSG_LINE);
  PRESSRETURN('Math:    Perform Math,',    MSG_LINE);
  PRESSRETURN('Zero:    Zero FORM cells,', MSG_LINE);
  PRESSRETURN('Nullify: Null FORM cells,', MSG_LINE);
  PRESSRETURN('List:    List FORM cells,', MSG_LINE);
  PRESSRETURN('Save:    Save page,',       MSG_LINE);
  (*$E 40COL  *)
END;   (* of help *)

SEGMENT PROCEDURE LISTORZERO;
TYPE
     OUT_DESC = RECORD
                  COL_NUMBER, COL_WIDTH: INTEGER
                END;
VAR
     OUT_COL: ARRAY[1..MAXCOL] OF OUT_DESC;
     WIDTH,PRINT_LINE,PAGE,I,J,ROW,ROW_CNT,COL_CNT: INTEGER;
     WPFILE, TOPRINTER: BOOLEAN;
     VOL: STRING[7];
     FNAME: STRING[10];
     THELIST: STRING[T_LENGTH];


PROCEDURE LEAVE;                                                        FORWARD;
PROCEDURE ONEPAIR( VAR PT, BEG, LAST: INTEGER );                        FORWARD;

SEGMENT PROCEDURE SETUP( VAR CNT: INTEGER;  THEROWS: BOOLEAN;
                            VAR PRINTLIST: STRING;  DOWHAT: STRING );   FORWARD;
SEGMENT PROCEDURE LIST;                                                 FORWARD;
SEGMENT PROCEDURE ZEROIT( DOWHAT: STRING;  TOZEROS: BOOLEAN );          FORWARD;


SEGMENT PROCEDURE SETUP{ VAR CNT: INTEGER;  THEROWS: BOOLEAN;
                            VAR PRINTLIST: STRING;  DOWHAT: STRING };
VAR
     MAX, HIGH, FIRST, START, NUM, INC, PT, BEG: INTEGER;
     FIRSTONE, A_OK: BOOLEAN;
     WHAT: STRING[7];
     
PROCEDURE SET_OUT(NUM: INTEGER);

  PROCEDURE SHOWERR(ERRNUM: INTEGER);
  BEGIN
    A_OK := FALSE;
    GOTOXY(PT-1,MSG_LINE+1);
    WRITE(OUTPUT,' <- ');
    DELETE(PRINTLIST,LENGTH(PRINTLIST),1);  (* Delete the inserted comma *)
    FOR I := PT TO LENGTH(PRINTLIST) DO WRITE(OUTPUT,PRINTLIST[I]);
    IS := '';
    CASE ERRNUM OF
      1: IF CNT <= 1 THEN  (* Additional check on CNT added  SDA 6/26/81 *)
           (*$B 40COL- *)
           IS := 'Line width is too small for ANY Columns to fit'
           (*$E 40COL  *)
           (*$B 40COL+ *)
           IS := 'No Columns will fit'
           (*$E 40COL  *)
         ELSE
           BEGIN           (* Change  SDA 5/7/81 *)
             ENCODE(OUT_COL[ CNT-1 ].COL_NUMBER,IS);
             (*$B 40COL- *)
             IS := CONCAT('Can only fit thru ',WHAT,' ',IS,',')
             (*$E 40COL  *)
             (*$B 40COL+ *)
             IS := CONCAT('Can fit thru ',WHAT,' ',IS,',')
             (*$E 40COL  *)
           END;
      2: IS := 'Illegal value,'
    END;
    PRESSRETURN(IS,MSG_LINE+2);
    ERASE(MSG_LINE+2);
    ERASE(MSG_LINE+1)
  END;

BEGIN
  CNT := CNT + 1;
  (* MOD by SDA  9/22/81 *)
  IF (CNT > MAXCOL) AND (NOT THEROWS) THEN SHOWERR(1)  ELSE
  IF NOT (NUM IN [1..HIGH]) THEN SHOWERR(2)  ELSE
  IF NOT THEROWS THEN
    WITH OUT_COL[ CNT ] DO BEGIN
      COL_NUMBER := NUM;
      IF COMMAND = 'L' THEN (* Listing so checkout total width of line so far *)
        BEGIN
          COL_WIDTH := COL_POS[ NUM ] - COL_POS[ NUM - 1 ];
          WIDTH := WIDTH + COL_WIDTH;
          IF TOPRINTER AND (WIDTH >= CHARS_PER_LINE) THEN SHOWERR(1)
        END
    END
END;

BEGIN (* SETUP *)
  WITH DIRECTORY^ DO
    IF THEROWS THEN                (* Change SDA 5/5/81 *)
      IF PLANE = PAGECOL THEN
        BEGIN  WHAT := 'Page';    HIGH := NO_PAGES;  MAX := NO_PAGES   END
      ELSE
        BEGIN  WHAT := 'Row';     HIGH := NO_ROWS;   MAX := THEMAXROW  END
    ELSE
      IF PLANE = ROWPAGE THEN
        BEGIN  WHAT := 'Page';    HIGH := NO_PAGES;  MAX := NO_PAGES   END
      ELSE
        BEGIN  WHAT := 'Column';  HIGH := NO_COLS;   MAX := THEMAXCOL  END;
  
  (*$B 40COL- *)
  PROMPT(CONCAT('Enter sequences of ',WHAT,'s (XX-XX,YY-YY) to ',DOWHAT,
                   ' below'),MSG_LINE);
  WRITE(OUTPUT,' (there are ',HIGH,')');
  (*$E 40COL  *)
  (*$B 40COL+ *)
  PROMPT(CONCAT('Enter ',WHAT,'s to ',DOWHAT),MSG_LINE);
  WRITE(OUTPUT,' (max ',HIGH,')');
  (*$E 40COL  *)
  REPEAT
    CNT := 0;   PT := 1;
    FIRSTONE := TRUE;   A_OK := TRUE;
    WIDTH := COL_POS[0];
    ACCEPTSTR(TRUE,T_LENGTH-1,0,MSG_LINE+1,PRINTLIST,IS);
    IF IS = 'ESCAPE' THEN  LEAVE  ELSE  PRINTLIST := IS;
    PRINTLIST := CONCAT(PRINTLIST,',');   (* comma stopper at end of string *)
    REPEAT
      WHILE NOT ( (PRINTLIST[PT] IN DIGITS) OR (PRINTLIST[PT]=',') ) DO
        PT := PT + 1;
      IF PRINTLIST[PT] = ',' THEN BEGIN  PT := PT + 1;  FIRSTONE := TRUE  END
      ELSE  (* must be a number *)
        BEGIN
          START := PT;
          WHILE PRINTLIST[PT] IN DIGITS DO PT := PT+1; (* find end of number *)
          VALUE(TRUE,COPY(PRINTLIST,START,PT-START),FAKE,NUM);
          IF FIRSTONE THEN
            BEGIN  SET_OUT(NUM);  BEG := NUM;  FIRSTONE := FALSE  END
          ELSE  (* second number so generate a sequence *)
            BEGIN
              IF THEROWS THEN  FIRST := BEG
              ELSE (*thecols*) FIRST := OUT_COL[ CNT ].COL_NUMBER;
              IF FIRST <> NUM THEN  (* legitimate sequence *)
                BEGIN
                  IF FIRST > NUM THEN INC := -1 ELSE INC := 1;
                  REPEAT
                    FIRST := FIRST + INC;
                    SET_OUT(FIRST)
                  UNTIL (NOT A_OK) OR (FIRST = NUM)
                END;
              FIRSTONE := TRUE
            END
        END
    UNTIL (NOT A_OK) OR (PT >= LENGTH(PRINTLIST))
  UNTIL A_OK;
  DELETE(PRINTLIST,LENGTH(PRINTLIST),1);  (* get rid of added comma *)
  IF CNT = 0 THEN LEAVE;                  (* Bug fix  SDA 3/4/81    *)
  ERASE(MSG_LINE+1)
END;  (* of setup *)



========================================================================================
DOCUMENT :usus Folder:VOL27:ff.data2.text
========================================================================================

SEGMENT PROCEDURE LIST;

SEGMENT PROCEDURE OPENOUTPUTFILE( OLD: BOOLEAN );
BEGIN
  REPEAT
    GETRESPONSE(TRUE,'Volume Name: ',VOL,':',7,VOL);
    IF VOL   = 'ESCAPE' THEN LEAVE;
    GETRESPONSE(TRUE,'File Name: ',FNAME,'.TEXT',10,FNAME);
    IF FNAME = 'ESCAPE' THEN LEAVE;
    IF OLD THEN   RESET(PRINTER,CONCAT(VOL,':',FNAME,'.TEXT'))
    ELSE        REWRITE(PRINTER,CONCAT(VOL,':',FNAME,'.TEXT'));
    PRINTER_ON := IORESULT = 0;
    IF NOT PRINTER_ON THEN
      PRESSRETURN(CONCAT('Unable to open ',VOL,':',FNAME,'.TEXT'),MSG_LINE)
  UNTIL PRINTER_ON;
END;   (* of open output file *)

SEGMENT PROCEDURE CLOSEFILE;
BEGIN
  CLOSE(PRINTER,LOCK);  PRINTER_ON := FALSE;
END;

SEGMENT PROCEDURE LISTIT;
CONST
     RUNOFFCH = '';    (* CHR(31), which is the same as the Editor uses *)

VAR
     OFFSET, CNT, PT, BEG, LAST: INTEGER;
     
PROCEDURE DOWRITELN;                              FORWARD;

SEGMENT PROCEDURE HEADINGS;                       FORWARD;
SEGMENT PROCEDURE DOBOTTOM;                       FORWARD;

SEGMENT PROCEDURE HEADINGS;
VAR TEMP, TABSTOP: INTEGER;

FUNCTION MAX( X, Y: INTEGER ): INTEGER;
BEGIN
  IF X > Y THEN MAX := X ELSE MAX := Y
END;

BEGIN
  IF WPFILE THEN   (* Set up tab stops after a Save settings command *)
    BEGIN
      WRITE(PRINTER,'[SS/TA=');
      TABSTOP := COL_POS[0];
      FOR TEMP := 1 TO COL_CNT DO
        WITH OUT_COL[TEMP] DO BEGIN
          TABSTOP := TABSTOP + COL_WIDTH;
          WRITE(PRINTER,'R',TABSTOP);
          IF TEMP <> COL_CNT THEN WRITE(PRINTER,',')
        END;
      WRITE(PRINTER,']')
    END;
  DOWRITELN;
  TEMP := LENGTH(TITLE1);
  WRITE(PRINTER,TITLE1: MAX( TEMP, TEMP + ( (WIDTH-TEMP) DIV 2 ) ));  DOWRITELN;
  TEMP := LENGTH(TITLE2);
  WRITE(PRINTER,TITLE2: MAX( TEMP, TEMP + ( (WIDTH-TEMP) DIV 2 ) ));  DOWRITELN;
  TEMP := LENGTH(TITLE3);
  WRITE(PRINTER,TITLE3: MAX( TEMP, TEMP + ( (WIDTH-TEMP) DIV 2 ) ));  DOWRITELN;
  DOWRITELN;
  TEMP := LENGTH(PAGE_TITLE);
  WRITE(PRINTER,PAGE_TITLE: MAX( TEMP, TEMP + ( (WIDTH-TEMP) DIV 2 ) ));
  DOWRITELN;
  DOWRITELN;
  IF NOT WPFILE THEN WRITE(PRINTER,' ':COL_POS[0]);
  FOR TEMP := 1 TO COL_CNT DO
    WITH OUT_COL[TEMP] DO BEGIN
      IF PLANE = ROWPAGE THEN      (* Addtion  SDA 5/5/81 *)
        BEGIN
          ENCODE(COL_NUMBER,IS);
          IS := CONCAT('Page ',IS)
        END
      ELSE
        BEGIN
          SEEKCTL(FORM_CTL_FILE,TRUE,COL_NUMBER,ANDGET);
          IS := FORM_CTL_FILE^.CTL_DESC
        END;
      IF WPFILE THEN WRITE(PRINTER,TAB)
      ELSE WRITE(PRINTER,' ':COL_WIDTH-LENGTH(IS));
      WRITE(PRINTER,IS);
    END;
  DOWRITELN;
  PRINT_LINE := 8;
END;

SEGMENT PROCEDURE DOBOTTOM;
BEGIN
  DOWRITELN;  DOWRITELN;  DOWRITELN;
  WRITE(PRINTER, FOOTING);
  IF TOPRINTER THEN
    {WRITE(PRINTER,CLEAR)}  (** ??? *)
  ELSE
    IF WPFILE THEN BEGIN DOWRITELN;  WRITE(PRINTER,'[PA/RS]')  END;
  DOWRITELN
END;

PROCEDURE DOWRITELN;
BEGIN
  IF WPFILE THEN WRITE(PRINTER,RUNOFFCH);
  WRITELN(PRINTER);
  IF IORESULT <> 0 THEN
    BEGIN
      IF TOPRINTER THEN ERROR(0) ELSE ERROR(2);
      LEAVE
    END
END;

BEGIN  (* LISTIT *)
  ONEMOMENT('Listing');
  WITH FORM_CTL_FILE^, DIRECTORY^ DO BEGIN
    HEADINGS;   (* write out titles and column headings *)
    CNT := 0;  PT := 1;
    THELIST := CONCAT(LISTROW,',');
    REPEAT
      ONEPAIR(PT,BEG,LAST);
      IF BEG <= LAST THEN OFFSET := 1 ELSE OFFSET := -1;
      ROW := BEG - OFFSET;
      REPEAT
        ROW := ROW + OFFSET;
        IF PLANE = PAGECOL THEN         (* BUG FIX   SDA 11/6/81 *)
          BEGIN
            SEEKCTL(FORM_CTL_FILE,FALSE,CUR_PAGE,ANDGET);
            ENCODE(ROW,IS);
            IS := CONCAT('Page ',IS)
          END
        ELSE BEGIN SEEKCTL(FORM_CTL_FILE,FALSE,ROW,ANDGET); IS := CTL_DESC END;
        WRITE(PRINTER,IS);
        IF NOT WPFILE THEN WRITE(PRINTER,' ':COL_POS[0]-LENGTH(IS));
        IF CTL_TYPE <> HEADING THEN
          FOR J := 1 TO COL_CNT DO
            WITH OUT_COL[J] DO BEGIN
              IF FORMAT = FCOL THEN                 (* BUG FIX   SDA 11/6/81 *)
                IF PLANE = ROWPAGE THEN
                  SEEKCTL(FORM_CTL_FILE,TRUE,CUR_PAGE,  ANDGET)
                ELSE
                  SEEKCTL(FORM_CTL_FILE,TRUE,COL_NUMBER,ANDGET);
              IF MAP_PAGE THEN CTL_FORMAT := MAP_FORMAT;
              BEFOREAFTER(CTL_FORMAT);
              NUMBER(FORM_DAT_FILE,FORM_DAT_DESC,CUR_PAGE,ROW,COL_NUMBER,
                                                            ANUMBER,ANDGET,ERR);
              CALLNUMBER(CUR_PAGE,ROW,COL_NUMBER,ANDGET);  (* New SDA 5/5/81 *)
              NUMTOSTR(IS,ANUMBER,BEFORE,AFTER);
              IF WPFILE THEN WRITE(PRINTER,TAB)
              ELSE WRITE(PRINTER,' ':COL_WIDTH-LENGTH(IS));
              WRITE(PRINTER,IS)
            END;
        DOWRITELN;
        PRINT_LINE := PRINT_LINE + 1;
        IF PRINT_LINE > PAPER_LENGTH-12 THEN
          BEGIN DOBOTTOM;  HEADINGS  END;
        CNT := CNT + 1
      UNTIL ROW = LAST
    UNTIL CNT = ROW_CNT;
    DOBOTTOM;
  END;
END;   (* of listit *)

BEGIN  (* LIST *)
  PROMPT('List',MSG_LINE-1);
  
  MEMORY;
  
  VOL := DISKDRIVE;  FNAME := '';
  TOPRINTER := YESNO('List to the Printer','Y');
  IF TOPRINTER THEN
    (*$B 40COL- *)
    GETNUM(1,999,CHARS_PER_LINE,'How many characters wide is the paper ?',
                    CHARS_PER_LINE);
    (*$E 40COL  *)
    (*$B 40COL+ *)
    GETNUM(1,999,CHARS_PER_LINE,'How wide is paper ?',CHARS_PER_LINE);
    (*$E 40COL  *)
    
  IF YESNO('Is there a Control file to use','N') THEN
    BEGIN
      OPENOUTPUTFILE(TRUE);
      READLN(PRINTER,TITLE1);
      READLN(PRINTER,TITLE2);
      READLN(PRINTER,TITLE3);
      READLN(PRINTER,FOOTING);
      READLN(PRINTER,LISTROW);
      READLN(PRINTER,LISTCOL);
      CLOSEFILE
    END;
  
  SETUP(ROW_CNT,TRUE,LISTROW,'List');      (* get list of rows to print    *)
  SETUP(COL_CNT,FALSE,LISTCOL,'List');     (* get list of columns to print *)
  GETRESPONSE(TRUE,'Title 1 -> ',TITLE1, '',T_LENGTH,TITLE1);
  GETRESPONSE(TRUE,'Title 2 -> ',TITLE2, '',T_LENGTH,TITLE2);
  GETRESPONSE(TRUE,'Title 3 -> ',TITLE3, '',T_LENGTH,TITLE3);
  GETRESPONSE(TRUE,'Footing -> ',FOOTING,'',T_LENGTH,FOOTING);
  
  (*$B 40COL- *)
  IF YESNO('Save this information in a Control file','N') THEN
  (*$E 40COL  *)
  (*$B 40COL+ *)
  IF YESNO('Save info in a Control file','N') THEN
  (*$E 40COL  *)
    BEGIN
      OPENOUTPUTFILE(FALSE);
      WRITELN(PRINTER,TITLE1);
      WRITELN(PRINTER,TITLE2);
      WRITELN(PRINTER,TITLE3);
      WRITELN(PRINTER,FOOTING);
      WRITELN(PRINTER,LISTROW);
      WRITELN(PRINTER,LISTCOL);
      CLOSEFILE
    END;
  
  IF TOPRINTER THEN
    BEGIN
      WPFILE := FALSE;
      SETPRINTER;
      IF NOT PRINTER_ON THEN LEAVE
    END
  ELSE
    BEGIN
      FNAME := 'LISTING';
      OPENOUTPUTFILE(FALSE);
      (*$B 40COL- *)
      WPFILE := YESNO('Create output for Word Processing','Y');
      (*$E 40COL  *)
      (*$B 40COL+ *)
      WPFILE := YESNO('Output for Word Processing','Y');
      (*$E 40COL  *)
    END;
  LISTIT;
  CLOSEFILE
END;   (* of list *)

SEGMENT PROCEDURE ZEROIT{ DOWHAT: STRING;  TOZEROS: BOOLEAN };
VAR
     OFFSET, CNT, PT, BEG, LAST: INTEGER;
     DUMYLIST: STRING[T_LENGTH];

BEGIN
  
  MEMORY;
  
  PROMPT(DOWHAT, MSG_LINE-1);
  THELIST := '';   DUMYLIST := '';
  SETUP(ROW_CNT, TRUE, THELIST, DOWHAT);    (* Gather rows to ZERO    *)
  SETUP(COL_CNT, FALSE, DUMYLIST, DOWHAT);  (* Gather columns to ZERO *)
  ONEMOMENT(CONCAT(DOWHAT,'ing'));
  DIDDLED := TRUE;
  IF TOZEROS THEN ANUMBER := ZERO ELSE ANUMBER := EMPTY;
  CNT := 0;    PT := 1;
  THELIST := CONCAT(THELIST, ',');
  REPEAT
    ONEPAIR(PT, BEG, LAST);
    IF BEG <= LAST THEN OFFSET := 1 ELSE OFFSET := -1;
    ROW := BEG - OFFSET;
    REPEAT
      ROW := ROW + OFFSET;
      CNT := CNT + 1;
      FOR I := 1 TO COL_CNT DO                        (* Change  SDA 5/5/81 *)
        CALLNUMBER(CUR_PAGE,ROW,OUT_COL[I].COL_NUMBER,ANDPUT)
    UNTIL ROW = LAST
  UNTIL CNT = ROW_CNT;
  DISPLAY(FALSE)
END;   (* of zeroit *)

PROCEDURE LEAVE;
BEGIN
  ERASE(MSG_LINE+1);  EXIT(LISTORZERO)
END;

PROCEDURE ONEPAIR{ VAR PT, BEG, LAST: INTEGER };
VAR
     FIRSTONE, SECOND: BOOLEAN;
     NUM, START: INTEGER;
BEGIN
  FIRSTONE := TRUE;  SECOND := FALSE;  LAST := -1;
  REPEAT
    WHILE NOT ( (THELIST[PT] IN DIGITS) OR (THELIST[PT]=',') ) DO
      PT := PT + 1;
    IF THELIST[PT] = ',' THEN
      BEGIN  PT := PT + 1;  FIRSTONE := TRUE;  SECOND := LAST <> -1  END
    ELSE  (* must be a number *)
      BEGIN
        START := PT;
        WHILE THELIST[PT] IN DIGITS DO PT := PT+1; (* find end of number *)
        VALUE(TRUE,COPY(THELIST,START,PT-START),FAKE,NUM);
        IF FIRSTONE THEN
          BEGIN  BEG := NUM;  LAST := NUM;  FIRSTONE := FALSE  END
        ELSE  (* second number *)
          BEGIN  SECOND := TRUE;  LAST := NUM  END
       END
   UNTIL (LAST <> -1) AND SECOND;
END;   (* of onepair *)

BEGIN  (* LISTORZERO *)
  CASE COMMAND OF
    'L': LIST;
    'Z': ZEROIT('Zero',TRUE);
    'N': ZEROIT('Nullify',FALSE)
  END
END;   (* of listorzero *)


========================================================================================
DOCUMENT :usus Folder:VOL27:ff.data3.text
========================================================================================

(*$R- *)
SEGMENT PROCEDURE MATH;
VAR
     SKIPOMSG, LEAVE: BOOLEAN;
     CURCONST, ROW, COL: INTEGER;

PROCEDURE DOIT(DOINGROW: BOOLEAN);
VAR
     CNT, MAX: INTEGER;
     C_STRING: STRING[L_CALC];

PROCEDURE OOPS(NUM: INTEGER);
BEGIN
  IF SKIPOMSG AND (NUM=1) THEN EXIT(OOPS);  (* Told to ignore Overflow msgs ? *)
  PROMPT('ERROR: ',MSG_LINE-1);
  CASE NUM OF
    1: WRITE(OUTPUT,'OVERFLOW');
    2: WRITE(OUTPUT,'Heading');
    3: BEGIN
         WRITE(OUTPUT,'Illegal ');
         IF DOINGROW THEN WRITE(OUTPUT,'row') ELSE WRITE(OUTPUT,'column')
       END
  END;
  IF NUM <> 1 THEN WRITE(OUTPUT,' specified');
  WRITELN(OUTPUT,', Calc. at Row = ',ROW,'  Col = ',COL);
  IF NUM = 1 THEN   (* Continue?, if so should Overflows be ignored *)
    BEGIN
      LEAVE := NOT YESNO('Continue Calculations','Y');
      IF NOT LEAVE THEN SKIPOMSG := YESNO('Ignore future Overflows','Y')
    END;
  IF LEAVE OR (NUM <> 1) THEN
    BEGIN
      PRESSRETURN('Math being aborted,',MSG_LINE);
      CLOSE(FORM_CON_FILE);  CON_OPEN := FALSE;  (* Bug fix  SDA 12/18/81    *)
      DISPLAY(FALSE);                            (* Forgot to close Con_file *)
      EXIT(MATH);
    END;
  ERASE(MSG_LINE);
  PROMPT('Math in progress....',MSG_LINE-1);
END;   (* of err *)

PROCEDURE DOMATH;
TYPE
     TOKENKINDS = (CONSTV, EOFV, LPARENV, MINUSV, PLUSV, UPARROWV, RPARENV,
                   VALUEV, SLASHV, STARV);
VAR
     SCANRSLT: NUMBERTYPE;
     TOKENTYPE: TOKENKINDS;
     PT: INTEGER;
     
PROCEDURE SCANNER;
VAR
     NUM: INTEGER;
     CH, DUMY: CHAR;

PROCEDURE SETNUM;
VAR  ENDOFNUM: INTEGER;
BEGIN
  ENDOFNUM := PT;
  REPEAT
    ENDOFNUM := ENDOFNUM + 1;
    DUMY := C_STRING[ ENDOFNUM ]
  UNTIL NOT (( DUMY >= '0' ) AND ( DUMY <= '9' ));
  VALUE(TRUE,COPY(C_STRING,PT,ENDOFNUM-PT),FAKE,NUM);
  PT := ENDOFNUM;
END;   (* of setnum *)

  
PROCEDURE GETCONSTANT;
BEGIN
  PT := PT + 1;
  DUMY := C_STRING[ PT ];
  IF (DUMY >= '0') AND (DUMY <= '9') THEN
    BEGIN
      SETNUM;
      IF NUM <> CURCONST THEN
        BEGIN  SEEKCON(NUM,ANDGET);  CURCONST := NUM  END;
      SCANRSLT := FORM_CON_FILE^;
      TOKENTYPE := CONSTV
    END
END;   (* of getconstant *)

PROCEDURE GETVALUE;
BEGIN
  SETNUM;
  WITH DIRECTORY^ DO
    IF DOINGROW THEN
      BEGIN
        IF NUM > NO_ROWS THEN OOPS(3);
        NUMBER(FORM_DAT_FILE,FORM_DAT_DESC,CUR_PAGE,NUM,COL,SCANRSLT,ANDGET,ERR)
      END
    ELSE
      BEGIN
        IF NUM > NO_COLS THEN OOPS(3);
        NUMBER(FORM_DAT_FILE,FORM_DAT_DESC,CUR_PAGE,ROW,NUM,SCANRSLT,ANDGET,ERR)
      END;
  TOKENTYPE := VALUEV;
END;   (* getvalue *)

BEGIN  (* SCANNER *)
  IF C_STRING[ PT ] = ' ' THEN
    REPEAT PT := PT + 1 UNTIL C_STRING[ PT ] <> ' '; (* get non blank *)
  CH := C_STRING[ PT ];
  IF CH = 'C' THEN GETCONSTANT
  ELSE IF (CH >= '0') AND (CH <= '9') THEN GETVALUE
    ELSE
      BEGIN
        CASE CH OF
          '+': TOKENTYPE:=PLUSV;
          '-': TOKENTYPE:=MINUSV;
          '*': TOKENTYPE:=STARV;
          '/': TOKENTYPE:=SLASHV;
          '^': TOKENTYPE:=UPARROWV;
          '(': TOKENTYPE:=LPARENV;
          ')': TOKENTYPE:=RPARENV;
          '#': TOKENTYPE:=EOFV
        END;
        PT := PT + 1
      END;
  IF TOKENTYPE = EOFV THEN PT := PT - 1;
END;   (* of scanner *)

PROCEDURE EXPRESSION( VAR ANS: NUMBERTYPE );
VAR
     SAVEOP: CHAR;
     CHANGESIGN: BOOLEAN;
     RESULT: NUMBERTYPE;

PROCEDURE PARENEXPRESSION( VAR ANS: NUMBERTYPE );
BEGIN
  SCANNER;            (* throw away left paren  *)
  EXPRESSION( ANS );
  SCANNER             (* throw away right paren *)
END;    (* of parenexpression *)

PROCEDURE PRIMARY( VAR ANS: NUMBERTYPE );
BEGIN   (* PRIMARY *)
  IF (TOKENTYPE = CONSTV) OR (TOKENTYPE = VALUEV) THEN
    BEGIN
      ANS := SCANRSLT;
      SCANNER
    END
  ELSE
    IF TOKENTYPE = LPARENV THEN PARENEXPRESSION( ANS )
END;    (* of primary *)

PROCEDURE FACTOR( VAR ANS: NUMBERTYPE );
VAR
     RESULT: NUMBERTYPE;

BEGIN   (* FACTOR *)
  PRIMARY( ANS );
  WHILE TOKENTYPE = UPARROWV DO
    BEGIN
      SCANNER;
      PRIMARY( RESULT );
      IF NOT FIGURE(ANS,ANS,RESULT,'^') THEN OOPS(1);
    END
END;    (* of factor *)

PROCEDURE TERM( VAR ANS: NUMBERTYPE );
VAR
     SAVEOP: CHAR;
     RESULT: NUMBERTYPE;

BEGIN   (* TERM *)
  FACTOR( ANS );
  WHILE (TOKENTYPE = STARV) OR (TOKENTYPE = SLASHV) DO
    BEGIN
      IF TOKENTYPE = STARV THEN SAVEOP := '*' ELSE SAVEOP := '/';
      SCANNER;
      FACTOR( RESULT );
      IF NOT FIGURE(ANS,ANS,RESULT,SAVEOP) THEN OOPS(1);
    END
END;    (* of term *)

BEGIN   (* EXPRESSION *)
  IF (TOKENTYPE = PLUSV) OR (TOKENTYPE = MINUSV) THEN
    BEGIN
      CHANGESIGN := TOKENTYPE = MINUSV;
      SCANNER
    END
  ELSE CHANGESIGN := FALSE;
  TERM( ANS );
  IF CHANGESIGN THEN IF FIGURE(ANS,ZERO,ANS,'-') THEN; (* do the unary minus *)
  WHILE (TOKENTYPE = PLUSV) OR (TOKENTYPE = MINUSV) DO
    BEGIN
      IF TOKENTYPE = PLUSV THEN SAVEOP := '+' ELSE SAVEOP := '-';
      SCANNER;
      TERM( RESULT );
      IF NOT FIGURE(ANS,ANS,RESULT,SAVEOP) THEN OOPS(1)
    END
END;   (* of expression *)

BEGIN  (* DOMATH *)
  PT := 1;
  SCANNER;
  EXPRESSION( ANUMBER );
  NUMBER(FORM_DAT_FILE,FORM_DAT_DESC,CUR_PAGE,ROW,COL,ANUMBER,ANDPUT,ERR)
END;   (* of domath *)

BEGIN
  WITH DIRECTORY^, FORM_CTL_FILE^ DO BEGIN
    C_STRING := CTL_CALC;
    LCTOUC(C_STRING);   (* Convert to caps *)
    C_STRING := CONCAT(C_STRING,'#');

    (* The first version of Freeform left an equals sign in the first position
       of the calc string.  Must get rid of this for this version to work *)
    IF POS('=',C_STRING) = 1 THEN DELETE(C_STRING,1,1);

    IF DOINGROW THEN  MAX := NO_COLS  ELSE  MAX := NO_ROWS;

    (*$R- *)
    FOR CNT := 1 TO MAX DO
      IF DOINGROW THEN
        IF CROSS_CALC^[ CNT + NO_ROWS ] THEN
          BEGIN  COL := CNT;  DOMATH  END
        ELSE
          (* No math then *)
      ELSE
        IF CROSS_CALC^[ CNT ] THEN
          BEGIN  ROW := CNT;  DOMATH  END
        ELSE
          (* No math then *)
    (*$R^ *)
  END
END;   (* of doit *)

(*$R- *)
PROCEDURE DO_COLS(WHICH: TYPE_CALC);
BEGIN
  WITH FORM_CTL_FILE^, DIRECTORY^ DO
    FOR COL := 1 TO NO_COLS DO
      IF WHICH = CALC_LIST^[ COL + NO_ROWS ] THEN
        BEGIN
          SEEKCTL(FORM_CTL_FILE,TRUE,COL,ANDGET);
          DOIT(FALSE)
        END
END;   (* of do_cols *)

PROCEDURE DO_ROWS(WHICH: TYPE_CALC);
BEGIN
  WITH FORM_CTL_FILE^, DIRECTORY^ DO
    FOR ROW := 1 TO NO_ROWS DO
      IF WHICH = CALC_LIST^[ ROW ] THEN
        BEGIN
          SEEKCTL(FORM_CTL_FILE,FALSE,ROW,ANDGET);
          DOIT(TRUE)
        END
END;   (* of do_rows *)
(*$R^ *)

BEGIN
  IF NOT OPEN_CON(REQUESTED_FORM) THEN  (* Open file that has constants *)
    BEGIN  ERROR(12);  EXIT(MATH)  END;
  PROMPT('Math in progress....',MSG_LINE-1);
  SKIPOMSG := FALSE;
  CURCONST := 0;
  DIDDLED := CALC_CASE <> 0;
  
  MEMORY;
  
  WITH DIRECTORY^ DO
    CASE CALC_CASE OF
      0: (* no calculations to do! *) ;
      1: DOCOLS(INIT_C);
      2: DOROWS(INIT_C);
      3: IF FORMAT = FCOL THEN
           BEGIN
             DO_COLS(INIT_C);
             DO_ROWS(INIT_C)
           END
         ELSE
           BEGIN
             DO_ROWS(INIT_C);
             DO_COLS(INIT_C)
           END;
      4: DOCOLS(FINL_C);
      5: BEGIN
           DOCOLS(INIT_C);
           DOCOLS(FINL_C)
         END;
      6: BEGIN
           DOROWS(INIT_C);
           DOCOLS(FINL_C)
         END;
      7: IF FORMAT = FCOL THEN
           BEGIN
             DOCOLS(INIT_C);
             DOROWS(INIT_C);
             DOCOLS(FINL_C)
           END
         ELSE
           BEGIN
             DOROWS(INIT_C);
             DOCOLS(INIT_C);
             DOCOLS(FINL_C)
           END;
      8: DOROWS(FINL_C);
      9: BEGIN
           DOCOLS(INIT_C);
           DOROWS(FINL_C)
         END;
     10: BEGIN
           DOROWS(INIT_C);
           DOROWS(FINL_C)
         END;
     11: IF FORMAT = FCOL THEN
           BEGIN
             DOCOLS(INIT_C);
             DOROWS(INIT_C);
             DOROWS(FINL_C)
           END
         ELSE
           BEGIN
             DOROWS(INIT_C);
             DOCOLS(INIT_C);
             DOROWS(FINL_C)
           END;
     12: IF FORMAT = FCOL THEN
           BEGIN
             DOCOLS(FINL_C);
             DOROWS(FINL_C)
           END
         ELSE
           BEGIN
             DOROWS(FINL_C);
             DOCOLS(FINL_C)
           END;
     13: IF FORMAT = FCOL THEN
           BEGIN
             DOCOLS(INIT_C);
             DOCOLS(FINL_C);
             DOROWS(FINL_C)
           END
         ELSE
           BEGIN
             DOCOLS(INIT_C);
             DOROWS(FINL_C);
             DOCOLS(FINL_C)
           END;
     14: IF FORMAT = FCOL THEN
           BEGIN
             DOROWS(INIT_C);
             DOCOLS(FINL_C);
             DOROWS(FINL_C)
           END
         ELSE
           BEGIN
             DOROWS(INIT_C);
             DOROWS(FINL_C);
             DOCOLS(FINL_C)
           END;
     15: IF FORMAT = FCOL THEN
           BEGIN
             DOCOLS(INIT_C);
             DOROWS(INIT_C);
             DOCOLS(FINL_C);
             DOROWS(FINL_C)
           END
         ELSE
           BEGIN
             DOROWS(INIT_C);
             DOCOLS(INIT_C);
             DOROWS(FINL_C);
             DOCOLS(FINL_C)
           END
    END;
  CLOSE(FORM_CON_FILE);  CON_OPEN := FALSE;
  DISPLAY(FALSE)
END;   (* of math *)
(*$R^ *)


========================================================================================
DOCUMENT :usus Folder:VOL27:ff.data4.text
========================================================================================

SEGMENT PROCEDURE INIT;
VAR
     FINALC_COL, FINALC_ROW, INITC_COL, INITC_ROW, THEMAX, DESCLENGTH,
       FORMATLEN, I: INTEGER;

SEGMENT PROCEDURE OPENUPDATAFILES;
(* If a WORK_PAGE condition exists then the real file will be opened as
   TRUE_DAT_FILE and the workfile as FORM_DAT_FILE. *)
VAR
     I: INTEGER;
     AWINDOW: WINDOWTYPE;

PROCEDURE LEAVE;
BEGIN
  ERROR(11);
  VARDISPOSE( CALC_LIST,  SIZE_CALC_LIST  );
  VARDISPOSE( CROSS_CALC, SIZE_CROSS_CALC );
  CLOSE(FORM_DAT_FILE, PURGE);  DAT_OPEN := FALSE;
  CLOSE(TRUE_DAT_FILE);
  CLOSE(FORM_CTL_FILE);         CTL_OPEN := FALSE;
  EXIT(DATAIN)
END;   (* of leave *)

BEGIN  (* OPENUPDATAFILES *)
  ONEMOMENT('Opening Data File');
  IF WORK_PAGE THEN
    BEGIN
      RESET(TRUE_DAT_FILE,CONCAT(DISKDRIVE,':',REQUESTED_FORM,'.DAT'));
      IF IORESULT <> 0 THEN
        BEGIN  ERROR(5);  EXIT(DATAIN)  END;
      REWRITE(FORM_DAT_FILE,CONCAT(DISKDRIVE,':',TEMP_FILE_NAME,'.DAT'));
      IF IORESULT <> 0 THEN LEAVE;
      FOR I := 0 TO WINDOWSIZE DO AWINDOW[I] := EMPTY;
      WITH FORM_DAT_DESC, DIRECTORY^ DO BEGIN
        BLKSPERPAGE := ( (THEMAXROW*THEMAXCOL) + WINDOWSIZE ) DIV
                                  ( WINDOWSIZE + 1 );
        FOR I := 1 TO BLKSPERPAGE DO
          IF BLOCKWRITE(FORM_DAT_FILE,AWINDOW,1) <> 1 THEN LEAVE
      END;
      CLOSE(FORM_DAT_FILE,LOCK);
      IF OPEN_DAT(TEMP_FILE_NAME,FORM_DAT_FILE,
               FORM_DAT_DESC,'DATAIN,MATH,LISTORZERO,FIGURE,NUMTOSTR',TRUE) THEN
    END
  ELSE
    IF NOT OPEN_DAT(REQUESTED_FORM,FORM_DAT_FILE,FORM_DAT_DESC,
                             'DATAIN,MATH,LISTORZERO,FIGURE,NUMTOSTR',TRUE) THEN
      BEGIN  ERROR(5);  EXIT(DATAIN)  END
END;   (* of open up data files *)

FUNCTION MAX( X, Y: INTEGER ): INTEGER;
BEGIN
  IF X > Y THEN MAX := X ELSE MAX := Y;
END;

(*$R- *)
PROCEDURE COUNT_CALCS(CTL_TYPE: TYPE_CTL;  DOINGROW: BOOLEAN;  OFFSET: INTEGER);
BEGIN
  CASE CTL_TYPE OF
    HEADING, DATA: CALC_LIST^[ OFFSET ] := NO_C;
    INITIALC: BEGIN
                CALC_LIST^[ OFFSET ] := INIT_C;
                IF DOINGROW THEN INITC_ROW := INITC_ROW + 1
                            ELSE INITC_COL := INITC_COL + 1
              END;
    FINALC:   BEGIN
                CALC_LIST^[ OFFSET ] := FINL_C;
                IF DOINGROW THEN FINALC_ROW := FINALC_ROW + 1
                            ELSE FINALC_COL := FINALC_COL + 1
              END
  END
END;   (* of count_calcs *)
(*$R^ *)

BEGIN
  WITH DIRECTORY^, FORM_CTL_FILE^ DO BEGIN
    (* 
       NOTE:
         You may wonder why on earth there is a plus 2 on both of the
         expressions below.  Well I will tell you!  Some genius at
         Softech Microsystems decided that you cannot Dispose of less
         than two words but allocating just one with a Varnew is a ok.
         So for forms where just one word was needed below things
         would be FUBARed when the Vardispose was done.  I have a word
         for the person who coded the Varnew and Vardispose routines
         but I will keep it to myself.
                                                          SDA  9/28/81
    *)
    SIZE_CROSS_CALC := VARNEW( CROSS_CALC, (( NO_ROWS+NO_COLS ) DIV 16 ) + 2 );
    SIZE_CALC_LIST  := VARNEW( CALC_LIST , (( NO_ROWS+NO_COLS ) DIV 8  ) + 2 );
    IF (SIZE_CROSS_CALC = 0) OR (SIZE_CALC_LIST = 0) THEN
      BEGIN
        PRESSRETURN('*** Not Enough Memory.  Aborting,',MSG_LINE);
        FINISH_UP;
        EXIT(DATAIN)
      END;
    
    (* Additions Below  SDA 5/5/81 *)
    PLANE := NOTSET;
    REPEAT
      IF YESNO('Access Data by Pages','N')   THEN PLANE := ROWCOL  ELSE
      IF YESNO('Access Data by Columns','N') THEN PLANE := ROWPAGE ELSE
      IF YESNO('Access Data by Rows','N')    THEN PLANE := PAGECOL
    UNTIL PLANE <> NOTSET;
    
    IF PLANE <> ROWCOL THEN WORK_PAGE := FALSE
    ELSE WORK_PAGE := YESNO('Use a Work File','Y');
      
    OPENUPDATAFILES;
    
    GETPNUM(1,REAL_PAGE);    (* This sets MAP_PAGE boolean *)
    
    ONEMOMENT('Setting Up'); (* Addition  SDA 6/26/81      *)
    
    CASE PLANE OF
      ROWCOL:  BEGIN
                 NUM_COLS := NO_COLS;     NUM_ROWS := NO_ROWS;
                 IF WORK_PAGE THEN SET_WORK_PAGE
               END;
      PAGECOL: BEGIN
                 NUM_COLS := NO_COLS;     NUM_ROWS := NO_PAGES
               END;
      ROWPAGE: BEGIN
                 NUM_COLS := NO_PAGES;    NUM_ROWS := NO_ROWS
               END
    END;
  
    IF NOT WORK_PAGE THEN CUR_PAGE := REAL_PAGE;
  
    (* Initialize Col pos array, COL_POS[ I-1 ] contains position of Col I
       Also set num of calculated Rows and Cols, both Initial and Final if
       PLANE is ROWCOL
    *)
    THEMAX := 0;
    INITC_ROW := 0;  FINALC_ROW := 0;  INITC_COL := 0;  FINALC_COL := 0;
    IF PLANE = PAGECOL THEN
      THEMAX := 8               (* All descs are of the form 'Page xxx'      *)
    ELSE
      FOR I := 1 TO NO_ROWS DO  (* set col pos 0 by finding biggest row desc *)
        BEGIN                   (* cnt number of initial and final row calcs *)
          GETCTLREC( FALSE, I );
          THEMAX := MAX( THEMAX, LENGTH( CTL_DESC ) );
          IF PLANE = ROWCOL THEN
            BEGIN
              (*$R- *) CROSS_CALC^[ I ] := CTL_CROSS; (*$R^ *)
              COUNT_CALCS(CTL_TYPE, TRUE, I)
            END
        END;
    COL_POS[0] := THEMAX + GAP;
    IF FORMAT = FROW THEN  (* spacing determined by row with biggest format *)
      BEGIN                (* and the size of each column description.      *)
        THEMAX := 0;
        FOR I := 1 TO NO_ROWS DO  (* find biggest format *)
          BEGIN
            GETCTLREC( FALSE, I );
            THEMAX := MAX( THEMAX, LENGTH( CTL_FORMAT ) )
          END;
        THEMAX := THEMAX + 1;  (* add one for the sign *)
        FOR I := 1 TO NUM_COLS DO   (* set pos to max of format and desc *)
          BEGIN                     (* cnt number of column calcs too    *)
            IF PLANE = ROWPAGE THEN
              DESCLENGTH := 8       (* Descs are of the form 'Page xxx'  *)
            ELSE
              BEGIN
                GETCTLREC( TRUE, I );
                DESCLENGTH := LENGTH( CTL_DESC );
                IF PLANE = ROWCOL THEN
                  BEGIN
                    (*$R- *) CROSS_CALC^[ I + NO_ROWS ] := CTL_CROSS; (*$R^ *)
                    COUNT_CALCS(CTL_TYPE, FALSE, I + NO_ROWS)
                  END
                END;
            COL_POS[I] := COL_POS[I-1] + GAP + MAX( THEMAX, DESCLENGTH )
          END
      END
    ELSE      (* formatting by columns *)
      BEGIN
        IF PLANE = ROWPAGE THEN (* If PLANE is ROWPAGE then find the largest *)
          BEGIN                 (* col format and use it for the comparisons *)
            FORMATLEN := 0;     (* below.         SDA 5/5/81                 *)
            FOR I := 1 TO NO_COLS DO
              BEGIN
                GETCTLREC(TRUE,I);
                FORMATLEN := MAX( FORMATLEN, LENGTH(CTL_FORMAT) )
              END;
            DESCLENGTH := 8     (* All col descs are of the form 'Page xxxx' *)
          END;
        FOR I := 1 TO NUM_COLS DO (* set pos to max of col format and desc   *)
          BEGIN                   (* cnt number of column calcs too          *)
            IF PLANE <> ROWPAGE THEN
              BEGIN
                GETCTLREC( TRUE, I );
                FORMATLEN := LENGTH(CTL_FORMAT);
                DESCLENGTH := LENGTH(CTL_DESC);
                IF PLANE = ROWCOL THEN
                  BEGIN
                    (*$R- *) CROSS_CALC^[ I + NO_ROWS ] := CTL_CROSS; (*$R^ *)
                    COUNT_CALCS(CTL_TYPE, FALSE, I + NO_ROWS)
                  END
              END;
            COL_POS[I] := COL_POS[I-1] + GAP + MAX ( DESCLENGTH, FORMATLEN + 1 )
          END
      END
  END;  (* of with directory^, form_ctl_file^ *)
  
  (* initialize CALC_CASE *)
  IF (INITC_COL  = 0)  AND (INITC_ROW  = 0)  AND
     (FINALC_COL = 0)  AND (FINALC_ROW = 0)  THEN CALC_CASE := 0  ELSE
  IF (INITC_COL  > 0)  AND (INITC_ROW  = 0)  AND
     (FINALC_COL = 0)  AND (FINALC_ROW = 0)  THEN CALC_CASE := 1  ELSE
  IF (INITC_COL  = 0)  AND (INITC_ROW  > 0)  AND
     (FINALC_COL = 0)  AND (FINALC_ROW = 0)  THEN CALC_CASE := 2  ELSE
  IF (INITC_COL  > 0)  AND (INITC_ROW  > 0)  AND
     (FINALC_COL = 0)  AND (FINALC_ROW = 0)  THEN CALC_CASE := 3  ELSE
  IF (INITC_COL  = 0)  AND (INITC_ROW  = 0)  AND
     (FINALC_COL > 0)  AND (FINALC_ROW = 0)  THEN CALC_CASE := 4  ELSE
  IF (INITC_COL  > 0)  AND (INITC_ROW  = 0)  AND
     (FINALC_COL > 0)  AND (FINALC_ROW = 0)  THEN CALC_CASE := 5  ELSE
  IF (INITC_COL  = 0)  AND (INITC_ROW  > 0)  AND
     (FINALC_COL > 0)  AND (FINALC_ROW = 0)  THEN CALC_CASE := 6  ELSE
  IF (INITC_COL  > 0)  AND (INITC_ROW  > 0)  AND
     (FINALC_COL > 0)  AND (FINALC_ROW = 0)  THEN CALC_CASE := 7  ELSE
  IF (INITC_COL  = 0)  AND (INITC_ROW  = 0)  AND
     (FINALC_COL = 0)  AND (FINALC_ROW > 0)  THEN CALC_CASE := 8  ELSE
  IF (INITC_COL  > 0)  AND (INITC_ROW  = 0)  AND
     (FINALC_COL = 0)  AND (FINALC_ROW > 0)  THEN CALC_CASE := 9  ELSE
  IF (INITC_COL  = 0)  AND (INITC_ROW  > 0)  AND
     (FINALC_COL = 0)  AND (FINALC_ROW > 0)  THEN CALC_CASE := 10 ELSE
  IF (INITC_COL  > 0)  AND (INITC_ROW  > 0)  AND
     (FINALC_COL = 0)  AND (FINALC_ROW > 0)  THEN CALC_CASE := 11 ELSE
  IF (INITC_COL  = 0)  AND (INITC_ROW  = 0)  AND
     (FINALC_COL > 0)  AND (FINALC_ROW > 0)  THEN CALC_CASE := 12 ELSE
  IF (INITC_COL  > 0)  AND (INITC_ROW  = 0)  AND
     (FINALC_COL > 0)  AND (FINALC_ROW > 0)  THEN CALC_CASE := 13 ELSE
  IF (INITC_COL  = 0)  AND (INITC_ROW  > 0)  AND
     (FINALC_COL > 0)  AND (FINALC_ROW > 0)  THEN CALC_CASE := 14 ELSE
  IF (INITC_COL  > 0)  AND (INITC_ROW  > 0)  AND
     (FINALC_COL > 0)  AND (FINALC_ROW > 0)  THEN CALC_CASE := 15;

  SET_TITLE;
  
  CUR_COL := 1;   ST_COL := 1;
  CUR_ROW := 1;   ST_ROW := 1;

  DIDDLED := FALSE;
  
  TITLE1  := '';
  TITLE2  := '';
  TITLE3  := '';
  FOOTING := '';
  LISTROW := '';
  LISTCOL := '';
END;   (* of init *)

SEGMENT PROCEDURE UPDATE;
VAR  LASTCH: CHAR;
     OLD_ROW, OLD_COL, POSROW, POSCOL, POSPG, L, X, Y, TRASH: INTEGER;
     PROMPTLINE: STRING[63];
     which_key : sc_key_command;

PROCEDURE SETBEFOREAFTER( INDEX: INTEGER );
BEGIN
  WITH THEFORMAT[ INDEX ] DO BEGIN
    BEFORE := BEF;
    AFTER :=  AFT;
    L :=      BEF + AFT + 1;    (* Add 1 for a decimal point       *)
    IF AFT = 0 THEN L := L - 1  (* No decimal point so knock off 1 *)
  END
END;   (* of setbefore after *)

PROCEDURE MOVEHOME;
BEGIN
  CUR_COL := ST_COL;  CUR_ROW := ST_ROW;
  OLD_COL := 0;       OLD_ROW := 0;
  WHILE NOT LEGAL[ CUR_ROW - YOFFSET ] DO
    BEGIN
      CUR_COL := CUR_COL + 1;
      IF CUR_COL > LAST_COL THEN
        BEGIN
          CUR_COL := ST_COL;
          CUR_ROW := CUR_ROW + 1;
          IF CUR_ROW > LAST_ROW THEN  (* no legal place to put cursor *)
            BEGIN
              (*$B 40COL- *)
              PRESSRETURN('*** Re-Anchor, no place to put Cursor,',MSG_LINE);
              (*$E 40COL  *)
              (*$B 40COL+ *)
              PRESSRETURN('*** Re-Anchor,',MSG_LINE);
              (*$E 40COL  *)
              EXIT(UPDATE)
            END
        END
    END;
END;   (* of movehome *)

PROCEDURE UP;
BEGIN
  REPEAT
    CUR_ROW := CUR_ROW - 1;
    IF CUR_ROW < ST_ROW THEN
      BEGIN
        CUR_ROW := LAST_ROW;
        CUR_COL := CUR_COL - 1;
        IF CUR_COL < ST_COL THEN CUR_COL := LAST_COL
      END
  UNTIL LEGAL[ CUR_ROW - YOFFSET ];
END;

PROCEDURE DOWN;
BEGIN
  REPEAT
    CUR_ROW := CUR_ROW + 1;
    IF CUR_ROW > LAST_ROW THEN
      BEGIN
        CUR_ROW := ST_ROW;
        CUR_COL := CUR_COL + 1;
        IF CUR_COL > LAST_COL THEN CUR_COL := ST_COL
      END
  UNTIL LEGAL[ CUR_ROW - YOFFSET ];
END;

PROCEDURE RIGHT;
BEGIN
  REPEAT
    CUR_COL := CUR_COL + 1;
    IF CUR_COL > LAST_COL THEN
      BEGIN
        CUR_COL := ST_COL;
        CUR_ROW := CUR_ROW + 1;
        IF CUR_ROW > LAST_ROW THEN CUR_ROW := ST_ROW
      END
  UNTIL LEGAL[ CUR_ROW - YOFFSET ];
END;

PROCEDURE LEFT;
BEGIN
  REPEAT
    CUR_COL := CUR_COL - 1;
    IF CUR_COL < ST_COL THEN
      BEGIN
        CUR_COL := LAST_COL;
        CUR_ROW := CUR_ROW - 1;
        IF CUR_ROW < ST_ROW THEN CUR_ROW := LAST_ROW
      END
  UNTIL LEGAL[ CUR_ROW - YOFFSET ];
END;

BEGIN
  CASE PLANE OF
    ROWCOL:  PROMPTLINE := 'Row       Col       Pg ';
    PAGECOL: PROMPTLINE := 'Pg        Col       Row';
    ROWPAGE: PROMPTLINE := 'Row       Pg        Col';
  END;
  (*$B 40COL- *)
  PROMPTLINE := CONCAT('Update    ',PROMPTLINE,'         Press ENTER to leave');
  (*$E 40COL  *)
  (*$B 40COL+ *)
  PROMPTLINE := CONCAT('Update    ',PROMPTLINE);
  (*$E 40COL  *)
  
  (* set the positions to write at in the promptline  *)
  POSROW := POS( 'Row', PROMPTLINE ) + 3;
  POSCOL := POS( 'Col', PROMPTLINE ) + 3;
  POSPG  := POS( 'Pg ', PROMPTLINE ) + 3;
  
  PROMPT(PROMPTLINE,MSG_LINE-1);
  
  (*$B 40COL+ *)
  PROMPT('Press ENTER to leave',MSG_LINE);
  (*$E 40COL  *)
  
  MEMORY;
  
  MOVEHOME;
  REPEAT
    (* initialize X,Y coordinates on the screen for the field to put
       the cursor in, and set L which is the length of a number allowed
       to be entered there and set BEFORE and AFTER for that number *)
    X := COL_POS[ CUR_COL-1 ] - XOFFSET;
    Y := CUR_ROW - YOFFSET;
    IF DIRECTORY^.FORMAT = FROW THEN
      SETBEFOREAFTER( CUR_ROW - ST_ROW )     (* Two Bug fixes  SDA 3/5/81 *)
    ELSE                                     (* Was minus Y- and X-OFFSET *)
      SETBEFOREAFTER( CUR_COL - ST_COL );
    
    (* Get a number and/or a movement *)
    REPEAT
      GOTOXY(POSROW,MSG_LINE-1);  WRITE(OUTPUT,CUR_ROW:5);
      GOTOXY(POSCOL,MSG_LINE-1);  WRITE(OUTPUT,CUR_COL:5);
      GOTOXY(POSPG, MSG_LINE-1);  WRITE(OUTPUT,REAL_PAGE:5);
      GOTOXY(X,Y);
      ACCEPTNUM(TRUE,L,IS,LASTCH,which_key);
    UNTIL IS <> 'INVALID';
    
    IF IS <> '' THEN  (* Got a number, display it *)
      BEGIN
        DIDDLED := TRUE;
        VALUE(FALSE,IS,ANUMBER,TRASH);
        CALLNUMBER(CUR_PAGE,CUR_ROW,CUR_COL,ANDPUT);   (* Change  SDA 5/6/81 *)
        WRITENUM(CUR_ROW,CUR_COL);
      END;
    
    (* perform movement *)
    {
    IF LASTCH = CURSOR_UP THEN UP ELSE
    IF LASTCH = CURSOR_DOWN THEN DOWN ELSE
    IF LASTCH = CURSOR_RIGHT THEN RIGHT ELSE
    IF LASTCH = CURSOR_LEFT THEN LEFT ELSE
    IF LASTCH = HOME THEN MOVEHOME ELSE
    IF LASTCH IN [SPACE,TAB] THEN
      }
    if which_key = sc_up_key then up else
    if which_key = sc_down_key then down else
    if which_key = sc_right_key then right else
    if which_key = sc_left_key then left else
    {screenops don't support home key - gws }
    IF LASTCH IN [SPACE,TAB] THEN
      IF DIRECTORY^.FORMAT = FROW THEN RIGHT ELSE DOWN ELSE
    IF LASTCH IN ['A','a'] THEN
      BEGIN
        ST_COL := CUR_COL;  ST_ROW := CUR_ROW;
        DISPLAY(TRUE);
        PROMPT(PROMPTLINE,MSG_LINE-1);
      END
  UNTIL which_key = sc_etx_key;
END;   (* of update *)

SEGMENT PROCEDURE ANCHOR;
(* Sets CUR_PAGE, ST_COL, ST_ROW, CUR_COL and CUR_ROW and calls display if a
   new page is asked for.
*)
VAR 
     WAS_MAP: BOOLEAN;
     PAGE: INTEGER;

BEGIN  (* ANCHOR *)
  PROMPT('Anchor',MSG_LINE-1);
  WITH DIRECTORY^ DO BEGIN
    WAS_MAP := MAP_PAGE;           (* Save MAP_PAGE boolean *)
    GETPNUM(REAL_PAGE, PAGE);
    IF PAGE <> REAL_PAGE THEN
      BEGIN
        IF WORK_PAGE THEN
          BEGIN
            IF DIDDLED THEN
              IF YESNO('Save the current Page','Y') THEN SAVEPAGE;
            REAL_PAGE := PAGE;
            SET_WORK_PAGE   (* Sets Cur_Page to one *)
          END
        ELSE
          BEGIN  REAL_PAGE := PAGE;  CUR_PAGE := PAGE  END;
        SET_TITLE;
        DIDDLED := FALSE
      END
    ELSE                                (* Stayed on same page *)
      IF WAS_MAP THEN MAP_PAGE := TRUE; (* Stay in Map mode if you were in it *)
    IF PLANE = PAGECOL THEN IS := 'Page' ELSE IS := 'Row';
    GETNUM(1,NUM_ROWS,ST_ROW,CONCAT('Enter ',IS,' #'),ST_ROW);
    IF PLANE = ROWPAGE THEN IS := 'Page' ELSE IS := 'Column';
    GETNUM(1,NUM_COLS,ST_COL,CONCAT('Enter ',IS,' #'),ST_COL)
  END;
  CUR_COL := ST_COL;  CUR_ROW := ST_ROW;
  DISPLAY(TRUE)
END;   (* of anchor *)


========================================================================================
DOCUMENT :usus Folder:VOL27:ff.data5.text
========================================================================================

PROCEDURE SAVE;
BEGIN
  PROMPT('Save',MSG_LINE-1);
  SAVEPAGE
END;   (* of save *)

PROCEDURE SET_WORK_PAGE;
(* This procedure copies the REAL_PAGE from the real file to the work file and
   then sets all the page numbers of the blocks in memory to zero so NUMBER
   will go to the disk to get numbers rather than using those in memory *)
VAR
     I, LOC: INTEGER;
     AWINDOW: WINDOWTYPE;
     
BEGIN
  CUR_PAGE := 1;
  
  MEMORY;
  
  WITH FORM_DAT_DESC DO BEGIN
    LOC := (REAL_PAGE - 1) * BLKSPERPAGE;
    FOR I := 0 TO BLKSPERPAGE - 1 DO
      BEGIN
        IF BLOCKREAD (TRUE_DAT_FILE, AWINDOW, 1, LOC + I) = 1 THEN;
        IF BLOCKWRITE(FORM_DAT_FILE, AWINDOW, 1, I)       = 1 THEN
      END;
    I := LISTHEAD;    (* Set Page #'s to 0 & CHANGED to False to fool NUMBER *)
    WHILE I <> 0 DO
      WITH LIST[I] DO
        BEGIN  DPAGE := 0; CHANGED := FALSE; I := AFTER  END  (* SDA 4/24/81 *)
  END
END;   (* of set_work_page *)

PROCEDURE SAVEPAGE;
(* This routine is only called if a WORK_PAGE condition exists.  The first
   thing it does is make sure that the work file on disk jives with the numbers
   in memory by writing to disk any numbers that are in a CHANGED window.  It
   then copies the blocks in the workfile to the right place in the real file *)
VAR
     I, LOC: INTEGER;
     AWINDOW: WINDOWTYPE;
     
BEGIN
  ONEMOMENT('Saving current Page');
  
  MEMORY;
  
  WITH FORM_DAT_DESC DO BEGIN
    I := LISTHEAD;
    WHILE I <> 0 DO
      WITH LIST[I] DO BEGIN
        IF CHANGED THEN
          BEGIN
            IF BLOCKWRITE(FORM_DAT_FILE,WINDOW^,1,DBLOCK) <> 1 THEN;
            CHANGED := FALSE
          END;
        I := AFTER
      END;
    LOC := (REAL_PAGE - 1) * BLKSPERPAGE;
    FOR I := 0 TO BLKSPERPAGE-1 DO
      BEGIN
        IF BLOCKREAD (FORM_DAT_FILE,AWINDOW,1,I)     = 1 THEN;
        IF BLOCKWRITE(TRUE_DAT_FILE,AWINDOW,1,LOC+I) = 1 THEN
      END
  END;
  DIDDLED := FALSE
END;   (* of savepage *)

PROCEDURE SET_TITLE;
BEGIN
  IF PLANE = ROWCOL THEN                (* Changes made  SDA 5/6/81 *)
   IF OPEN_TIT( REQUESTED_FORM ) THEN
     BEGIN
       SEEKTIT(FORM_TIT_FILE,REAL_PAGE,ANDGET);
       PAGE_TITLE := FORM_TIT_FILE^;
       CLOSE(FORM_TIT_FILE);  TIT_OPEN := FALSE
     END
   ELSE  BEGIN  ERROR(8);  PAGE_TITLE := ''  END
  ELSE    (* Plane is either Pagecol or Rowpage *)
    BEGIN
      GETCTLREC( PLANE=ROWPAGE, REAL_PAGE );
      PAGE_TITLE := FORM_CTL_FILE^.CTL_DESC
    END
END;   (* of set_title *)

PROCEDURE GETPNUM{ DEFAULT: INTEGER;  VAR ANS: INTEGER };
(* This is a special edition of GETNUM *)
VAR  
     MAX: INTEGER;
     WHAT: STRING[7];
     MAXSTR, DEFSTR: STRING[3];
     xdummy : sc_key_command;

BEGIN
  
  MEMORY;
  
  WITH DIRECTORY^ DO
    CASE PLANE OF      (* Addition  SDA 5/6/81 *)
      ROWCOL:  BEGIN  WHAT := 'Page';     MAX := NO_PAGES  END;
      PAGECOL: BEGIN  WHAT := 'Row';      MAX := NO_ROWS   END;
      ROWPAGE: BEGIN  WHAT := 'Column';   MAX := NO_COLS   END
    END;
  
    IF MAX = 1 THEN    (* Set page to edit and the bool MAP_PAGE too *)
      BEGIN  COMMAND := '*';  ANS := 1  END
    ELSE
      BEGIN
        ENCODE(MAX,MAXSTR);  ENCODE(DEFAULT, DEFSTR);
        REPEAT
          PROMPT(CONCAT('Enter ',WHAT,' # ',DEFSTR,'    (max. is ',MAXSTR,')'),
                  MSG_LINE);
          GOTOXY(9+LENGTH(WHAT),MSG_LINE);          (* Change  SDA 5/6/81 *)
          ACCEPTNUM(TRUE,3,IS,COMMAND,xdummy);   (* put ending char into COMMAND *)
          IF (IS = '') OR (IS = 'INVALID') THEN ANS := DEFAULT
          ELSE VALUE(TRUE, IS, FAKE, ANS)
        UNTIL ANS IN [1..MAX]
      END;
  MAP_PAGE := (COMMAND IN ['M','m']) AND (PLANE = ROWCOL)   (* SDA 5/6/81 *)
END;   (* of getpnum *)

PROCEDURE GETCTLREC{ COL: BOOLEAN;  REC: INTEGER };
BEGIN
  SEEKCTL(FORM_CTL_FILE,COL,REC,ANDGET);
  (* NOTE:  May want to check IORESULT here in the future *)
  (* Set FORMAT to an integer if MAP_PAGE is true         *)
  IF MAP_PAGE THEN
    FORM_CTL_FILE^.CTL_FORMAT := MAP_FORMAT
END;   (* of get next ctl rec *)

PROCEDURE BEFOREAFTER{ FORMAT: STRING };
(* This procedure, given FORMAT, sets the global variables BEFORE and AFTER
   to the number of places to be put BEFORE and AFTER the decimal point     *)
BEGIN
  BEFORE := SCAN( LENGTH( FORMAT ), ='.', FORMAT[1] );
  AFTER := LENGTH( FORMAT ) - BEFORE - 1;
  IF AFTER < 0 THEN AFTER := 0;
END;  (* of beforeafter *)

PROCEDURE CALLNUMBER{ Z, Y, X: INTEGER;  WHAT: ACTIONTYPE };
BEGIN
  CASE PLANE OF
    ROWCOL:  NUMBER(FORM_DAT_FILE,FORM_DAT_DESC,Z,Y,X,ANUMBER,WHAT,ERR);
    PAGECOL: NUMBER(FORM_DAT_FILE,FORM_DAT_DESC,Y,Z,X,ANUMBER,WHAT,ERR);
    ROWPAGE: NUMBER(FORM_DAT_FILE,FORM_DAT_DESC,X,Y,Z,ANUMBER,WHAT,ERR);
  END
END;   (* of callnumber *)

PROCEDURE WRITENUM{ ROW, COL: INTEGER };
(* Expects the cursor to be at the correct position, and BEFORE and AFTER to
   be set correctly.  It writes out the number specified by ROW and COL from
   the current page's FORM array *)
VAR  ANS: STRING[17];  (* 17 picked to be bigger than Maxfrac+Maxwhole+2 *)
BEGIN
  CALLNUMBER(CUR_PAGE,ROW,COL,ANDGET);   (* Change  SDA 5/6/81 *)
  NUMTOSTR(ANS, ANUMBER, BEFORE, AFTER);
  GOTOXY(COL_POS[COL-1]-XOFFSET, ROW-YOFFSET);
  WRITE(OUTPUT,ANS);
END;

PROCEDURE DISPLAY{ CLEARFIRST: BOOLEAN };
(* This procedure will display a page on the screen, given ST_COL, and
   ST_ROW.  It will set XOFFSET, YOFFSET, LAST_COL, and LAST_ROW.        *)
VAR  I, J: INTEGER;
     TOOFAR: BOOLEAN;

PROCEDURE SETTHEFORMAT( INDEX: INTEGER );
BEGIN
  WITH THEFORMAT[ INDEX ] DO BEGIN
    BEF := BEFORE;
    AFT := AFTER
  END
END;   (* of settheformat *)

PROCEDURE COLDESC;
BEGIN
  GOTOXY(COL_POS[J-1]-XOFFSET, DESCLINE);
  IF PLANE = ROWPAGE THEN                 (* Change  SDA 5/6/81 *)
    BEGIN
      WRITE(OUTPUT,'Page ',J);
      GETCTLREC(TRUE,CUR_PAGE)
    END
  ELSE
    BEGIN
      GETCTLREC(TRUE, J);
      WRITE(OUTPUT, FORM_CTL_FILE^.CTL_DESC)
    END
END;

PROCEDURE ROWDESC;
BEGIN
  GOTOXY(1, I-YOFFSET);
  IF PLANE = PAGECOL THEN                 (* Change  SDA 5/6/81 *)
    BEGIN
      WRITE(OUTPUT,'Page ',I);
      GETCTLREC(FALSE,CUR_PAGE)
    END
  ELSE
    BEGIN
      GETCTLREC(FALSE, I);
      WRITE(OUTPUT, FORM_CTL_FILE^.CTL_DESC)
    END;
  LEGAL[ I - YOFFSET ] := FORM_CTL_FILE^.CTL_TYPE <> HEADING
END;

BEGIN  (* DISPLAY *)
  (* set last_col and row and x and yoffset *)
  XOFFSET := COL_POS[ ST_COL-1 ] - COL_POS[ 0 ];
  LAST_COL := ST_COL - 1;
  REPEAT
    LAST_COL := LAST_COL + 1;
    TOOFAR := ( COL_POS[ LAST_COL-1 ] - GAP + 1 - XOFFSET ) >= S_WIDTH;
  UNTIL TOOFAR OR ( LAST_COL > NUM_COLS );          (* Change  SDA 5/6/81 *)
  IF TOOFAR THEN LASTCOL := LASTCOL - 1;
  LAST_COL := LAST_COL - 1;
  YOFFSET := ST_ROW - DESCLINE - 1;
  IF (MSG_LINE-DESCLINE-3) < MAXLINES THEN LAST_ROW := MSG_LINE-DESCLINE-3
  ELSE                                     LAST_ROW := MAXLINES;
  LAST_ROW := LAST_ROW + ST_ROW - 1;
  IF LAST_ROW > NUM_ROWS THEN LASTROW := NUM_ROWS;  (* Change  SDA 5/6/81 *)
  
  (* display the data now *)
  WITH FORM_CTL_FILE^ DO BEGIN
    IF CLEARFIRST THEN {WRITE(OUTPUT, CLEAR)} sc_clr_screen;
    GOTOXY(1, TITLELINE);
    WRITE(OUTPUT, PAGE_TITLE);
    IF DIRECTORY^.FORMAT = FROW THEN (* write stuff out a row at a time *)
      BEGIN
        FOR J := ST_COL TO LAST_COL DO COLDESC;  (* write all col descs. *)
        FOR I := ST_ROW TO LAST_ROW DO
          BEGIN
            ROWDESC;                     (* write the row desc for row I *)
            IF CTL_TYPE <> HEADING THEN
              BEGIN
                BEFOREAFTER(CTL_FORMAT);         (* set Before and After *)
                SETTHEFORMAT(I-ST_ROW);          (* Bug Fix  SDA 3/5/81  *)
                FOR J := ST_COL TO LAST_COL DO WRITENUM(I,J)
              END
          END
      END
    ELSE                             (* write stuff out a col at a time *)
      BEGIN
        FOR I := ST_ROW TO LAST_ROW DO ROWDESC;  (* write all row descs *)
        FOR J := ST_COL TO LAST_COL DO
          BEGIN
            COLDESC;                    (* Write the col desc for col J *)
            BEFOREAFTER(CTL_FORMAT);
            SETTHEFORMAT(J-ST_COL);              (* Bug Fix  SDA 3/5/81 *)
            FOR I := ST_ROW TO LAST_ROW DO       (* Bug Fix  SDA 4/8/80 *)
              IF LEGAL[ I - YOFFSET ] THEN WRITENUM(I,J)
          END
      END
  END
END;   (* of display *)

FUNCTION GETCOMMAND(VAR COMMAND: CHAR): BOOLEAN;
BEGIN
  
  MEMORY;
  
  REPEAT
    (*$B 40COL- *)
    GETRESPONSE(TRUE,'Enter Command => ','',
                    '      A,U,M,Z,N,L,S,<ESC>  (H for Help)',1,IS);
    (*$E 40COL  *)
    (*$B 40COL+ *)
    GETRESPONSE(TRUE,'Command => ','',
                    '  A,U,M,Z,N,L,S,H(elp),ESC',1,IS);
    (*$E 40COL  *)
    LCTOUC(IS);
  UNTIL (IS='A') OR (IS='U') OR (IS='M') OR (IS='Z') OR (IS='L') OR
        (IS='H') OR (IS='N') OR (IS='S') OR (IS='ESCAPE');
  IF IS <> 'ESCAPE' THEN
    BEGIN GETCOMMAND := TRUE; COMMAND := IS[1] END
  ELSE
    BEGIN
      GETCOMMAND := FALSE;
      IF DIDDLED AND WORK_PAGE THEN
        IF YESNO('Save page before leaving','Y') THEN SAVEPAGE
    END
END;   (* of getcommand *)

BEGIN  (* DATAIN *)
  {WRITELN(OUTPUT,CLEAR);}
  sc_clr_screen;
  WRITELN(OUTPUT,'F R E E F O R M   D A T A   E N T R Y');
  IF DISK_DIR THEN
    IF NAME_FORM(REQUESTED_FORM, RECNUMBER) THEN
      BEGIN
        ONEMOMENT('Opening Control file');
        IF NOT OPEN_CTL(REQUESTED_FORM) THEN ERROR(4)
        ELSE
          BEGIN
            INIT;
            DISPLAY(TRUE);
            WHILE GETCOMMAND(COMMAND) DO
              BEGIN
                CASE COMMAND OF
                  'A': ANCHOR;
                  'U': UPDATE;
                  'M': IF (NOT MAP_PAGE) AND (PLANE = ROWCOL) THEN MATH;
                  'Z', 'N', 'L': LISTORZERO;
                  'S': IF WORK_PAGE THEN SAVE;
                  'H': HELP
                END;
                ERASE(MSG_LINE-1)
              END;
            IF WORK_PAGE THEN
              BEGIN
                CLOSE(FORM_DAT_FILE,PURGE);  DAT_OPEN := FALSE;
                FREEMEM(FORM_DAT_DESC);
                CLOSE(TRUE_DAT_FILE)
              END;
            VARDISPOSE( CALC_LIST,  SIZE_CALC_LIST  );
            VARDISPOSE( CROSS_CALC, SIZE_CROSS_CALC )
          END
      END;
  FINISHUP
END;   (* of datain *)



========================================================================================
DOCUMENT :usus Folder:VOL27:ff.forms1.text
========================================================================================

SEGMENT PROCEDURE FORMS;
TYPE
     SETTYPE = ( NEWFILE, NEWREC, OLDREC );
     
VAR
    MONTHS: ARRAY[1..12] OF STRING[3];
    PRINT_LINE: INTEGER;
    PREV_FORMAT: STRING[L_CFORMAT];
    CONTROL_HEADER: STRING[69];
    
PROCEDURE BLANKREC;  FORWARD;
PROCEDURE CHECKERR( ERRORNUM: INTEGER;  DELENTRY: BOOLEAN;  COND: SETTYPE );
  FORWARD;
FUNCTION  ABORT: BOOLEAN;  FORWARD;
PROCEDURE PUTMAINHEAD;  FORWARD;
PROCEDURE PUTCTRLHEAD( WHAT: STRING;  NUM: INTEGER );  FORWARD;
PROCEDURE SETNUM( MIN, MAX: INTEGER;  WHAT: STRING;  VAR ANS: INTEGER;
                    LINE: INTEGER );  FORWARD;
PROCEDURE GETUSERID;  FORWARD;
PROCEDURE GETFORMDESC;  FORWARD;
PROCEDURE GETDATE;  FORWARD;
PROCEDURE GET_CONSTANT( NUM, LINE: INTEGER;  OLD: BOOLEAN );  FORWARD;
PROCEDURE SET_PAGE( PAGE: INTEGER; NO_PROMPT,NEWPAGE: BOOLEAN; COND: SETTYPE;
                       VAR ERR: INTEGER );  FORWARD;
PROCEDURE WRITEAREC( VAR OUTFILE: TXTFILE; NUM: INTEGER; VAR AREC: CTLRECORD );
  FORWARD;
PROCEDURE SET_CTRL_REC( VAR REC: CTLRECORD;  SETTINGROW: BOOLEAN;
                           OFFSET: INTEGER;  NO_PROMPT: BOOLEAN;
                              VAR HITESC: BOOLEAN;  COND: SETTYPE );
  FORWARD;
PROCEDURE DISPLAYDIR( VAR OUTFILE: TXTFILE;  TOSCREEN, ALL: BOOLEAN;
                        RECNUMBER: INTEGER );  FORWARD;

SEGMENT PROCEDURE DEF;           FORWARD;
SEGMENT PROCEDURE LIST;          FORWARD;
SEGMENT PROCEDURE CHG;           FORWARD;
SEGMENT PROCEDURE INITIALIZE;    FORWARD;

SEGMENT PROCEDURE DEF;     (* Form definition *)

PROCEDURE CREATE;      (* Creates freeform directory *)
VAR I: INTEGER;
BEGIN
  ONEMOMENT('Creating Freeform Directory');
  REWRITE(DIRECTORY,CONCAT(DISKDRIVE,':',DIRNAME));
  CHECKERR(2,FALSE,NEWFILE);  (* make sure directory was opened *)
  FILEOPEN := TRUE;
  I := 0;  BLANKREC;
  WHILE I <= DIRSIZE DO
    BEGIN               (* fill directory with blank records *)
      PUT(DIRECTORY);
      CHECKERR(2,FALSE,NEWFILE);(* escape and give err message if put failed *)
      I := I + 1
    END;
  CLOSE(DIRECTORY,LOCK);  FILEOPEN := FALSE;
END;     (* of create *)

PROCEDURE FORMAT_CHOICE;     (* Prompt for choice of format (R/C) *)
BEGIN
  REPEAT
    GETRESPONSE(TRUE,'Format Rows or Columns? (R/C)  ','R','',1,IS);
    LCTOUC(IS);
  UNTIL (IS='R') OR (IS='C');
  IF IS='C' THEN
    BEGIN IS := 'COLUMN'; DIRECTORY^.FORMAT := FCOL END
  ELSE
    BEGIN IS := 'ROW';    DIRECTORY^.FORMAT := FROW END;
  PROMPT(CONCAT('Formatting is fixed by ',IS),5);
END;     (* of format_choice *)

PROCEDURE AUTO_CHOICE;     (* Automatic month descriptions? *)
VAR  TEMP: INTEGER;

BEGIN     (* AUTO_CHOICE *)
  WITH DIRECTORY^ DO
    (*$B 40COL- *)
    IF YESNO('Do you want automatic month descriptions','N') THEN
      BEGIN     (* wantauto *)
        REPEAT
          GETRESPONSE(TRUE,'Month descriptions for rows or columns? (R/C)  ',
             'C','',1,IS);
    (*$E 40COL  *)
    (*$B 40COL+ *)
    IF YESNO('Auto month descriptions','N') THEN
      BEGIN     (* wantauto *)
        REPEAT
          GETRESPONSE(TRUE,'Descriptions for rows or cols? (R/C)  ',
             'C','',1,IS);
    (*$E 40COL  *)
          LCTOUC(IS);
        UNTIL (IS='C') OR (IS='R');
        IF IS='R' THEN AUTO_SWITCH := AROW ELSE AUTO_SWITCH := ACOL;
        (* select starting month *)
        GETNUM(1,12,1,'Enter starting month #',TEMP);
        START_MONTH := TEMP;
      END
    ELSE AUTO_SWITCH := NOAUTO;
END;     (* of auto_choice *)

PROCEDURE SET_CONSTANTS;     (* Gets desired # of constants and sets them   *)
VAR I: INTEGER;              (* Also creates page in Dat file for Constants *)
BEGIN
  ONEMOMENT('Creating File for Constants');
  REWRITE(FORM_CON_FILE,CONCAT(DISKDRIVE,':',REQUESTED_FORM,'.CON[4]'));
  CHECKERR(2,TRUE,NEWFILE);
  CON_OPEN := TRUE;
  WITH DIRECTORY^ DO BEGIN
    (*$B 40COL- *)
    SETNUM(0,MAXCONSTS,'Calculation Constants',NO_CONSTS,6);
    (*$E 40COL  *)
    (*$B 40COL+ *)
    SETNUM(0,MAXCONSTS,'Calc Constants',NO_CONSTS,6);
    (*$E 40COL  *)
    (* initialize all Constants to EMPTY value   SDA 12/03/80 *)
    FORM_CON_FILE^ := EMPTY;
    FOR I := 1 TO MAXCONSTS DO
      BEGIN  PUT(FORM_CON_FILE);  CHECKERR(2,TRUE,NEWFILE)  END;
    (* Gather the constants *)
    FOR I := 0 TO NO_CONSTS-1 DO GET_CONSTANT(I+1,(I MOD (MSG_LINE-11))+7,FALSE)
  END;
  CLOSE(FORM_CON_FILE,LOCK);  CON_OPEN := FALSE
END;     (* of set_constants *)

PROCEDURE SET_THE_CTRLS( THEROWS: BOOLEAN );
VAR
     HITESC: BOOLEAN;
     I, CNT: INTEGER;
     WHAT: STRING[7];
BEGIN
  WITH DIRECTORY^ DO BEGIN
    IF THEROWS THEN BEGIN  WHAT := 'Row';     CNT := NO_ROWS  END
    ELSE            BEGIN  WHAT := 'Column';  CNT := NO_COLS  END;
    PUTCTRLHEAD(WHAT, CNT);  (* load parameters into control file *)
    I := 0;
    WHILE I < CNT DO
      BEGIN
        I := I + 1;
        (* give record a value before doing the Put *)
        SET_CTRL_REC(FORM_CTL_FILE^,THEROWS,I,NO_PROMPT,HITESC,NEWFILE);
        IF HITESC THEN
          IF YESNO('Abort Define process','N') THEN
            CHECKERR(0,TRUE,NEWFILE)
          ELSE
            BEGIN
              IF I = 1 THEN
                BEGIN
                  I := 0;
                  CNT := 1;
                  (*$B 40COL- *)
                  PRESSRETURN(CONCAT('One ',WHAT,' must be defined'), MSG_LINE)
                  (*$E 40COL  *)
                  (*$B 40COL+ *)
                  PRESSRETURN(CONCAT('Must define one ',WHAT), MSG_LINE)
                  (*$E 40COL  *)
                END
              ELSE CNT := I - 1;
              IF THEROWS THEN NO_ROWS := CNT ELSE NO_COLS := CNT;
              SEEKDIR(RECNUMBER,ANDPUT)
            END
        ELSE SEEKCTL(FORM_CTL_FILE,NOT THEROWS,I,ANDPUT)
      END
  END
END;     (* of set_the_ctls *)

PROCEDURE DEFINE;
(* Prompts for form definition attributes and then creates a new entry
   in the freeform directory
*)
VAR ALLOK: BOOLEAN;
BEGIN
  (* see if checkpoint prompts are desired *)
  NO_PROMPT := NOT YESNO('Are checkpoint prompts desired','N');
  (* set directory window variable *)
  SEEKDIR(RECNUMBER,NOTHING);
  DIRECTORY^.FORM_NAME := REQUESTED_FORM;  (* set form name *)
  DIRECTORY^.VERSION   := THEVERSION;      (* set version  *)
  GETUSERID;        (* prompt for user id *)
  GETFORMDESC;      (* prompt for form description *)
  GETDATE;          (* prompt for date created *)
  
  REPEAT
    ALLOK := TRUE;
    (* get number of pages, format control, and constants *)
    SETNUM(1,MAXPAGES,'pages',DIRECTORY^.NO_PAGES,4);
    FORMAT_CHOICE;  (* select row or column formatting *)
    AUTO_CHOICE;    (* automatic month descriptions? *)
    SET_CONSTANTS;  (* get constants desired *)
    IF NOT NO_PROMPT THEN
      ALLOK := NOT YESNO('Anything to change','N')
  UNTIL ALLOK;

  REPEAT         (* Set the Maxes for Rows and Cols as well as actual values *)
    ALLOK := TRUE;
    WITH DIRECTORY^ DO BEGIN   (* get # of rows and columns *)
      (*$B 40COL- *)
      GETNUM(1,MAXCOL,-1,'How many columns might ever be in the FORM ?',
              THEMAXCOL);
      THEMAXROW := ( MAXINT - WINDOWSIZE ) DIV THEMAXCOL;
      GETNUM(1,THEMAXROW,-1,'How many rows might ever be in the FORM ?',
              THEMAXROW);
      (*$E 40COL  *)
      (*$B 40COL+ *)
      GETNUM(1,MAXCOL,-1,'Max cols in FORM ?',THEMAXCOL);
      THEMAXROW := ( MAXINT - WINDOWSIZE ) DIV THEMAXCOL;
      GETNUM(1,THEMAXROW,-1,'Max rows in FORM ?',THEMAXROW);
      (*$E 40COL  *)
      SETNUM(1,THEMAXCOL,'columns',NO_COLS,MSG_LINE-3);
      SETNUM(1,THEMAXROW,'rows',NO_ROWS,MSG_LINE-2);
    END;
    (*$B 40COL- *)
    ALLOK := YESNO('Are the dimensions ok as specified','Y');
    (*$E 40COL  *)
    (*$B 40COL+ *)
    ALLOK := YESNO('Are the dimensions ok','Y');
    (*$E 40COL  *)
  UNTIL ALLOK;

  ONEMOMENT('Updating Directory');
  PUT(DIRECTORY);

END;     (* of define *)

PROCEDURE CREATE_CTLS;     (* Creates form controls *)
VAR  
     AWINDOW: WINDOWTYPE;
     I, ERR: INTEGER;

BEGIN
  ONEMOMENT('Creating Form Control File');
  REWRITE(FORM_CTL_FILE,CONCAT(DISKDRIVE,':',REQUESTED_FORM,'.CTL'));
  CHECKERR(2,TRUE,NEWFILE);
  CTL_OPEN := TRUE;
  WITH DIRECTORY^ DO
    FOR I := 0 TO THEMAXROW+THEMAXCOL DO
      BEGIN  PUT(FORM_CTL_FILE);  CHECKERR(2,TRUE,NEWFILE)  END;
  CLOSE(FORM_CTL_FILE, LOCK);  CTL_OPEN := FALSE;

  ONEMOMENT('Creating Form Data and Titles File');
  REWRITE(FORM_TIT_FILE,CONCAT(DISKDRIVE,':',REQUESTED_FORM,'.TIT'));
  CHECKERR(2,TRUE,NEWFILE);
  FILLCHAR(FORM_TIT_FILE^,L_TITLE+1,0);
  FOR I := 0 TO MAXPAGES DO
    BEGIN PUT(FORM_TIT_FILE);  CHECKERR(2,TRUE,NEWFILE)  END;
  CLOSE(FORM_TIT_FILE,LOCK);
  
  IF OPEN_TIT(REQUESTED_FORM) THEN;
  
  MEMORY;
  
  WITH DIRECTORY^, FORM_DAT_DESC DO BEGIN
    REWRITE(FORM_DAT_FILE,CONCAT(DISKDRIVE,':',REQUESTED_FORM,'.DAT'));
    USEDHEAP := FALSE;
    CHECKERR(2,TRUE,NEWFILE);
    DAT_OPEN := TRUE;
    BLKSPERPAGE := ( (THEMAXROW*THEMAXCOL) + WINDOWSIZE ) DIV ( WINDOWSIZE+1 );
    (* load page titles into title file *)
    PUTMAINHEAD;
    (*$B 40COL- *)
    WRITE(OUTPUT,'FREEFORM Page Parameter Definition for ',REQUESTED_FORM,
                 '  Pages=',NO_PAGES {,'  Memavail=',MEMAVAIL} );
    (*$E 40COL  *)
    (*$B 40COL+ *)
    WRITE(OUTPUT,'FREEFORM Page Def for ',REQUESTED_FORM,
                 '  Pages=',NO_PAGES {,'  Memavail=',MEMAVAIL} );
    (*$E 40COL  *)
    I := 0;
    REPEAT
      I := I + 1;
      SET_PAGE(I,NO_PROMPT,TRUE,NEWFILE,ERR);(* accept page titles, zero form *)
      IF ERR = 2 THEN    (* User pressed ESC *)
        IF NOT YESNO('Abort Define process','N') THEN
          BEGIN
            ERR := 0;
            IF I = 1 THEN
              BEGIN
                I := 0;
                NO_PAGES := 1;
                PRESSRETURN('Must define one Page', MSG_LINE)
              END
            ELSE NO_PAGES := I - 1;
            SEEKDIR(RECNUMBER,ANDPUT);
          END
    UNTIL (ERR <> 0) OR (I >= NO_PAGES);
    IF ERR <> 0 THEN
      BEGIN
        IF ERR = 1 THEN ERROR(2);
        IF (ERR = 2) OR ( (ERR = 1) AND (I = 1) ) THEN
          CHECKERR(0,TRUE,NEWFILE)
        ELSE
          IF YESNO('Is FORM O.K. with fewer Pages','Y') THEN
            BEGIN
              NO_PAGES := I - 1;
              SEEKDIR(RECNUMBER,ANDPUT);
              (* move file ptr back to end of last page *)
              IF BLOCKREAD(FORM_DAT_FILE,AWINDOW,1,BLKSPERPAGE*NO_PAGES-1)=1 THEN
            END
          ELSE CHECKERR(0,TRUE,NEWFILE);
      END;
    CLOSE(FORM_DAT_FILE,CRUNCH);  DAT_OPEN := FALSE
  END;
  
  TIT_OPEN := FALSE;
  CLOSE(FORM_TIT_FILE, LOCK);
  
  MEMORY;
  
  IF OPEN_CTL(REQUESTED_FORM) THEN;
  SET_THE_CTRLS( TRUE );      (* load row parameters into control file *)
  SET_THE_CTRLS( FALSE );     (* load col parameters into control file *)
  CLOSE(FORM_CTL_FILE);
  
  MEMORY;
  
  CTL_OPEN := FALSE;

END;     (* of create_ctls *)

BEGIN     (* DEF *)
  PUTMAINHEAD;
  WRITELN(OUTPUT,'New Forms Definition');
  IF NOT DISK_DIR THEN
    (*$B 40COL- *)
    IF YESNO('Create a New Freeform directory','Y') THEN
    (*$E 40COL  *)
    (*$B 40COL+ *)
    IF YESNO('Create New directory','Y') THEN
    (*$E 40COL  *)
      BEGIN  CREATE;  OPEN_DIR  END
    ELSE
      EXIT(DEF);
  
  MEMORY;
  
  IF GET_FORM_NAME(REQUESTED_FORM, RECNUMBER) THEN
    BEGIN
      DEFINE;       (* prompt for form attributes *)
      CREATE_CTLS;  (* prompt for row & col controls *)
      
      CLOSE(DIRECTORY,LOCK);
      FILEOPEN := FALSE
    END;
END;      (* of def *)


========================================================================================
DOCUMENT :usus Folder:VOL27:ff.forms2.text
========================================================================================

SEGMENT PROCEDURE LIST;

SEGMENT PROCEDURE DIR;     (* Display or list freeform directory *)
BEGIN
  PUTMAINHEAD;
  WRITELN('FREEFORM Directory Listing');
  IF DISK_DIR THEN
    BEGIN
      MEMORY;
      IF YESNO('Listing on Printer','N') THEN
        BEGIN
          SETPRINTER;
          IF PRINTER_ON THEN
            BEGIN  ONEMOMENT('Listing');  DISPLAYDIR(PRINTER,FALSE,TRUE,0)  END
        END
      ELSE
        BEGIN
          DISPLAYDIR(OUTPUT,TRUE,TRUE,0);
          PRESSRETURN('To continue,',MSG_LINE)
        END;
      CLOSE(DIRECTORY);  FILEOPEN := FALSE;
    END
END;      (* of dir *)

SEGMENT PROCEDURE CONTROL;
VAR
    I, BOT_CNT: INTEGER;
    
SEGMENT PROCEDURE DISPLAYCTL(VAR OUTFILE: TXTFILE;  TOSCREEN: BOOLEAN);
VAR
    NUM_CONSTANTS, PAGE: INTEGER;

PROCEDURE NEWPAGE;                      FORWARD;
PROCEDURE DOHEADING;                    FORWARD;
PROCEDURE CHECKIO( ERR: INTEGER );      FORWARD;

SEGMENT PROCEDURE DIS_CONSTS;           FORWARD;
SEGMENT PROCEDURE DIS_PAGE_CTRLS;       FORWARD;
SEGMENT PROCEDURE DIS_RC_CTRLS;         FORWARD;

SEGMENT PROCEDURE DIS_CONSTS;
BEGIN
  WRITELN(OUTFILE);
  WRITELN(OUTFILE,'Calculation constants  : ',DIRECTORY^.NO_CONSTS);
  PRINT_LINE := PRINT_LINE + 8;
  FOR I := 1 TO DIRECTORY^.NO_CONSTS DO
    BEGIN
      IF PRINT_LINE > BOT_CNT THEN
        IF TOSCREEN THEN
          BEGIN PRESSRETURN('More constants..',MSG_LINE); DOHEADING END
        ELSE NEWPAGE;
      PRINT_LINE := PRINT_LINE+1;
      SEEKCON(I,ANDGET);
      NUMTOSTR(IS, FORM_CON_FILE^, MAXWHOLE, 5);
      WRITELN(OUTFILE,'Constant # ',I:3,' = ',IS);
    END;
  CLOSE(FORM_CON_FILE);  CON_OPEN := FALSE
END;   (* of dis_consts *)

SEGMENT PROCEDURE DIS_PAGE_CTRLS;     (* Page controls listing *)
VAR PAGE: INTEGER;

PROCEDURE TITLEIT;
BEGIN
  IF TOSCREEN THEN
    BEGIN
      PRESSRETURN('For page titles',MSG_LINE);
      DOHEADING
    END;
  WRITELN(OUTFILE);
  WRITELN(OUTFILE,'Page Titles are as follows:');
  WRITELN(OUTFILE,'##  Title Description');
  PRINT_LINE := PRINT_LINE+3;
END;  (* of titleit *)

BEGIN  (* DIS_PAGE_CTLS *)
  IF NOT OPEN_TIT(REQUESTED_FORM) THEN CHECKIO(8);
  TITLEIT;
  MEMORY;
  FOR PAGE := 1 TO DIRECTORY^.NO_PAGES DO
    BEGIN   (* Display page titles *)
      IF PRINT_LINE > BOT_CNT THEN
        IF TOSCREEN THEN TITLEIT ELSE NEWPAGE;
      GET(FORM_TIT_FILE);
      WRITELN(OUTFILE,PAGE:2,'  ',FORM_TIT_FILE^);
      PRINT_LINE := PRINT_LINE + 1
    END;
  MEMORY;
  CLOSE(FORM_TIT_FILE);
  TIT_OPEN := FALSE;
END;     (* of dis_page_ctrls *)

SEGMENT PROCEDURE DIS_RC_CTRLS;   (* Display row and column controls *)
VAR
     WHAT: STRING[7];
     I, J, NUM: INTEGER;

PROCEDURE TITLEIT;
BEGIN
  IF TOSCREEN THEN 
    BEGIN
      PRESSRETURN(CONCAT('For ',WHAT,' controls'),MSG_LINE);
      DOHEADING
    END;
  WRITELN(OUTFILE);
  WRITELN(OUTFILE,'Controls for the ',NUM,' defined ',WHAT,
                  's are as follows:');
  WRITELN(OUTFILE,CONTROL_HEADER);
  PRINT_LINE := PRINT_LINE + 3;
END;  (* of titleit *)

PROCEDURE WRITERECORD(RECNUM: INTEGER;  DOINGROW: BOOLEAN);
BEGIN
  IF PRINT_LINE > BOT_CNT THEN
    IF TOSCREEN THEN TITLEIT ELSE NEWPAGE;
  SEEKCTL(FORM_CTL_FILE,NOT DOINGROW,RECNUM,ANDGET);
  WRITEAREC(OUTFILE,RECNUM,FORM_CTL_FILE^);
  PRINT_LINE := PRINT_LINE+1;
END;  (* of writerecord *)

BEGIN   (* DIS_RC_CTRLS *)
  IF NOT OPEN_CTL(REQUESTED_FORM) THEN CHECKIO(4);
  WHAT := 'row'   ;  NUM := DIRECTORY^.NO_ROWS;
  MEMORY;
  TITLEIT;
  FOR I := 1 TO NUM DO  WRITERECORD(I,TRUE);
  WHAT := 'column';  NUM := DIRECTORY^.NO_COLS;
  TITLEIT;
  FOR I := 1 TO NUM DO  WRITERECORD(I,FALSE);
  MEMORY;
  CLOSE(FORM_CTL_FILE);  CTL_OPEN := FALSE;
END;    (* of dis_rc_ctrls *)

PROCEDURE NEWPAGE;
BEGIN
  {WRITELN(OUTFILE,CLEAR);}
  sc_clr_screen;
  PRINT_LINE := 1;
END;

PROCEDURE DOHEADING;
BEGIN
  PUTMAINHEAD;
  WRITELN(OUTFILE);
  WRITELN(OUTFILE,'Form name is -> ',REQUESTED_FORM);
  PRINT_LINE := PRINT_LINE+2;
END;

PROCEDURE CHECKIO{ ERR: INTEGER };
BEGIN
  ERROR(ERR);
  EXIT(DISPLAYCTL)
END;  (* of checkio *)

BEGIN     (* DISPLAYCTL *)
  IF NOT TOSCREEN THEN        (* get printer aligned *)
    BEGIN
      SETPRINTER;
      IF IORESULT <> 0 THEN CHECKIO(3);
      ONEMOMENT('Listing')
    END;
  
  IF TOSCREEN THEN            (* set bot_cnt to point where a tof is needed  *)
    BEGIN  BOT_CNT := MSG_LINE-3;  PUTMAINHEAD  END
  ELSE
    BOT_CNT := PAPER_LENGTH-3;
  
  WITH DIRECTORY^ DO BEGIN
    WRITELN(OUTFILE);
    WRITELN(OUTFILE,'FORM description         : ',FORM_DESC);
    WRITELN(OUTFILE,'FORM name                : ',
       REQUESTED_FORM,'   User ID : ',FORM_ID,'   Date Created : ',FORM_DATE);
    WRITELN(OUTFILE);
    WRITELN(OUTFILE,'# of Pages/Rows/Max Rows/Columns/Max Columns : ',
        NO_PAGES,'/',NO_ROWS,'/',THEMAXROW,'/',NO_COLS,'/',THEMAXCOL);
    WRITE(OUTFILE,'Formatted by ');
    IF FORMAT=FROW THEN  WRITE(OUTFILE,'ROW') ELSE  WRITE(OUTFILE,'COLUMN');
    WRITE(OUTFILE,' --- ');
    IF AUTO_SWITCH=NOAUTO THEN
      WRITE(OUTFILE,'No automatic month headings')
    ELSE
      BEGIN
        WRITE(OUTFILE,'Month Headings by ');
        IF AUTO_SWITCH=AROW THEN  WRITE(OUTFILE,'ROW')
        ELSE WRITE(OUTFILE,'COLUMN');
      END;
    WRITELN(OUTFILE);
    IF NOT OPEN_CON(REQUESTED_FORM) THEN CHECKIO(12);
    MEMORY
  END  (* of with Directory^ *);
  
  DIS_CONSTS;        (* display constants     *)
  DIS_PAGE_CTRLS;    (* Display page controls *)
  DIS_RC_CTRLS;      (* display row  controls *)

  IF NOT TOSCREEN THEN {WRITE(OUTFILE, CLEAR)} sc_clr_screen;
END;     (* of displayctl *)

BEGIN     (* CONTROL *)
  PUTMAINHEAD;
  WRITELN(OUTPUT,'FORM Controls listing');
  IF DISK_DIR THEN      (* Get a disk with a free directory *)
    BEGIN
      IF NAME_FORM(REQUESTED_FORM,RECNUMBER) THEN   (* enter name of form *)
        BEGIN
          MEMORY;
          IF YESNO('Listing on Printer','N') THEN
            DISPLAYCTL(PRINTER,FALSE)
          ELSE
            BEGIN
              DISPLAYCTL(OUTPUT,TRUE);
              PRESSRETURN('To continue,',MSG_LINE)
            END
        END;
      CLOSE(DIRECTORY);
      FILEOPEN := FALSE;
    END
END;     (* of control *)

BEGIN    (* LIST *)
  MEMORY;
  CASE OPTION OF
    3: DIR;
    4: CONTROL;
  END;
END;    (* of list *)


========================================================================================
DOCUMENT :usus Folder:VOL27:ff.forms3.text
========================================================================================

SEGMENT PROCEDURE CHG;
     
PROCEDURE MODIFY;
VAR
     ERR: BOOLEAN;
     I, J, ANS: INTEGER;

FUNCTION CHANGE(WHAT: STRING): BOOLEAN;
(* This asks if WHAT is to be changed.  Returns true if the answer is yes.
   Returns false otherwise.
*)
BEGIN
  CHANGE := YESNO(CONCAT('Change ',WHAT),'N');
END;   (* of change *)

FUNCTION GETNUMFOR(WHAT: STRING;  MAX: INTEGER): INTEGER;
(* This function prompts for a number that tells which WHAT is to be changed.
   It returns a value between 1 and MAX.
*)
VAR  ANS: INTEGER;
BEGIN
  GETNUM(1,MAX,-1,CONCAT('Enter ',WHAT,' # to Change'),ANS);
  GETNUMFOR := ANS;
END;   (* of getnumfor *)

PROCEDURE CHANGEPAGES;
VAR
     ERR, LASTPAGE, NUMPAGES: INTEGER;
     AWINDOW: WINDOWTYPE;
     PAGES: STRING[2];
BEGIN
  SETNUM(1,MAXPAGES,'Pages',LASTPAGE,MSG_LINE);
  ONEMOMENT('Opening Data File');
  WITH FORM_DAT_DESC, DIRECTORY^ DO BEGIN
    RESET(FORM_DAT_FILE,CONCAT(DISKDRIVE,':',REQUESTED_FORM,'.DAT'));
    USEDHEAP := FALSE;
    CHECKERR(5,FALSE,OLDREC);
    DAT_OPEN := TRUE;
    BLKSPERPAGE := ( (THEMAXROW*THEMAXCOL) + WINDOWSIZE ) DIV ( WINDOWSIZE+1 );
    NUMPAGES := NO_PAGES;
    IF LASTPAGE > NUMPAGES THEN  (* need to add pages *)
      BEGIN
        ONEMOMENT('Opening Title file');
        IF NOT OPEN_TIT(REQUESTED_FORM) THEN CHECKERR(8,FALSE,OLDREC);
        REPEAT
          NUMPAGES := NUMPAGES + 1;
          SET_PAGE(NUMPAGES,FALSE,TRUE,NEWREC,ERR); (* get info and add page *)
          IF ERR <> 0 THEN
            BEGIN  IF ERR = 1 THEN ERROR(2);  LASTPAGE := NUMPAGES-1 END
        UNTIL NUMPAGES >= LASTPAGE;
        CLOSE(FORM_TIT_FILE,LOCK);  TIT_OPEN := FALSE
      END;
    (* Position file pointer after last block in the file *)
    IF BLOCKREAD(FORM_DAT_FILE,AWINDOW,1,BLKSPERPAGE*LASTPAGE-1) <> 1 THEN;
    NO_PAGES := LASTPAGE;
    CLOSE(FORM_DAT_FILE,CRUNCH);  DAT_OPEN := FALSE
  END;
  DISPLAYDIR(OUTPUT,TRUE,FALSE,RECNUMBER);  (* display directory record *)
END;   (* of changepages *)

PROCEDURE ROWCHANGE(NUM: INTEGER; COND: SETTYPE;  DISPLAYHEAD: BOOLEAN;
                        VAR ERR: BOOLEAN );
BEGIN
  IF DISPLAYHEAD THEN PUTCTRLHEAD('Row',DIRECTORY^.NO_ROWS);
  SEEKCTL(FORM_CTL_FILE,FALSE,NUM,ANDGET);
  SET_CTRL_REC(FORM_CTL_FILE^,TRUE,NUM,TRUE,ERR,COND);
  IF NOT ERR THEN SEEKCTL(FORM_CTL_FILE,FALSE,NUM,ANDPUT)
END;

PROCEDURE COLCHANGE(NUM: INTEGER; COND: SETTYPE;  DISPLAYHEAD: BOOLEAN;
                        VAR ERR: BOOLEAN );
BEGIN
  IF DISPLAYHEAD THEN PUTCTRLHEAD('Col',DIRECTORY^.NO_COLS);
  SEEKCTL(FORM_CTL_FILE,TRUE,NUM,ANDGET);
  SET_CTRL_REC(FORM_CTL_FILE^,FALSE,NUM,TRUE,ERR,COND);
  IF NOT ERR THEN SEEKCTL(FORM_CTL_FILE,TRUE,NUM,ANDPUT)
END;

PROCEDURE CHANGECTLS(VAR NUM: INTEGER; MAX: INTEGER; DOINGROW: BOOLEAN;
                         WHAT: STRING);
VAR CNT: INTEGER;

PROCEDURE SWAPRECS(FIRST, LAST, OFFSET, DELTA: INTEGER);
VAR
     CNT, K: INTEGER;

BEGIN  (* SWAPRECS *)
  ONEMOMENT(CONCAT('Moving ',WHAT,'s'));
  CNT := FIRST - OFFSET;
  WITH FORM_CTL_FILE^, DIRECTORY^ DO
    WHILE CNT <> (LAST + DELTA + OFFSET) DO  (* swap fields in control file *)
      BEGIN
        CNT := CNT + OFFSET;
        SEEKCTL(FORM_CTL_FILE,NOT DOINGROW,CNT-DELTA,ANDGET);
        SEEKCTL(FORM_CTL_FILE,NOT DOINGROW,CNT      ,ANDPUT)
      END;
  K := 0;
  WITH DIRECTORY^ DO  (* swap data in each page of dat file *)
    REPEAT
      K := K + 1;
      CNT := FIRST - OFFSET;
      WHILE CNT <> (LAST + DELTA + OFFSET) DO
        BEGIN
          CNT := CNT + OFFSET;
          MOVEFORMDATA(DOINGROW,K,CNT-DELTA,CNT);
        END
    UNTIL K = NO_PAGES;
END;   (* of swaprecs *)

PROCEDURE CHANGECALC(VAR CTLREC: CTLRECORD; FOCALPT, DELTA: INTEGER;
                           DELIT: BOOLEAN);
VAR
     I, ANS: INTEGER;
     TEMP: STRING[L_CALC];

FUNCTION ENDOFNUM(START: INTEGER): INTEGER;
BEGIN
  WHILE (START < LENGTH(TEMP)) AND (TEMP[START] IN DIGITS) DO
    START := START + 1;
  ENDOFNUM := START - 1;
END;

BEGIN  (* CHANGECALC *)
  IF CTLREC.CTL_TYPE IN [INITIALC,FINALC] THEN
    WITH CTLREC DO BEGIN
      TEMP := CONCAT(CTL_CALC,'#');
      CTL_CALC := '';
      REPEAT
        IF TEMP[1] IN ['C','c'] THEN I := ENDOFNUM(2)
        ELSE
          IF TEMP[1] IN DIGITS THEN
            BEGIN
              I := ENDOFNUM(1);
              VALUE(TRUE,COPY(TEMP,1,I),FAKE,ANS);
              IF (ANS >= (FOCALPT + DELTA)) AND DELIT THEN ANS := ANS - DELTA
              ELSE IF (ANS >= FOCALPT) AND NOT DELIT THEN  ANS := ANS + DELTA
            END
          ELSE
            BEGIN
              I := 1;
              WHILE (I < LENGTH(TEMP)) AND
                 NOT (TEMP[I] IN (DIGITS + ['C','c'])) DO I := I + 1;
              I := I - 1
            END;
        IF TEMP[1] IN DIGITS THEN
          ENCODE(ANS,IS)
        ELSE
          IS := COPY(TEMP,1,I);
        CTL_CALC := CONCAT(CTL_CALC,IS);
        DELETE(TEMP,1,I)
      UNTIL LENGTH(TEMP) = 1;
    END;
END;   (* of changecalc *)

PROCEDURE DOINSERT;
VAR  NEWCNT, NEWNUM: INTEGER;
BEGIN
  GETNUM(0,NUM,-1,CONCAT('Enter ',WHAT,' # to Insert After'),ANS);
  CNT := MAX - NUM;   (* Maximum number that could be inserted *)
  GETNUM(1,CNT,1,CONCAT('Insert how many ',WHAT,'s ?'),CNT);
  ANS := ANS + 1;
  NUM := NUM + CNT;
  IF (NUM-CNT) >= ANS THEN SWAPRECS(NUM,ANS+1,-1,CNT);
  I := ANS;
  WHILE I <= (ANS + CNT - 1) DO
    BEGIN
      IF DOINGROW THEN ROWCHANGE(I,NEWREC,I=ANS,ERR)
      ELSE             COLCHANGE(I,NEWREC,I=ANS,ERR);
      IF ERR THEN
        BEGIN
          IF YESNO(CONCAT('Abort all ',WHAT,'s inserted'),'N') THEN
            BEGIN  NEWCNT := 0;        NEWNUM := NUM - CNT           END
          ELSE
            BEGIN  NEWCNT := I - ANS;  NEWNUM := NUM + NEWCNT - CNT  END;
          IF (NUM - CNT) >= ANS THEN  SWAPRECS(ANS+NEWCNT,NUM-1,1,NEWCNT-CNT);
          NUM := NEWNUM;
          CNT := NEWCNT
        END
      ELSE I := I + 1
    END;
  IF ( (NUM-CNT) >= ANS ) AND (CNT <> 0) THEN
    BEGIN
      ONEMOMENT('Adjusting calculation strings');
      FOR I := 1 TO NUM DO
        IF NOT (I IN [ANS..ANS+CNT-1]) THEN
          BEGIN
            J := I;
            SEEKCTL(FORM_CTL_FILE,NOT DOINGROW,J,ANDGET);
            CHANGECALC(FORM_CTL_FILE^,ANS,CNT,FALSE);
            SEEKCTL(FORM_CTL_FILE,NOT DOINGROW,J,ANDPUT)
          END
    END
END;   (* of doinsert *)

PROCEDURE DODELETE;
BEGIN
  GETNUM(1,NUM,-1,CONCAT('Enter Starting ',WHAT,' # to Delete'),ANS);
  CNT := NUM - ANS + 1;
  IF CNT = NUM THEN CNT := CNT - 1;  (* don't let all be deleted *)
  GETNUM(1,CNT,1,CONCAT('Delete how many ',WHAT,'s ?'),CNT);
  I := 0;
  REPEAT       (* Display all of the items that will be deleted *)
    GOTOXY(0,MSG_LINE+1);
    SEEKCTL(FORM_CTL_FILE,NOT DOINGROW,ANS+I,ANDGET);
    WRITEAREC(OUTPUT,ANS+I,FORM_CTL_FILE^);
    I := I + 1;
    IF I < CNT THEN
      PRESSRETURN(CONCAT('To see the next ',WHAT),MSG_LINE+2)
  UNTIL I >= CNT;
  ERASE(MSG_LINE+2);
  IF YESNO('Do you still want to Delete','N') THEN
    BEGIN
      ERASE(MSG_LINE+1);
      NUM := NUM - CNT;
      IF (NUM + 1) > ANS THEN
        BEGIN
          SWAPRECS(ANS,NUM+CNT-1,1,-CNT);
          FOR I := 1 TO NUM DO
            BEGIN
              J := I;
              SEEKCTL(FORM_CTL_FILE,NOT DOINGROW,J,ANDGET);
              CHANGECALC(FORM_CTL_FILE^,ANS,CNT,TRUE);
              SEEKCTL(FORM_CTL_FILE,NOT DOINGROW,J,ANDPUT)
            END
        END
    END
  ELSE
    ERASE(MSG_LINE+1)
END;   (* of dodelete *)

BEGIN  (* CHANGECTLS *)
  WHILE CHANGE(CONCAT('Number of ',WHAT,'s')) DO
    WITH FORM_CTL_FILE^, DIRECTORY^ DO BEGIN
      IF NOT DAT_OPEN THEN
        IF NOT OPEN_DAT(REQUESTED_FORM,FORM_DAT_FILE,FORM_DAT_DESC,
                  'FORMS,CHG,MOVEFORMDATA',TRUE) THEN CHECKERR(5,FALSE,OLDREC);
      IF NUM < MAX THEN
        IF YESNO(CONCAT('Insert ',WHAT,'(s)'),'N') THEN DOINSERT;
      IF NUM > 1 THEN                        (* WAS 0, BUG FIX  SDA 8/28/80 *)
        IF YESNO(CONCAT('Delete ',WHAT,'(s)'),'N') THEN DODELETE
    END
END;   (* of changectls *)

BEGIN   (* MODIFY *)
  DISPLAYDIR(OUTPUT,TRUE,FALSE,RECNUMBER);  (* display dir record *)
  ONEMOMENT('Opening Control and Data files');
  IF NOT OPEN_CTL(REQUESTED_FORM) THEN CHECKERR(4,FALSE,OLDREC);
  
  MEMORY;
  
  WITH DIRECTORY^ DO BEGIN
    REPEAT
      IF CHANGE('User ID') THEN GETUSERID;
      IF CHANGE('Form description') THEN GETFORMDESC;
      IF CHANGE('Form creation date') THEN GETDATE;
      IF CHANGE('Number of Pages') THEN CHANGEPAGES;
      IF CHANGE('Number of Constants') THEN
        SETNUM(0,MAXCONSTS,'Constants',NO_CONSTS,MSG_LINE);
      IF DIRECTORY^.NO_CONSTS > 0 THEN
        WHILE CHANGE('Value of a Constant') DO
          BEGIN
            IF NOT CON_OPEN THEN  (* Open file containing Constants *)
              BEGIN
                ONEMOMENT('Opening Constant file');
                IF NOT OPEN_CON(REQUESTED_FORM) THEN CHECKERR(12,FALSE,OLDREC)
              END;
            GET_CONSTANT(GETNUMFOR('Constant',NO_CONSTS),MSG_LINE,TRUE)
          END;
      IF CON_OPEN THEN
        BEGIN  CLOSE(FORM_CON_FILE,LOCK);  CON_OPEN := FALSE  END;
      CHANGECTLS(NO_ROWS,THEMAXROW,TRUE,'Row');
      CHANGECTLS(NO_COLS,THEMAXCOL,FALSE,'Column');
      DISPLAYDIR(OUTPUT,TRUE,FALSE,RECNUMBER)   (* Show changed Dir record *)
    (*$B 40COL- *)
    UNTIL YESNO('Are these new specifications ok','Y');
    (*$E 40COL  *)
    (*$B 40COL+ *)
    UNTIL YESNO('New specifications ok','Y');
    (*$E 40COL  *)

    IF DAT_OPEN THEN
      BEGIN
        ONEMOMENT('Closing Data File');
        CLOSE_DAT(FORM_DAT_FILE,FORM_DAT_DESC,ERR);
        IF ERR THEN ERROR(10)
      END;
    
    REPEAT
      WHILE CHANGE('Page Titles') DO
        BEGIN
          IF NOT TIT_OPEN THEN    (* Open file containing Titles *)
            BEGIN
              ONEMOMENT('Opening Title file');
              IF NOT OPEN_TIT(REQUESTED_FORM) THEN CHECKERR(8,FALSE,OLDREC)
            END;
          ANS := GETNUMFOR('Page',NO_PAGES);
          SET_PAGE(ANS,FALSE,FALSE,OLDREC,I)
        END;
      IF TIT_OPEN THEN
        BEGIN  CLOSE(FORM_TIT_FILE,LOCK);  TIT_OPEN := FALSE  END;
      WHILE CHANGE('Row controls')    DO
        ROWCHANGE(GETNUMFOR('Row',NO_ROWS),OLDREC,TRUE,ERR);
      DISPLAYDIR(OUTPUT,TRUE,FALSE,RECNUMBER);  (* Show changed Dir record *)
      WHILE CHANGE('Column controls') DO
        COLCHANGE(GETNUMFOR('Column',NO_COLS),OLDREC,TRUE,ERR);
      DISPLAYDIR(OUTPUT,TRUE,FALSE,RECNUMBER)   (* Show changed Dir record *)
    (*$B 40COL- *)
    UNTIL YESNO('Are these new specifications ok','Y');
    (*$E 40COL  *)
    (*$B 40COL+ *)
    UNTIL YESNO('New specifications ok','Y');
    (*$E 40COL  *)
  END;
  ONEMOMENT('Updating Directory');
  SEEKDIR(RECNUMBER,ANDPUT);
END;    (* of modify *)

BEGIN   (* CHG *)
  PUTMAINHEAD;
  WRITELN(OUTPUT,'Modify FORM controls');
  IF DISK_DIR THEN
    BEGIN
      IF NAME_FORM(REQUESTED_FORM, RECNUMBER) THEN MODIFY;
      FINISHUP
    END
END;   (* of chg *)


========================================================================================
DOCUMENT :usus Folder:VOL27:ff.forms4.text
========================================================================================

SEGMENT PROCEDURE INITIALIZE;
BEGIN
  QUIT := FALSE;         (* User gave up flag               *)
  NO_PROMPT := TRUE;
  PREV_FORMAT := '####.##';
  CONTROL_HEADER := CONCAT('#####  Description       D/I/F/H  C  ',
                              'Format         Calculation');
  MONTHS[1]  := 'Jan';  MONTHS[2]  := 'Feb';  MONTHS[3]  := 'Mar';
  MONTHS[4]  := 'Apr';  MONTHS[5]  := 'May';  MONTHS[6]  := 'Jun';
  MONTHS[7]  := 'Jul';  MONTHS[8]  := 'Aug';  MONTHS[9]  := 'Sep';
  MONTHS[10] := 'Oct';  MONTHS[11] := 'Nov';  MONTHS[12] := 'Dec';
END;     (* of initialize *)

PROCEDURE BLANKREC;     (* Creates blank directory record *)
BEGIN
  FILLCHAR(DIRECTORY^,SIZEOF(DIRRECORD),0)
END;     (* of blankrec *)

PROCEDURE CHECKERR{ ERRORNUM: INTEGER; DELENTRY: BOOLEAN; COND: SETTYPE };
VAR I: INTEGER;
BEGIN
  IF (ERRORNUM=0) OR (IORESULT <> 0) THEN
    BEGIN
      IF ERRORNUM > 0 THEN ERROR(ERRORNUM);
      IF DELENTRY AND (COND = NEWFILE) THEN
        BEGIN
          OPEN_DIR;
          SEEKDIR(RECNUMBER,ANDGET);
          IF NOT DAT_OPEN THEN
            BEGIN
              RESET(FORM_DAT_FILE,CONCAT(DISKDRIVE,':',REQUESTED_FORM,'.DAT'));
              FORM_DAT_DESC.USEDHEAP := FALSE
            END;
          CLOSE(FORM_DAT_FILE, PURGE);
          DAT_OPEN := FALSE;
          IF FORM_DAT_DESC.USEDHEAP THEN FREEMEM(FORM_DAT_DESC);
          BLANKREC;
          SEEKDIR(RECNUMBER,ANDPUT);
          IF OPEN_CTL(REQUESTED_FORM) THEN;
          CLOSE(FORM_CTL_FILE,PURGE); CTL_OPEN := FALSE;
          IF OPEN_CON(REQUESTED_FORM) THEN;
          CLOSE(FORM_CON_FILE,PURGE); CON_OPEN := FALSE;
          IF OPEN_TIT(REQUESTED_FORM) THEN;
          CLOSE(FORM_TIT_FILE,PURGE); TIT_OPEN := FALSE
        END;
      FINISH_UP;
      EXIT(FORMS)
    END
END; (* of checkerr *)

FUNCTION ABORT{: BOOLEAN };
BEGIN
  ERASE(MSG_LINE-1);
  ERASE(MSG_LINE+1);
  ERASE(MSG_LINE+2);
  PRESSRETURN('Warning ESC was pressed,',MSG_LINE);
  ABORT := YESNO('Do you want to Stop','Y');
  ERASE(MSG_LINE)
END; (* of abort *)

PROCEDURE PUTMAINHEAD;
BEGIN
  {WRITELN(OUTPUT,CLEAR);}
  sc_clr_screen;
  (*$B 40COL- *)
  WRITELN(OUTPUT,'F R E E F O R M   F O R M S   C O N T R O L');
  (*$E 40COL  *)
  (*$B 40COL+ *)
  WRITELN(OUTPUT,'F R E E F O R M   FORMS CONTROL');
  (*$E 40COL  *)
  
  MEMORY;
  
  PRINT_LINE := 2;
END;

PROCEDURE PUTCTRLHEAD{ WHAT: STRING;  NUM: INTEGER };
BEGIN
  PUTMAINHEAD;
  (*$B 40COL- *)
  WRITELN('FREEFORM ',WHAT,' Parameter Definition for ',REQUESTED_FORM,
          '  ',WHAT,'s=',NUM);
  (*$E 40COL  *)
  (*$B 40COL+ *)
  WRITELN('FREEFORM ',WHAT,' Def. for ',REQUESTED_FORM,'  ',WHAT,'s=',NUM);
  (*$E 40COL  *)
  WRITELN(CONTROL_HEADER)
END;

PROCEDURE SETNUM{ MIN, MAX: INTEGER; WHAT: STRING; VAR ANS: INTEGER;
                   LINE: INTEGER };
BEGIN
  GETNUM(MIN,MAX,-1,CONCAT('How many ',WHAT,'?'),ANS);
  PROMPT(CONCAT('Number of ',WHAT,' -> '),LINE);
  WRITE(OUTPUT,ANS);
END;     (* of setnum *)

PROCEDURE GETUSERID;
BEGIN
  GETRESPONSE(TRUE,'Enter user initials ->  ','','   (optional)',
     L_ID,DIRECTORY^.FORMID);
END;

PROCEDURE GETFORMDESC;
BEGIN
  (*$B 40COL- *)
  GETRESPONSE(TRUE,'Enter descriptive comment ->  ','','   (optional)',
     L_DESC,DIRECTORY^.FORM_DESC);
  (*$E 40COL  *)
  (*$B 40COL+ *)
  GETRESPONSE(TRUE,'Form description ->  ','','   (optional)',
     L_DESC,DIRECTORY^.FORM_DESC);
  (*$E 40COL  *)
END;

PROCEDURE GETDATE;
var t_info : sc_info_type;
BEGIN
  sc_use_info ( sc_get, t_info );
  WITH DIRECTORY^,t_info DO BEGIN
    ENCODE(sc_date.DAY,FORM_DATE);
    FORM_DATE := CONCAT(MONTHS[sc_date.MONTH],' ',FORM_DATE);
    GETRESPONSE(TRUE,'Enter today''s date (MMDDYY)  ->  ',FORM_DATE,
               '   (optional)',L_DATE,FORM_DATE)
  END
END;

PROCEDURE GET_CONSTANT{ NUM, LINE: INTEGER;  OLD: BOOLEAN };
VAR  TRASH: INTEGER;
     xdummy : sc_key_command; (**gws*)
     DUMY: CHAR;
BEGIN
  REPEAT
    GOTOXY(0,MSG_LINE);
    sc_erase_to_eol ( 0, msg_line );
    WRITE(OUTPUT,'CONSTANT(',NUM:3,') = -',CRT_CURSOR_LEFT); (**gws*)
    ACCEPTNUM(TRUE,MAXFRAC+MAXWHOLE+2,IS,DUMY,xdummy);
  UNTIL (IS<>'INVALID');
  IF IS = '' THEN IS := '-';
  VALUE(FALSE, IS, FORM_CON_FILE^, TRASH);
  SEEKCON(NUM,ANDPUT);  (* enter constant into the file  SDA 11/25/80 *)
  NUMTOSTR(IS, FORM_CON_FILE^, MAXWHOLE, 5);          (* SDA  9/22/81 *)
  IF NOT OLD THEN                                     (* SDA  9/22/81 *)
    BEGIN
      ERASE(LINE);
      GOTOXY(2,LINE);
      WRITELN(OUTPUT,'CONSTANT(',NUM:3,') = ',IS);
      ERASE(LINE+1)
    END
END;   (* of get_constant *)

PROCEDURE SET_PAGE{ PAGE: INTEGER; NO_PROMPT, NEWPAGE: BOOLEAN; COND: SETTYPE;
                       VAR ERR: INTEGER };
VAR
     ALLOK: BOOLEAN;
     I, J: INTEGER;
     PAGES: STRING[2];
     AWINDOW: WINDOWTYPE;

BEGIN
  ERR := 0;
  ENCODE(PAGE,PAGES);    (* change Page into a string *)
  IF PAGE<10 THEN PAGES := CONCAT(PAGES);
  IF NEWPAGE THEN FORM_TIT_FILE^ := ''      (* initialize Title to nul string *)
  ELSE SEEKTIT(FORM_TIT_FILE,PAGE,ANDGET);  (* Set Title to current value     *)
  REPEAT
    ALLOK := TRUE;
    PROMPT(CONCAT('Enter Title for Page ',PAGES,' (60 chars. max.)'),
           MSG_LINE-1);
    GETRESPONSE(TRUE,'',FORM_TIT_FILE^,'',60,FORM_TIT_FILE^);
    IF FORM_TIT_FILE^ = 'ESCAPE' THEN
      IF ABORT THEN
        BEGIN  ERR := 2;  EXIT( SET_PAGE )  END
      ELSE
        BEGIN  FORM_TIT_FILE^ := '';  ALLOK := FALSE  END
    ELSE
      BEGIN
        ERASE(MSG_LINE-1);
        ERASE(MSG_LINE);
        (* Note: If the title is allowed to be longer than 60 chars then this
           line will cause a string overflow !!!!  *)
        PROMPT('Page ',(PAGE MOD (MSG_LINE-7)) + 4);
        WRITE(PAGE:2,' Title is -> ',FORM_TIT_FILE^);
        ERASE( (PAGE MOD (MSG_LINE-7)) + 5 );
        IF NOT NO_PROMPT THEN
          ALLOK := YESNO('Is Title Correct','Y')
      END
  UNTIL ALLOK;
  SEEKTIT(FORM_TIT_FILE,PAGE,ANDPUT);
  IF NEWPAGE THEN  (* Create a page file *)
    WITH DIRECTORY^, FORM_DAT_DESC DO BEGIN
      ONEMOMENT(CONCAT('Creating Page ',PAGES));
      FOR I := 0 TO WINDOWSIZE DO AWINDOW[I] := EMPTY;
      J := (PAGE-1) * BLKSPERPAGE;
      FOR I := 0 TO BLKSPERPAGE-1 DO
        IF BLOCKWRITE(FORM_DAT_FILE,AWINDOW,1,I+J) <> 1 THEN
          BEGIN  ERR := 1;  EXIT(SET_PAGE)  END
    END
END;     (* of set_page *)

PROCEDURE WRITEAREC{ VAR OUTFILE: TXTFILE; NUM: INTEGER; VAR AREC: CTLRECORD };
VAR
     I: INTEGER;
     CH: CHAR;

BEGIN
  WITH AREC DO BEGIN
    WRITE(OUTFILE,NUM:5,'  ',CTL_DESC,'      ');
    FOR I := 1 TO L_CDESC-LENGTH(CTL_DESC) DO WRITE(OUTFILE,' ');
    CASE CTL_TYPE OF
      DATA:       CH := 'D';
      INITIALC:   CH := 'I';
      HEADING:    CH := 'H';
      FINALC:     CH := 'F'
    END;
    WRITE(OUTFILE,CH,'     ');
    IF CTL_CROSS THEN CH := 'Y' ELSE CH := 'N';
    WRITE(OUTFILE,CH,'  ',CTL_FORMAT,'  ');
    FOR I := 1 TO L_CFORMAT-LENGTH(CTL_FORMAT) DO WRITE(OUTFILE,' ');
    WRITELN(OUTFILE,CTL_CALC);
  END;
END;   (* of writearec *)


========================================================================================
DOCUMENT :usus Folder:VOL27:ff.forms5.text
========================================================================================

PROCEDURE SET_CTRL_REC{ VAR REC: CTLRECORD;  SETTINGROW: BOOLEAN;
                           OFFSET: INTEGER;  NO_PROMPT: BOOLEAN;
                              VAR HITESC: BOOLEAN;  COND: SETTYPE };
  VAR
     OK_KIND: STRING[33];
     WHAT: STRING[7];
     ALLOK: BOOLEAN;
     NUM: STRING[2];
     DEF_CROSS, DEF_TYPE: STRING[1];

PROCEDURE EVALUATE(VAR CALC:STRING);
VAR DUMY: CHAR;

FUNCTION VALID_CALC: BOOLEAN;  (* Calculate string validation *)
(* Returns true if a valid_calc string is given and false otherwise *)
TYPE
     TOKENKINDS = (CONSTV, EOFV, LPARENV, MINUSV, PLUSV, UPARROWV, RPARENV,
                   VALUEV, SLASHV, STARV, BADCONSTV, BADVALUEV, UNRECSYMV);
VAR
     PT: INTEGER;
     OPERATORS: SET OF CHAR;
     TOKENTYPE: TOKENKINDS;

PROCEDURE ERR( REASON: TOKENKINDS );
VAR  
     I: INTEGER;
     MSG: STRING[15];
BEGIN
  IF REASON IN [RPARENV,EOFV,BADCONSTV,BADVALUEV] THEN
    CASE REASON OF
      RPARENV:   MSG := 'Paren missing';
      EOFV:      MSG := 'Unexpected end';
      BADCONSTV: MSG := 'Invalid Const';
      BADVALUEV: IF SETTINGROW THEN MSG := 'Invalid Row'
                 ELSE               MSG := 'Invalid Column';
    END
  ELSE MSG := 'Bad character';
  GOTOXY(1,MSG_LINE+1);
  FOR I := 1 TO PT-1 DO WRITE(OUTPUT,CALC[I]);
  WRITE(OUTPUT,' <-> ');
  DELETE(CALC,LENGTH(CALC),1);   (* remove EOF char *)
  FOR I := PT TO LENGTH(CALC) DO WRITE(OUTPUT,CALC[I]);
  PRESSRETURN(MSG,MSG_LINE+2);
  ERASE(MSG_LINE+2);
  EXIT(VALID_CALC);
END;   (* of err *)

PROCEDURE SCANNER;
VAR
     NUM: INTEGER;
     CH: CHAR;

PROCEDURE SETNUM;
VAR  ENDOFNUM: INTEGER;
BEGIN
  ENDOFNUM := PT + 1;
  WHILE CALC[ ENDOFNUM ] IN DIGITS DO ENDOFNUM := ENDOFNUM + 1;
  VALUE(TRUE,COPY(CALC,PT,ENDOFNUM-PT),FAKE,NUM);
  PT := ENDOFNUM;
END;   (* of setnum *)

PROCEDURE GETCONSTANT;
BEGIN
  TOKENTYPE := BADCONSTV;
  PT := PT + 1;
  IF CALC[ PT ] IN DIGITS THEN
    BEGIN
      SETNUM;
      IF (NUM > 0) AND (NUM <= DIRECTORY^.NO_CONSTS) THEN TOKENTYPE := CONSTV
    END
END;   (* of getconstant *)

PROCEDURE GETVALUE;
BEGIN
  SETNUM;
  IF (NUM > 0) AND
       ((SETTINGROW AND (NUM <= DIRECTORY^.NO_ROWS)) OR
         (NOT SETTINGROW AND (NUM <= DIRECTORY^.NO_COLS))) THEN
      TOKENTYPE := VALUEV
    ELSE
      TOKENTYPE := BADVALUEV;
END;   (* getrcvalue *)

BEGIN  (* SCANNER *)
  IF CALC[ PT ] = ' ' THEN
    REPEAT PT := PT + 1 UNTIL CALC[ PT ] <> ' ';  (* get non blank *)
  CH := CALC[ PT ];
  IF CH IN ['C','c'] THEN GETCONSTANT
  ELSE IF CH IN DIGITS THEN GETVALUE
    ELSE IF CH IN OPERATORS THEN
           BEGIN
             CASE CH OF
               '+': TOKENTYPE:=PLUSV;
               '-': TOKENTYPE:=MINUSV;
               '*': TOKENTYPE:=STARV;
               '/': TOKENTYPE:=SLASHV;
               '^': TOKENTYPE:=UPARROWV;
               '(': TOKENTYPE:=LPARENV;
               ')': TOKENTYPE:=RPARENV;
               '#': TOKENTYPE:=EOFV
             END;
             PT := PT + 1
           END
         ELSE TOKENTYPE := UNRECSYMV;
  IF TOKENTYPE = EOFV THEN PT := PT - 1;
END;   (* of scanner *)

PROCEDURE EXPRESSION;

PROCEDURE PARENEXPRESSION;
BEGIN
  SCANNER;
  EXPRESSION;
  IF TOKENTYPE = RPARENV THEN SCANNER
  ELSE ERR(RPARENV);
END;    (* of parenexpression *)

PROCEDURE PRIMARY;
BEGIN
  IF TOKENTYPE IN [ CONSTV, VALUEV ] THEN SCANNER
  ELSE IF TOKENTYPE = LPARENV THEN PARENEXPRESSION
    ELSE ERR(TOKENTYPE)
END;    (* of primary *)

PROCEDURE FACTOR;
BEGIN
  PRIMARY;
  WHILE TOKENTYPE = UPARROWV DO
    BEGIN
      SCANNER;
      PRIMARY
    END
END;    (* of factor *)

PROCEDURE TERM;
BEGIN
  FACTOR;
  WHILE TOKENTYPE IN [ STARV, SLASHV ] DO
    BEGIN
      SCANNER;
      FACTOR
    END;
END;    (* of term *)

BEGIN   (* EXPRESSION *)
  IF TOKENTYPE IN [ PLUSV, MINUSV ] THEN SCANNER;
  TERM;
  WHILE TOKENTYPE IN [ PLUSV, MINUSV ] DO
    BEGIN
      SCANNER;
      TERM
    END
END;   (* of expression *)

BEGIN     (* VALID_CALC *)
  VALID_CALC := FALSE;
  CALC := CONCAT(CALC,'#');
  OPERATORS := ['+','*','-','/','^','(',')','#'];
  PT := 1;
  SCANNER;
  EXPRESSION;
  IF TOKENTYPE <> EOFV THEN ERR(UNRECSYMV);
  DELETE(CALC,LENGTH(CALC),1);
  VALID_CALC := TRUE
END;     (* of valid_calc *)

BEGIN     (* EVALUATE *)
  (* First released version of Freeform left an equals sign in the first
     position of the calc string.  This version does not and gets rid of
     any it finds.            SDA  9/15/80  *)
  IF POS('=',CALC) = 1 THEN DELETE(CALC,1,1);
  REPEAT
    PROMPT('=',MSG_LINE+1);
    ACCEPTSTR(TRUE,L_CALC-1,1,MSG_LINE+1,CALC,CALC);
    IF CALC='ESCAPE' THEN CALC := ''
  UNTIL VALID_CALC;
  ERASE(MSG_LINE+1);
END;     (* of evaluate *)

PROCEDURE SETTYPE;     (* Set type *)
VAR  TEMP: STRING[7];
BEGIN    (* SETTYPE *)
  REPEAT
    (*$B 40COL- *)
    GETRESPONSE(TRUE,CONCAT('Enter ',WHAT,' ',NUM,
       ' Type (Data, Initial calc, ',OK_KIND,' '),DEF_TYPE,'',1,IS);
    (*$E 40COL  *)
    (*$B 40COL+ *)
    GETRESPONSE(TRUE,CONCAT('Enter ',WHAT,' ',NUM,
       ' Type ',                     OK_KIND,' '),DEF_TYPE,'',1,IS);
    (*$E 40COL  *)
    LCTOUC(IS);
  UNTIL (IS='D') OR (IS='I') OR (IS='F') OR ( SETTINGROW AND (IS='H') );
  WITH REC DO BEGIN
    IF IS='D' THEN CTL_TYPE := DATA
    ELSE
      IF IS='H' THEN CTL_TYPE := HEADING
      ELSE
        BEGIN
          IF IS='F' THEN CTL_TYPE := FINALC ELSE CTL_TYPE := INITIALC;
          EVALUATE(CTL_CALC);
        END;
    IF CTL_TYPE IN [DATA,HEADING] THEN CTL_CALC := '';
    IF CTL_TYPE = HEADING THEN CTL_CROSS := FALSE
    ELSE
      BEGIN
        IF SETTINGROW THEN TEMP := 'Column' ELSE TEMP := 'Row';
        (*$B 40COL- *)
        CTL_CROSS := YESNO(CONCAT('O.K. to set values from ',TEMP,
                           ' calculations'),DEF_CROSS);
        (*$E 40COL  *)
        (*$B 40COL+ *)
        CTL_CROSS := YESNO('Cross calculations O.K.',DEF_CROSS);
        (*$E 40COL  *)
      END;
  END;
END;     (* of settype *)

PROCEDURE SETDESC;     (* Set description *)
BEGIN
  WITH REC DO BEGIN
    GETRESPONSE(TRUE,CONCAT('Enter Description for ',WHAT,' ',NUM,' '),
        CTL_DESC,'',L_CDESC,CTL_DESC);
    IF CTL_DESC='ESCAPE' THEN
      IF ABORT THEN
        BEGIN  HITESC := TRUE;  EXIT( SET_CTRL_REC )  END
      ELSE
        BEGIN  CTL_DESC := '';  SETDESC  END
  END;
END;     (* setdesc *)

PROCEDURE SETFORMAT;   (* Set format *)
VAR
     DECPT, ALLOK: BOOLEAN;
     I: INTEGER;
BEGIN
  WITH REC DO BEGIN
    REPEAT
      REPEAT
        IF CTL_FORMAT = '' THEN CTL_FORMAT := PREV_FORMAT;
        GETRESPONSE(TRUE,CONCAT('Enter ',WHAT,' ',NUM,' Editing Format '),
          CTL_FORMAT,'',L_CFORMAT,CTL_FORMAT);
        IF CTL_FORMAT = 'ESCAPE' THEN CTL_FORMAT := ''
      UNTIL CTL_FORMAT <> '';
      I := 1;  DECPT := FALSE;
      ALLOK := CTL_FORMAT[1] <> '.';  (* illegal to have no #'s before dec pt *)
      WHILE (I <= LENGTH(CTL_FORMAT)) AND ALLOK DO
        BEGIN
          ALLOK := CTL_FORMAT[I] IN ['#','.'];
          IF CTL_FORMAT[I]='.' THEN
            IF NOT DECPT THEN DECPT := TRUE
            ELSE ALLOK := FALSE;
          I := I + 1;
        END;
      IF NOT ALLOK THEN WRITE(OUTPUT,THEBELL)
    UNTIL ALLOK;
    I := POS('.',CTL_FORMAT);
    IF (I > 0) AND ( ( LENGTH(CTL_FORMAT)-I ) > MAXFRAC ) THEN
      DELETE(CTL_FORMAT, I+MAXFRAC+1, LENGTH(CTL_FORMAT)-I-MAXFRAC);
    PREV_FORMAT := CTL_FORMAT;
  END;
END;      (* setformat *)
  
PROCEDURE SETPARAMS;
BEGIN
  HITESC := FALSE;
  WITH REC DO BEGIN
    IF COND IN [NEWFILE, NEWREC] THEN
      BEGIN
        CTL_DESC   := '';
        CTL_FORMAT := '';
        CTL_CALC   := '';
        CTL_TYPE   := DATA;
        CTL_CROSS  := TRUE
      END;
    CASE CTL_TYPE OF
      DATA:       DEF_TYPE := 'D';
      INITIALC:   DEF_TYPE := 'I';
      HEADING:    DEF_TYPE := 'H';
      FINALC:     DEF_TYPE := 'F'
    END;
    IF CTL_CROSS THEN DEF_CROSS := 'Y' ELSE DEF_CROSS := 'N'
  END;
  ENCODE(OFFSET,NUM);    (* change Offset into a string *)
  IF SETTINGROW THEN
    BEGIN
      WHAT := 'Row';
      (*$B 40COL- *)
      OK_KIND := 'Final calc, or Heading (D/I/F/H)'
      (*$E 40COL  *)
      (*$B 40COL+ *)
      OK_KIND := '(D/I/F/H)'
      (*$E 40COL  *)
    END
  ELSE
    BEGIN
      WHAT := 'Column';
      (*$B 40COL- *)
      OK_KIND := 'or Final calc (D/I/F)'
      (*$E 40COL  *)
      (*$B 40COL+ *)
      OK_KIND := '(D/I/F)'
      (*$E 40COL  *)
    END;
END;

PROCEDURE DISPLAYCTLS;
VAR  Y: INTEGER;
BEGIN
  Y := ( OFFSET MOD ( MSG_LINE-7 ) ) + 5;
  ERASE(Y);
  WRITEAREC(OUTPUT,OFFSET,REC);
  ERASE(Y+1);
END;   (* of display ctls *)

BEGIN  (* SET_CTRL_REC *)
  SETPARAMS;
  REPEAT
    ALLOK := TRUE;
    WITH REC, DIRECTORY^  DO BEGIN
      IF COND = OLDREC THEN DISPLAYCTLS;
      IF ( (SETTINGROW AND (AUTO_SWITCH=AROW)) OR
          ((NOT SETTINGROW) AND (AUTO_SWITCH=ACOL)) ) AND (COND = NEWFILE) THEN
        CTL_DESC := MONTHS[ ( ( START_MONTH+OFFSET-2 ) MOD 12 ) + 1 ]
      ELSE
        BEGIN  (* set description up *)
          SETDESC;
          SETTYPE
        END;
      IF ( (SETTINGROW AND (FORMAT=FROW)) OR
            ((NOT SETTINGROW) AND (FORMAT=FCOL)) ) AND
           (CTL_TYPE <> HEADING)                          THEN
        SETFORMAT
      ELSE
        CTL_FORMAT := '';
      DISPLAYCTLS;
      IF NOT ( NO_PROMPT OR
          ( ( ( SETTINGROW AND (AUTO_SWITCH=AROW) AND (FORMAT=FCOL) ) OR
            ( (NOT SETTINGROW) AND (AUTO_SWITCH=ACOL) AND (FORMAT=FROW) ) ) AND
              (COND=NEWFILE) ) ) THEN
        ALLOK := YESNO(CONCAT('Are Controls for ',WHAT,' ',NUM,' ok'),'Y');
    END;
  UNTIL ALLOK;
END   (* of set_ctrl_rec *);
 
PROCEDURE DISPLAYDIR{ VAR OUTFILE: TXTFILE; TOSCREEN, ALL: BOOLEAN;
                       RECNUMBER: INTEGER };
(* Displays freeform directory entries if ALL is true or an entry if ALL is
   false.  Starts displaying with the RECNUMBER entry
*)
VAR
     BOT_CNT: INTEGER;
     CURRENT, AUTOKIND, THEFORMAT: CHAR;
     SPACES: STRING;
     
PROCEDURE PUTDIRHEAD;
BEGIN
  (*$B 40COL- *)
  WRITELN(OUTFILE,'F R E E F O R M   D I R E C T O R Y   L I S T I N G');
  (*$E 40COL  *)
  (*$B 40COL+ *)
  WRITELN(OUTFILE,'F R E E F O R M  DIRECTORY  LISTING');
  (*$E 40COL  *)
  WRITELN(OUTFILE);
  WRITELN(OUTFILE,
    ' FORM NAME  ID   DATE   DESCRIPTION            PAGES  ROWS   COLS   F  M');
  WRITELN(OUTFILE,
    ' =========  ==   ====   ===========            =====  =====  =====  =  =');
  PRINT_LINE := 4;
  IF TOSCREEN AND ALL THEN
    BEGIN
      PROMPT('* indicates FORM not useable with this Version of FREEFORM',
                             MSG_LINE+2);
      GOTOXY(0,PRINT_LINE)
    END
END;
  
BEGIN     (* DISPLAYDIR *)
  SPACES := '                                ';
  IF TOSCREEN THEN BOT_CNT := MSG_LINE-3 ELSE BOT_CNT := PAPER_LENGTH-3;
  IF TOSCREEN THEN {WRITE(OUTFILE,CLEAR)} sc_clr_screen;
  PUTDIRHEAD;
  WITH DIRECTORY^ DO
    WHILE (RECNUMBER<DIRSIZE) AND (FORM_NAME<>'') DO
      BEGIN
        PRINT_LINE := PRINT_LINE +1;
        IF PRINT_LINE > BOT_CNT THEN
          BEGIN
            IF TOSCREEN THEN PRESSRETURN('To continue',MSG_LINE);
            {WRITE(OUTFILE,CLEAR);}
            sc_clr_screen;
            PUTDIRHEAD
          END;
        
        IF THEVERSION = VERSION THEN CURRENT := ' ' ELSE CURRENT := '*';
        
        IF FORMAT=FROW THEN THEFORMAT := 'R' ELSE THEFORMAT := 'C';
        CASE AUTO_SWITCH OF
          NOAUTO: AUTOKIND := ' ';
          AROW  : AUTOKIND := 'R';
          ACOL  : AUTOKIND := 'C'
        END;
        
        WRITELN(OUTFILE,
                CURRENT,
                FORM_NAME,COPY(SPACES,1,(L_NAME-LENGTH(FORM_NAME))),'   ',
                FORM_ID,  COPY(SPACES,1,(L_ID-LENGTH(FORM_ID))),'  ',
                FORM_DATE,COPY(SPACES,1,(L_DATE-LENGTH(FORM_DATE))),'  ',
                FORM_DESCRIPTION,COPY(SPACES,1,
                  (L_DESC-LENGTH(FORM_DESCRIPTION))),'     ',
                NO_PAGES:3,'  ',NO_ROWS:5,'  ',NO_COLS:5,'  ',
                THEFORMAT,'  ',AUTOKIND);
          
        IF ALL THEN
          BEGIN RECNUMBER := RECNUMBER +1; GET(DIRECTORY) END
        ELSE RECNUMBER := DIRSIZE
      END;   (* of WHILE *)
  
  IF NOT TOSCREEN THEN {WRITE(OUTFILE,CLEAR)} sc_clr_screen;
END;     (* of displaydir *)

BEGIN    (* FORMS *)
  INITIALIZE;
  CASE OPTION OF
    1: DEF;
    2: CHG;
    3: LIST;
    4: LIST;
  END;
  FINISHUP;
END;    (* of forms *)



========================================================================================
DOCUMENT :usus Folder:VOL27:ff.freefrm.text
========================================================================================

(*XL LISTING.TEXT *)
(*$I- *)
(*$D 40COL- *)
PROGRAM FREEFORM;
(**********************************************************************)
(*                                                                    *)
(*        FREEFORM                                Jan  5, 1982        *)
(*        ========                                                    *)
(*                                                 _________          *)
(*                                                /         \         *)
(*        By S. Dale Ander                        | Version |         *)
(*           Texas Instruments Incorporated       |   F.4   |         *)
(*                                                \_________/         *)
(*                                                                    *)
(*                                                                    *)
(*                                                                    *)
(*                                                                    *)
(**********************************************************************) 

                {USES (*$U KERNEL.CODE *)    KERNEL;}
                     uses screenops     (       sc_key_command,
                                                sc_map_crt_command,
                                                sc_use_info,
                                                sc_clr_screen,
                                                sc_choice,
                                                sc_info_type,
                                                sc_date_rec,
                                                sc_chset,
                                                sc_misc_rec,
                                                sc_erase_to_eol); 
                                        { comment out the selective uses
                                          list if you don't have IV.1x  gws}
CONST
     MAXWHOLE   = 13;   (* max digits before decimal point     *)
     MAXFRAC    = 11;   (* max digits after  decimal point     *)
     ZEROS      = '000000000000';      (* MAXFRAC + 1  zeros   *)
     MAXCOL     = 101;  (* max # cols allowed in one form      *)
     MAXCONSTS  = 200;  (* number of consts allowed to be defined in a form *)
     MAXPAGES   = 100;  (* number of pages allowed in one form *)
     DIRSIZE    = 30;   (* size of freeform directory          *)

     L_NAME     = 8;    (* length of a form name *)
     L_ID       = 2;    (* length of form id     *)
     L_DATE     = 6;    (* length of form date   *)
     L_DESC     = 20;   (* length of form descr. *)
     L_CDESC    = 15;   (* length of ctrl descr. *)
     L_CFORMAT  = 13;   (* length of ctrl format *)
     L_CALC     = 59;   (* length of calc string *)
     L_TITLE    = 60;   (* length of page title  *)

     WINDOWSIZE  = 63;     (* Number of numbers less 1 that fit in 1 block *)
     MAXLISTSIZE = 31;     (* Max number of blocks that can be kept in mem *)

     DIRNAME        = 'FREEFORM.DIR';

     THEVERSION  = 'V4';   (* Validation string stored in directory *)
     VERSIONDATE = 'Sep 24, 1983';
     
TYPE
     TXTFILE = TEXT;

     NUMBERTYPE = REAL;          (* Changed these to Reals   SDA   3/25/80 *)
     BIGNUMTYPE = REAL;

     DIRRECORD = PACKED RECORD
                   FORM_NAME:    STRING[L_NAME];
                   FORM_ID:      STRING[L_ID];
                   FORM_DATE:    STRING[L_DATE];     (* Date of creation *)
                   FORM_DESC:    STRING[L_DESC];
                   VERSION:      PACKED ARRAY[1..02] OF CHAR;
                   FILLER:       PACKED ARRAY[1..52] OF CHAR; (* Space holder *)
                   FORMAT:       (FROW,FCOL);        (* Row or Col formatted  *)
                   AUTO_SWITCH:  (NOAUTO,AROW,ACOL); (* Automatic headings?   *)
                   START_MONTH:  0..12;
                   THEMAXROW:    INTEGER;
                   THEMAXCOL:    INTEGER;
                   NO_CONSTS:    INTEGER;
                   NO_PAGES:     INTEGER;
                   NO_ROWS:      INTEGER;
                   NO_COLS:      INTEGER;
                 END;

     TYPE_CTL = (DATA,INITIALC,HEADING,FINALC);

     CTLRECORD = PACKED RECORD
                   CTL_DESC:     STRING[L_CDESC];
                   CTL_FORMAT:   STRING[L_CFORMAT];
                   FILLER:       PACKED ARRAY[1..2] OF CHAR; (* for expansion *)
                   CTL_CALC:     STRING[L_CALC];
                   FILLER2:      PACKED ARRAY[1..2] OF CHAR;
                   CTL_TYPE:     TYPE_CTL;
                   CTL_CROSS:    BOOLEAN;
                 END;
   
     CFILE = FILE OF CTLRECORD;
     
     TITLETYPE = STRING[L_TITLE];
     
     TFILE = FILE OF TITLETYPE;
     
     ACTIONTYPE = ( NOTHING, ANDGET, ANDPUT );
     
     LISTRANGE = 0..MAXLISTSIZE;
     WINDOWTYPE = PACKED ARRAY[0..WINDOWSIZE] OF NUMBERTYPE;
     AFILE = FILE;
     FILEDESC = PACKED RECORD
                  BLKSPERPAGE: INTEGER;
                  LIST: PACKED ARRAY[LISTRANGE] OF
                          PACKED RECORD
                            DPAGE:   INTEGER;
                            DBLOCK:  INTEGER;
                            START:   INTEGER;
                            WINDOW:  ^WINDOWTYPE;
                            BEFORE:  LISTRANGE;
                            AFTER:   LISTRANGE;
                            CHANGED: BOOLEAN
                          END;
                  LISTHEAD, LISTTAIL, FREEHEAD: LISTRANGE;
                  USEDHEAP: BOOLEAN
                END;
     

VAR
   DIGITS: SET OF CHAR;
   MAX, FAKE, ZERO, EMPTY, OVERFLOW: NUMBERTYPE;
   PRINTER_ON, FILEOPEN, CTL_OPEN, DAT_OPEN, TIT_OPEN,
     CON_OPEN, QUIT, NO_PROMPT: BOOLEAN;
   IS: STRING;
   PAPER_LENGTH, CHARS_PER_LINE, S_HEIGHT, S_WIDTH, MSG_LINE, I: INTEGER;
   {HOME, CURSOR_UP, CURSOR_DOWN, CURSOR_LEFT, CURSOR_RIGHT,}
    ESCAPE, TAB, {CLEAR,
     ERASELINE,} SPACE, ENTER, {INSKEY, DELKEY,} THEBELL,{ ERASEFIELD,}
       ERASEINPUT, ABACKSPACE, CRT_CURSOR_LEFT: CHAR;{ not all of these are
                                                        used }
   DIRECTORY: FILE OF DIRRECORD;
   FORM_TIT_FILE: TFILE;
   FORM_CTL_FILE: CFILE;
   FORM_DAT_FILE: AFILE;
   FORM_DAT_DESC: FILEDESC;
   FORM_CON_FILE: FILE OF NUMBERTYPE;
   PRINTER: TEXT;
   OPTION, RECNUMBER: INTEGER;
   DISKDRIVE: STRING[3];
   REQUESTED_FORM: STRING[L_NAME];
   DASHES: STRING[60];
   TEMP_FILE_NAME: STRING[7];
   DEBUGMODE, FIRSTTIMESEEN: BOOLEAN;          (* SDA 11/14/80 *)

PROCEDURE NUMBER( VAR DAT_FILE: AFILE;  VAR DAT_DESC: FILEDESC;  
                     PAGE, ROW, COL: INTEGER;  VAR NUM: NUMBERTYPE;
                       WHAT: ACTIONTYPE;  VAR ERR: BOOLEAN );  FORWARD;
PROCEDURE VALUE(  RETURNINTEGER: BOOLEAN;  INSTRING: STRING;
                  VAR REALANS: NUMBERTYPE;  VAR INTANS: INTEGER );  FORWARD;
PROCEDURE PROMPT( MSG: STRING;  Y: INTEGER);  FORWARD;
PROCEDURE ONEMOMENT ( REASON: STRING );  FORWARD;
PROCEDURE PRESSRETURN( MSG: STRING;  Y: INTEGER);  FORWARD;
PROCEDURE GETRESPONSE( ANY: BOOLEAN;  LMSG, DEFAULT, RMSG: STRING;
                          LEN: INTEGER;  VAR RESPONSE: STRING);  FORWARD;
PROCEDURE ERASE ( LINE: INTEGER );  FORWARD;
FUNCTION  YESNO(  MSG, DEFAULT: STRING ):  BOOLEAN;  FORWARD;
PROCEDURE LCTOUC( VAR INSTRING: STRING);  FORWARD;
PROCEDURE OPENDIR;  FORWARD;
PROCEDURE FREEMEM( VAR DAT_DESC: FILEDESC );  FORWARD;
FUNCTION  OPEN_DAT ( REQUESTED_FORM: STRING;  VAR DAT_FILE: AFILE;
                        VAR DAT_DESC: FILEDESC;  ISEGS: STRING;
                             MAX: BOOLEAN ): BOOLEAN;
  FORWARD;
PROCEDURE CLOSE_DAT ( VAR DAT_FILE: AFILE;  VAR DAT_DESC: FILEDESC;
                         VAR ERR: BOOLEAN );  FORWARD;
FUNCTION  OPEN_CON ( RGQUESTED_FORM: STRING ): BOOLEAN;  FORWARD;
FUNCTION  OPEN_CTL ( REQUESTED_FORM: STRING ): BOOLEAN;  FORWARD;
FUNCTION  OPEN_TIT ( REQUESTED_FORM: STRING ): BOOLEAN;  FORWARD;
PROCEDURE SEEKDIR ( REC: INTEGER;  WHAT: ACTIONTYPE );  FORWARD;
PROCEDURE SEEKCON ( REC: INTEGER;  WHAT: ACTIONTYPE );  FORWARD;
PROCEDURE SEEKCTL ( VAR CTL_FILE: CFILE;  COL: BOOLEAN;  REC: INTEGER;
                        WHAT: ACTIONTYPE );  FORWARD;
PROCEDURE SEEKTIT ( VAR TIT_FILE: TFILE;  REC: INTEGER;  WHAT: ACTIONTYPE );
  FORWARD;
PROCEDURE FINISH_UP;  FORWARD;
PROCEDURE ERROR( INDEX: INTEGER );  FORWARD;
FUNCTION  SEARCH( VAR LOC: INTEGER;  NAME: STRING ): BOOLEAN;  FORWARD;
PROCEDURE GETNUM(MIN,THEMAX,DEFAULT: INTEGER; WHAT: STRING; VAR ANS: INTEGER);
  FORWARD;
PROCEDURE ENCODE( NUM: INTEGER;  VAR ANS: STRING );  FORWARD;

PROCEDURE MEMORY;  FORWARD;


SEGMENT PROCEDURE INITIALIZE;    FORWARD;
SEGMENT PROCEDURE HELP;          FORWARD;
SEGMENT PROCEDURE DEL;           FORWARD;
SEGMENT PROCEDURE MISC;          FORWARD;
SEGMENT PROCEDURE DATAIN;        FORWARD;
SEGMENT PROCEDURE FORMS;         FORWARD;
SEGMENT PROCEDURE COPYFORM;      FORWARD;
SEGMENT PROCEDURE SETPREFIX;     FORWARD;
SEGMENT PROCEDURE PRINTMENU;     FORWARD;
SEGMENT PROCEDURE CHOOSEOPTION;  FORWARD;
SEGMENT PROCEDURE NUMTOSTR(VAR ANS: STRING; NUM: NUMBERTYPE;
                             BEFORE, AFTER: INTEGER );             FORWARD;
SEGMENT FUNCTION  FIGURE( VAR Z: NUMBERTYPE;  X, Y: NUMBERTYPE;
                             OP: CHAR ): BOOLEAN;                  FORWARD;
SEGMENT PROCEDURE MOVEFORMDATA ( AROW: BOOLEAN; PAGE, SOURCE, DEST: INTEGER );
                                 FORWARD;
SEGMENT PROCEDURE SETPRINTER;    FORWARD;
SEGMENT FUNCTION  DISK_DIR: BOOLEAN;                               FORWARD;
SEGMENT FUNCTION  NAME_FORM( VAR REQUESTED_FORM: STRING;
                                VAR RECNUMBER: INTEGER): BOOLEAN;  FORWARD;
SEGMENT FUNCTION  GET_FORM_NAME( VAR REQUESTED_FORM: STRING;
                                VAR RECNUMBER: INTEGER): BOOLEAN;  FORWARD;
SEGMENT PROCEDURE ACCEPTNUM( ARROW: BOOLEAN;  MAX_LENGTH: INTEGER;
                                 VAR IS: STRING;  VAR CH: CHAR;
                                 var which_key : sc_key_command );  FORWARD;
SEGMENT PROCEDURE ACCEPTSTR( ANY: BOOLEAN;  MAX_LENGTH, X, Y: INTEGER;
                              DEFAULT: STRING;  VAR IS: STRING );  FORWARD;

(*$I FF.MISC1.TEXT    *)
(*$I FF.MISC2.TEXT    *)
(*$I FF.DATA1.TEXT    *)
(*$I FF.DATA2.TEXT    *)
(*$I FF.DATA3.TEXT    *)
(*$I FF.DATA4.TEXT    *)
(*$I FF.DATA5.TEXT    *)
(*$I FF.FORMS1.TEXT   *)
(*$I FF.FORMS2.TEXT   *)
(*$I FF.FORMS3.TEXT   *)
(*$I FF.FORMS4.TEXT   *)
(*$I FF.FORMS5.TEXT   *)
(*$I FF.COPY1.TEXT    *)
(*$I FF.COPY2.TEXT    *)
(*$I FF.BASICS1.TEXT  *)
(*$I FF.BASICS2.TEXT  *)
(*$I FF.BASICS3.TEXT  *)

BEGIN     (* FREEFORM *)
  INITIALIZE;
  REPEAT
    PRINT_MENU;
    CHOOSE_OPTION;
    CASE OPTION OF
      0: DATAIN;
      1: FORMS;
      2: FORMS;
      3: FORMS;
      4: FORMS;
      5: MISC;
      6: MISC;
      7: COPYFORM;
      8: DEL;
      9: HELP;
     10: DEBUGMODE := NOT DEBUGMODE;
     11: SETPREFIX
    END
  UNTIL FALSE;
END.


========================================================================================
DOCUMENT :usus Folder:VOL27:ff.misc1.text
========================================================================================

SEGMENT PROCEDURE INITIALIZE;
VAR
     TRIX:  RECORD CASE BOOLEAN OF
              TRUE: (A: CHAR);
              FALSE:(B: 0..255)
            END;
     I: INTEGER;
     backspace : char;
     THISID, SSN, PID: STRING;
     t_info : sc_info_type;

PROCEDURE ALARM;
CONST
     WAITTIME = 75;
     FILLCH = 25;
VAR
     DELAY: INTEGER;
     LINE: PACKED ARRAY[0..255] OF CHAR;
     STATUS_REC: ARRAY[0..29] OF INTEGER;

BEGIN
  {
  WRITE(OUTPUT,CLEAR,CHR(150));             (* erase screen then turn it off *)
  IF S_WIDTH > 255 THEN S_WIDTH := 255;
  FILLCHAR(LINE,S_WIDTH,CHR(FILLCH));
  FOR I := 1 TO S_HEIGHT DO                 (* fill screen with Fillch       *)
    BEGIN
      GOTOXY(0,I-1);
      UNITWRITE(2,LINE,S_WIDTH)
    END;
  }
  sc_clr_screen;
  GOTOXY((S_WIDTH - LENGTH(IS)) DIV 2,(S_HEIGHT DIV 2) - 1);
  WRITE(OUTPUT,IS);                         (* write msg in center of screen *)
  {
  I := 0;                                   (* when I = 0 the screen is off  *)
  REPEAT
    WRITE(OUTPUT,THEBELL,CHR(150));
    I := 1 - I;
    FOR DELAY := 1 TO WAITTIME DO;
    UNITSTATUS( 2,STATUS_REC,1 )
  UNTIL STATUS_REC[0] > 0;
  UNITREAD( 2, LINE, STATUS_REC[0], , 1 );
  IF I = 0 THEN WRITE(OUTPUT,CHR(150));
  }
  EXIT( PROGRAM )
END;   (* of alarm *)

BEGIN  (* INITIALIZE *)
  
    {WITH SYSCOM^ DO BEGIN
      WITH EXPANINFO DO            (* Addition  SDA  9/22/81 *)
        BEGIN
          INSKEY       := INSCHAR;
          DELKEY       := DELCHAR;
        END;
        
      WITH CRTINFO DO
        BEGIN
          CURSOR_UP    := UP;
          CURSOR_DOWN  := DOWN;
          CURSOR_LEFT  := LEFT;
          CURSOR_RIGHT := RIGHT;
          ABACKSPACE   := BACKSPACE;
          ESCAPE       := ALTMODE;
          ENTER        := ETX;
          ERASEINPUT   := LINEDEL;
          S_HEIGHT     := HEIGHT;
          S_WIDTH      := WIDTH
        END;

      WITH CRTCTRL DO
        BEGIN
          CRT_CURSOR_LEFT := BACKSPACE;
          CLEAR           := CLEARSCREEN;
          ERASELINE       := ERASEEOL
        END  
    END;

  HOME       := CHR(130);
  SPACE      := CHR(32);
  TAB        := CHR(9);
  THEBELL    := CHR(7);
  ERASEFIELD := CHR(128);
  }
  backspace := chr ( 8 );
  space := chr ( 32 );
  tab := chr ( 9 );
  thebell := chr ( 7 );
  crt_cursor_left := backspace;
  abackspace := backspace;
  sc_use_info ( sc_get, t_info );
  s_height := t_info.misc_info.height;
  s_width  := t_info.misc_info.width;
  
  (*$R-   *)
  DASHES[0] := CHR(60);
  FILLCHAR(DASHES[1],60,CHR(95{+128}));  (* a low intensity underline *)
                                        (** not on my terminal!!! gws *)
  (*$R^   *)
  
  MSG_LINE := S_HEIGHT - 3;
  
  DISKDRIVE := '';        (* use prefixed drive until told otherwise *)

  TEMP_FILE_NAME := 'FFTEMP';   (* Set the temp file name to FFTEMP then    *)
  FOR I := 1 TO 6 DO            (* turn it into low intensity so there's no *)
    BEGIN                       (* chance of writing over an existing file  *)
      TRIX.A := TEMP_FILE_NAME[I];
      TRIX.B := TRIX.B + 128;  {this puts the temp file in the directory
                                with the high order bit set.  If you bomb
                                the program with this file created, you 
                                will have to use the Filer wildcard options
                                to delete it. - gws }
      TEMP_FILE_NAME[I] := TRIX.A
    END;
    

  REQUESTED_FORM := '';
  RECNUMBER := 0;
  
  DIGITS := ['0'..'9'];
  
  FILEOPEN := FALSE;      (* Directory file status flag      *)
  CTL_OPEN := FALSE;      (* Control file status flag        *)
  DAT_OPEN := FALSE;      (* Data file status flag           *)
  TIT_OPEN := FALSE;      (* Title file status flag          *)
  PRINTER_ON := FALSE;    (* Printer status flag             *)

  ZERO := 0.0;
  
  MAX := PWROFTEN( MAXWHOLE );
  OVERFLOW := MAX + 1;    (* Special code to represent an overflow     *)
  EMPTY    := MAX + 2;    (* Special code to represent an empty number *)
  
  CHARS_PER_LINE := 132;
  PAPER_LENGTH   := 66;
  
  FIRSTTIMESEEN := TRUE;  (* If FIRSTTIMESEEN is true show copyright   *)
  DEBUGMODE := FALSE;
END;   (* of initialize *)

SEGMENT PROCEDURE HELP;

  PROCEDURE OUT(MSG, WHERE: STRING);
  BEGIN
    WRITELN(OUTPUT,'  ',MSG,' - Sec. ',WHERE);
  END;

BEGIN
  {WRITELN(OUTPUT,CLEAR);}
  sc_clr_screen;
  WRITELN(OUTPUT,'F R E E F O R M   H E L P');
  WRITELN(OUTPUT);
  WRITELN(OUTPUT);
  WRITELN(OUTPUT,'For Help with:');
  WRITELN(OUTPUT);
  (*$B 40COL- *)
  OUT('What Freeform is and what it can do','8.1');
  OUT('Defining a Form','8.2');
  OUT('Using a Form - Data entry procedures','8.3');
  OUT('Listing Form controls and the Freeform Directory','8.4');
  OUT('Modifying Forms','8.5');
  OUT('Delete, Roll and Copy Utilities','8.6');
  OUT('Consolidation Utility','8.7');
  (*$E 40COL  *)
  (*$B 40COL+ *)
  OUT('What Freeform is','8.1');
  OUT('Defining a Form','8.2');
  OUT('Using a Form - Data entry','8.3');
  OUT('Listing Form controls','8.4');
  OUT('Listing Freeform Directory','8.4');
  OUT('Modifying Forms','8.5');
  OUT('Delete Utility','8.6');
  OUT('Roll Utility','8.6');
  OUT('Copy Utility','8.6');
  OUT('Consolidation Utility','8.7');
  (*$E 40COL  *)
  WRITELN(OUTPUT);
  (*$B 40COL- *)
  WRITELN(OUTPUT,'Note:  Above references are to the PCIF Users Manual');
  (*$E 40COL  *)
  (*$B 40COL+ *)
  WRITELN(OUTPUT,'Note: Above refs. are to the PCIF Manual');
  (*$E 40COL  *)
  MEMORY;
  PRESSRETURN('To continue,',MSG_LINE);
END;   (* of help *)

SEGMENT PROCEDURE DEL;  (* Deletes the RECNUMBER entry in Freeform directory *)
VAR  SWAPREC: INTEGER;
BEGIN
  {WRITELN(OUTPUT,CLEAR);}
  sc_clr_screen;
  WRITELN(OUTPUT,'F R E E F O R M   D E L E T E');
  WRITELN(OUTPUT,'Delete an existing Form');
  MEMORY;
  IF NOT DISKDIR THEN EXIT(DEL);
  IF NOT NAME_FORM(REQUESTED_FORM,RECNUMBER) THEN EXIT(DEL);
  (*$B 40COL- *)
  IF YESNO(CONCAT('Are you sure you want to Delete ',REQUESTED_FORM),'N') THEN
  (*$E 40COL  *)
  (*$B 40COL+ *)
  IF YESNO(CONCAT('Delete ',REQUESTED_FORM),'N') THEN
  (*$E 40COL  *)
    BEGIN
      (* delete the title, dat and ctl files *)
      ONEMOMENT('Removing Control, Title and Data files');
      RESET(FORM_DAT_FILE,CONCAT(DISKDRIVE,':',REQUESTED_FORM,'.DAT'));
      CLOSE(FORM_DAT_FILE,PURGE); DAT_OPEN := FALSE;
      IF OPEN_CON(REQUESTED_FORM) THEN;
      CLOSE(FORM_CON_FILE,PURGE); CON_OPEN := FALSE;
      IF OPEN_CTL(REQUESTED_FORM) THEN;
      CLOSE(FORM_CTL_FILE,PURGE); CTL_OPEN := FALSE;
      IF OPEN_TIT(REQUESTED_FORM) THEN;
      CLOSE(FORM_TIT_FILE,PURGE); TIT_OPEN := FALSE;
      (* zap directory entry and shift the rest of the entries *)
      IF SEARCH(SWAPREC,'') THEN;  (* Set swaprec one past last entry *)
      SWAPREC := SWAPREC - 1;      (* now it points at the last entry *)
      (* take the last entry *)
      SEEKDIR(SWAPREC,ANDGET);
      (* and put it in the spot that contains the entry to delete *)
      SEEKDIR(RECNUMBER,ANDPUT);
      (* blank out the spot that the moved entry was in *)
      FILLCHAR(DIRECTORY^,SIZEOF(DIRRECORD),0); (* Use Fillchar now  SDA 3/19 *)
      SEEKDIR(SWAPREC,ANDPUT);
      REQUESTED_FORM := ''                      (* Addition       SDA 5/19/81 *)
    END;
  FINISHUP
END;    (* of del *)

SEGMENT PROCEDURE MISC;
VAR
     TEMP_DAT_FILE: AFILE;
     TEMP_DAT_DESC: FILEDESC;
     
SEGMENT FUNCTION OPEN_DAT_TEMP( VAR NAME: STRING ): BOOLEAN;  FORWARD;
SEGMENT PROCEDURE ROLL;            FORWARD;
SEGMENT PROCEDURE CONSOLIDATE;     FORWARD;

SEGMENT FUNCTION OPEN_DAT_TEMP{( VAR NAME: STRING ): BOOLEAN };
VAR
     AWINDOW: WINDOWTYPE;
     I: INTEGER;
     
BEGIN
  OPEN_DAT_TEMP := FALSE;
  NAME := CONCAT(DISKDRIVE,':',TEMP_FILE_NAME,'.DAT');
  REWRITE(TEMP_DAT_FILE,NAME);
  IF IORESULT <> 0 THEN ERROR(11)
  ELSE
    BEGIN
      FOR I := 0 TO WINDOWSIZE DO AWINDOW[I] := EMPTY;
      WITH DIRECTORY^, TEMP_DAT_DESC DO BEGIN
        BLKSPERPAGE := ( (THEMAXROW*THEMAXCOL) + WINDOWSIZE ) DIV
                                  ( WINDOWSIZE + 1 );
        USEDHEAP := FALSE;
        FOR I := 1 TO BLKSPERPAGE DO
          IF BLOCKWRITE(TEMP_DAT_FILE,AWINDOW,1) <> 1 THEN
            BEGIN
              CLOSE(TEMP_DAT_FILE,PURGE);
              ERROR(11);
              EXIT(OPEN_DAT_TEMP)
            END
      END;
      OPEN_DAT_TEMP := TRUE;    (* file created successfully *)
      CLOSE(TEMP_DAT_FILE,LOCK)
    END
END;   (* of open_temp_file *)

SEGMENT PROCEDURE ROLL;
VAR
     WHAT: STRING[6];
     DIR: STRING[5];
     CNT, MAX: INTEGER;
     LEFT, DOROWS: BOOLEAN;
     TEMP_CTL_FILE: CFILE;
     DAT_TEMP, CTL_TEMP: STRING[17];

SEGMENT FUNCTION OPEN_CTL_TEMP( VAR NAME: STRING ): BOOLEAN;
(* This Function returns true if it was able to open a temporary Control file
   and initialize it with the contents of FORM_CTL_FILE  *)
VAR  I: INTEGER;
BEGIN
  OPEN_CTL_TEMP := FALSE;
  NAME := CONCAT(DISKDRIVE,':',TEMP_FILE_NAME,'.CTL');
  REWRITE(TEMP_CTL_FILE,NAME);
  IF IORESULT <> 0 THEN ERROR(11)
  ELSE
    BEGIN
      WITH DIRECTORY^ DO BEGIN
        FOR I := 0 TO THEMAXROW+THEMAXCOL DO
          BEGIN
            PUT(TEMP_CTL_FILE);
            IF IORESULT <> 0 THEN
              BEGIN
                CLOSE(TEMP_CTL_FILE,PURGE);
                ERROR(11);
                EXIT(OPEN_CTL_TEMP)
              END;
            GET(FORM_CTL_FILE);
            TEMP_CTL_FILE^ := FORM_CTL_FILE^
          END
      END;
      OPEN_CTL_TEMP := TRUE;    (* file created successfully *)
      CLOSE(TEMP_CTL_FILE,LOCK)
    END
END;

PROCEDURE GATHERCONTROLS;

PROCEDURE LEAVE;                (* Added  SDA 6/26/81 *)
BEGIN
  CNT := 0;
  EXIT(GATHERCONTROLS)
END;

BEGIN
  REPEAT
    GETRESPONSE(TRUE,'Roll Row or Columns ? (R/C) ','C','',1,IS);
    LCTOUC(IS);
  UNTIL (IS = 'R') OR (IS = 'C') OR (IS = 'ESCAPE');
  IF IS = 'ESCAPE' THEN LEAVE;  (* Change  SDA 6/26/81 *)
  DOROWS := IS = 'R';
  IF DOROWS THEN
    BEGIN  MAX := DIRECTORY^.NO_ROWS-1;  WHAT := 'Row'     END
  ELSE
    BEGIN  MAX := DIRECTORY^.NO_COLS-1;  WHAT := 'Column'  END;
  IF MAX = 0 THEN               (* Change  SDA 6/26/81 *)
    BEGIN
      PRESSRETURN(CONCAT('Only one ',WHAT,' to Roll'),MSG_LINE);
      LEAVE
    END;
  IF DOROWS THEN
    REPEAT
      GETRESPONSE(TRUE,'Roll Rows Down or Up ? (D/U) ','D','',1,IS);
      LCTOUC(IS);
    UNTIL (IS = 'D') OR (IS = 'ESCAPE') OR (IS = 'U')
  ELSE
    REPEAT
      GETRESPONSE(TRUE,'Roll Columns Left or Right ? (L/R) ','L','',1,IS);
      LCTOUC(IS);
    UNTIL (IS = 'L') OR (IS = 'ESCAPE') OR (IS = 'R');
  IF IS = 'ESCAPE' THEN LEAVE;  (* Change  SDA 6/26/81 *)
  LEFT := (IS = 'L') OR (IS = 'U');
  IF LEFT THEN
    IF DOROWS THEN DIR := 'Up' ELSE DIR := 'Left'
  ELSE
    IF DOROWS THEN DIR := 'Down' ELSE DIR := 'Right';
  REPEAT
    (*$B 40COL- *)
    GETNUM(0,MAX,-1,CONCAT('Enter # of ',WHAT,'s to roll ',DIR),CNT);
    (*$E 40COL  *)
    (*$B 40COL+ *)
    GETNUM(0,MAX,-1,CONCAT('# ',WHAT,'s to roll ',DIR),CNT);
    (*$E 40COL  *)
  UNTIL YESNO(CONCAT('Is ',IS,' correct'),'Y');
END;   (* of gathercontrols *)

PROCEDURE ROLLIT;
VAR
     I, J, PTR, PAGES: INTEGER;
     ERR, NOCALCS: BOOLEAN;
     NUM: NUMBERTYPE;

PROCEDURE ADJUST(VAR C_STRING: STRING;  MODNUM: INTEGER);
VAR
     I, ANS: INTEGER;
     TEMP: STRING[L_CALC];
     
FUNCTION ENDOFNUM(START: INTEGER): INTEGER;
BEGIN
  WHILE (START < LENGTH(TEMP)) AND (TEMP[START] IN DIGITS) DO
    START := START + 1;
  ENDOFNUM := START - 1;
END;

BEGIN
  LCTOUC(C_STRING);               (* Convert C_STRING to caps *)
  TEMP := CONCAT(C_STRING,'#');
  C_STRING := '';
  REPEAT
    IF TEMP[1] = 'C' THEN I := ENDOFNUM(2)
    ELSE
      IF TEMP[1] IN DIGITS THEN
        BEGIN
          I := ENDOFNUM(1);
          VALUE(TRUE,COPY(TEMP,1,I),FAKE,ANS);
          ANS := ( ( ANS + MODNUM - CNT - 1 ) MOD MODNUM ) + 1;
        END
      ELSE
        BEGIN
          I := 1;
          WHILE (I < LENGTH(TEMP)) AND NOT (TEMP[I] IN DIGITS) AND
                (TEMP[I] <> 'C') DO I := I + 1;
          I := I - 1
        END;
    IF TEMP[1] IN DIGITS THEN
      ENCODE(ANS,IS)
    ELSE
      IS := COPY(TEMP,1,I);
    C_STRING := CONCAT(C_STRING,IS);
    DELETE(TEMP,1,I)
  UNTIL LENGTH(TEMP) = 1;
END;   (* of adjust *)

PROCEDURE MOVEROWNUMS;
BEGIN
  WITH DIRECTORY^ DO
    FOR I := 1 TO NO_ROWS DO    (* move rows   *)
      BEGIN
        PTR := ( (I + CNT - 1) MOD NO_ROWS ) + 1;
        FOR J := 1 TO NO_COLS DO
          BEGIN
            NUMBER(TEMP_DAT_FILE,TEMP_DAT_DESC,1,    PTR,J,NUM,ANDGET,ERR);
            NUMBER(FORM_DAT_FILE,FORM_DAT_DESC,PAGES,I,  J,NUM,ANDPUT,ERR)
          END
      END
END;   (* of moverownums *)

PROCEDURE MOVECOLNUMS;
BEGIN
  WITH DIRECTORY^ DO
    FOR I := 1 TO NO_COLS DO    (* move columns *)
      BEGIN
        PTR := ( (I + CNT - 1) MOD NO_COLS ) + 1;
        FOR J := 1 TO NO_ROWS DO
          BEGIN
            NUMBER(TEMP_DAT_FILE,TEMP_DAT_DESC,1,    J,PTR,NUM,ANDGET,ERR);
            NUMBER(FORM_DAT_FILE,FORM_DAT_DESC,PAGES,J,I,  NUM,ANDPUT,ERR)
          END
      END
END;   (* of movecolnums *)

PROCEDURE MOVEROWCTLS;
BEGIN
  WITH FORM_CTL_FILE^, DIRECTORY^ DO
    FOR I := 1 TO NO_ROWS DO
      BEGIN
        SEEKCTL(TEMP_CTL_FILE,FALSE,( ( I+CNT-1 ) MOD NO_ROWS ) + 1,ANDGET);
        FORM_CTL_FILE^ := TEMP_CTL_FILE^;
        IF LENGTH(CTL_CALC) > 0 THEN ADJUST(CTL_CALC,NO_ROWS);
        SEEKCTL(FORM_CTL_FILE,FALSE,I,ANDPUT)
      END
END;   (* of moverowctls *)

PROCEDURE MOVECOLCTLS;
BEGIN
  WITH FORM_CTL_FILE^, DIRECTORY^ DO
    FOR I := 1 TO NO_COLS DO
      BEGIN
        SEEKCTL(TEMP_CTL_FILE,TRUE,( ( I+CNT-1 ) MOD NO_COLS ) + 1,ANDGET);
        FORM_CTL_FILE^ := TEMP_CTL_FILE^;
        IF LENGTH(CTL_CALC) > 0 THEN ADJUST(CTL_CALC,NO_COLS);
        SEEKCTL(FORM_CTL_FILE,TRUE,I,ANDPUT)
      END
END;   (* of movecolctls *)

BEGIN  (* ROLLIT *)
  MEMORY;
  WITH DIRECTORY^ DO BEGIN
    IF NOT LEFT THEN  (* moving right, change CNT *)
      IF DOROWS THEN CNT := NO_ROWS - CNT ELSE CNT := NO_COLS - CNT;
    (* Move Data now *)
    IF OPEN_DAT(REQUESTED_FORM,FORM_DAT_FILE,FORM_DAT_DESC,'ROLL',FALSE) THEN;
    IF OPEN_DAT(TEMP_FILE_NAME,TEMP_DAT_FILE,TEMP_DAT_DESC,'ROLL',TRUE) THEN;
    FOR PAGES := 1 TO NO_PAGES DO
      BEGIN
        ENCODE(PAGES,IS);    (* Change Pages into a string *)
        ONEMOMENT(CONCAT('Rolling Page # ',IS,' now'));
        (* Set Temp file equal to file to be rolled *)
        FOR I := 1 TO NO_ROWS DO
          FOR J := 1 TO NO_COLS DO
            BEGIN
              NUMBER(FORM_DAT_FILE,FORM_DAT_DESC,PAGES,I,J,NUM,ANDGET,ERR);
              NUMBER(TEMP_DAT_FILE,TEMP_DAT_DESC,1,    I,J,NUM,ANDPUT,ERR)
            END;
        IF DOROWS THEN MOVEROWNUMS ELSE MOVECOLNUMS
      END;
    ONEMOMENT('Closing Data File');
    FREEMEM(TEMP_DAT_DESC);
    CLOSE(TEMP_DAT_FILE);
    CLOSE_DAT(FORM_DAT_FILE,FORM_DAT_DESC,ERR);
    (* Move Controls now *)
    ONEMOMENT(CONCAT('Rolling ',WHAT,' descriptions now'));
    IF OPEN_CTL(REQUESTED_FORM) THEN;                 (* re-open CTL files *)
    RESET(TEMP_CTL_FILE,CTL_TEMP);

    MEMORY;

    IF DOROWS THEN MOVEROWCTLS ELSE MOVECOLCTLS;
    CLOSE(TEMP_CTL_FILE)
  END
END;   (* of rollit *)

BEGIN  (* ROLL *)
  {WRITELN(OUTPUT,CLEAR);}
  sc_clr_screen;
  WRITELN(OUTPUT,'F R E E F O R M   R O L L');
  WRITELN(OUTPUT,'Roll an existing Form');
  MEMORY;
  IF DISKDIR THEN
    IF NAME_FORM(REQUESTED_FORM,RECNUMBER) THEN
      BEGIN
        ONEMOMENT('Searching for Control and Data files');
        IF NOT OPEN_CTL(REQUESTED_FORM) THEN ERROR(4)
        ELSE
          BEGIN
            RESET(FORM_DAT_FILE,CONCAT(DISKDRIVE,':',REQUESTED_FORM,'.DAT'));
            IF IORESULT <> 0 THEN ERROR(5)
            ELSE
              BEGIN
                CLOSE(FORM_DAT_FILE);   (* Leave CTL file open though *)
                ONEMOMENT('Opening Temp Files');
                IF OPEN_DAT_TEMP( DAT_TEMP ) THEN
                  BEGIN
                    IF OPEN_CTL_TEMP( CTL_TEMP ) THEN
                      BEGIN
                        CLOSE(FORM_CTL_FILE);  CTL_OPEN := FALSE;
                        GATHERCONTROLS;
                        IF CNT > 0 THEN ROLLIT;
                        RESET(TEMP_CTL_FILE, CTL_TEMP);
                        CLOSE(TEMP_CTL_FILE, PURGE);
                      END;
                    RESET(TEMP_DAT_FILE, DAT_TEMP);
                    CLOSE(TEMP_DAT_FILE, PURGE)
                  END
              END
          END
      END;
  FINISHUP
END;   (* of roll *)


========================================================================================
DOCUMENT :usus Folder:VOL27:ff.misc2.text
========================================================================================

SEGMENT PROCEDURE CONSOLIDATE;
VAR
     CALC: STRING[L_CALC];
     CONSPAGE: INTEGER;
     OPERATORS: SET OF CHAR;
     DAT_TEMP: STRING[17];
     VOL: STRING[7];
     FNAME: STRING[10];
     
PROCEDURE EVALUATE;
VAR
     CH: CHAR;
     PT: INTEGER;

FUNCTION VALID_CALC: BOOLEAN;

PROCEDURE ERR(WHAT: INTEGER);
VAR MSG: STRING[17];
     I: INTEGER;
BEGIN
  CASE WHAT OF
    1: MSG := 'Invalid Page';
    2: MSG := 'Bad character';
    3: MSG := 'Unexpected end';
    4: MSG := 'Invalid Constant'
  END;
  GOTOXY(1,MSG_LINE);
  FOR I := 1 TO PT-1 DO WRITE(OUTPUT,CALC[I]);
  WRITE(OUTPUT,' <-> ');
  DELETE(CALC,LENGTH(CALC),1);   (* remove EOF character *)
  FOR I := PT TO LENGTH(CALC) DO WRITE(OUTPUT,CALC[I]);
  PRESSRETURN(MSG,MSG_LINE+1);
  ERASE(MSG_LINE+1);
  EXIT(VALID_CALC)
END;

PROCEDURE SCANNER;
(* This procedure sets the variable PT that is the index into CALC,
   sets CH to the character just scanned,
   and calls ERR if something is wrong.
*)
VAR  NUM, ENDOFNUM: INTEGER;

  FUNCTION SETNUM: BOOLEAN;
  BEGIN
    IF CH IN DIGITS THEN  (* set NUM *)
      BEGIN
        ENDOFNUM := PT + 1;
        WHILE CALC[ ENDOFNUM ] IN DIGITS DO ENDOFNUM := ENDOFNUM + 1;
        VALUE(TRUE, COPY(CALC,PT,ENDOFNUM-PT), FAKE, NUM);
        PT := ENDOFNUM;
        SETNUM := TRUE
      END
    ELSE SETNUM := FALSE
  END;
  
BEGIN  (* SCANNER *)
  IF CALC[PT] = SPACE THEN
    REPEAT PT := PT + 1 UNTIL CALC[ PT ] <> SPACE;  (* get non-blank *)
  CH := CALC[ PT ];
  IF SETNUM THEN
    IF (NUM < 1) OR (NUM > DIRECTORY^.NO_PAGES) THEN ERR(1)
    ELSE              (* Have a valid Page reference *)
  ELSE
    IF CH IN OPERATORS THEN PT := PT + 1 ELSE
    IF CH = 'C' THEN  (* at a possible constant *)
      BEGIN
        PT := PT + 1;
        CH := CALC[ PT ];
        IF SETNUM THEN
          IF (NUM < 1) OR (NUM > DIRECTORY^.NO_CONSTS) THEN ERR(4)
          ELSE        (* have a valid Constant reference *)
        ELSE ERR(2)
      END
    ELSE ERR(2);
  IF CH = '#' THEN PT := PT - 1
END;   (* of scanner *)

BEGIN  (* VALID_CALC *)
  VALID_CALC := FALSE;
  SCANNER;                           (* get first thing to consolidate *)
  IF CH = '#' THEN ERR(3);           (* if nothing there then error   *)
  IF NOT (CH IN DIGITS) THEN ERR(2);
  SCANNER;                           (* get first operator *)
  WHILE (CH IN OPERATORS) AND (CH <> '#') DO
    BEGIN
      SCANNER;                                (* skip operator *)
      IF NOT (CH IN DIGITS) THEN              (* have a number ? *)
        IF CH = '#' THEN ERR(3) ELSE ERR(2);  (* No ! *)
      SCANNER;                                (* skip number *)
    END;
  IF CH <> '#' THEN ERR(3);  (* make sure no more string is left *)
  VALID_CALC := TRUE
END;   (* of valid_calc *)

BEGIN  (* EVALUATE *)
  REPEAT
    PROMPT('Enter Consolidation Control',MSG_LINE-1);
    PROMPT('=',MSG_LINE);
    ACCEPTSTR(TRUE,L_CALC-1,1,MSG_LINE,CALC,CALC);
    IF CALC = 'ESCAPE' THEN
      BEGIN
        FREEMEM(TEMP_DAT_DESC);
        CLOSE(TEMP_DAT_FILE,PURGE);
        FINISHUP;
        EXIT(CONSOLIDATE)
      END;
    LCTOUC(CALC);
    PT := 1;
    CALC := CONCAT(CALC,'#');
  UNTIL VALID_CALC;
  PROMPT('Consolidation -> ',MSG_LINE-1);
  DELETE(CALC,LENGTH(CALC),1);
  WRITE(OUTPUT,CONSPAGE,'=',CALC);
END;

PROCEDURE MATH;
VAR
     NUM, PT, ROW, COL, I, J: INTEGER;
     NUMBER1, NUMBER2: NUMBERTYPE;
     ERR, ACONST: BOOLEAN;
     CH, OP: CHAR;

PROCEDURE SCANNER( VAR ACONST: BOOLEAN );
(* This procedure sets the variable PT that is the index into CALC,
   sets CH to the character just scanned,
   sets PAGE to a page number if it was legal.
*)
VAR  ENDOFNUM: INTEGER;

  PROCEDURE SETNUM;
  BEGIN
    ENDOFNUM := PT + 1;
    WHILE CALC[ ENDOFNUM ] IN DIGITS DO ENDOFNUM := ENDOFNUM + 1;
    VALUE(TRUE, COPY(CALC,PT,ENDOFNUM-PT), FAKE, NUM);
    PT := ENDOFNUM
  END;

BEGIN  (* SCANNER *)
  ACONST := FALSE;
  IF CALC[PT] = SPACE THEN
    REPEAT PT := PT + 1 UNTIL CALC[ PT ] <> SPACE;  (* get non-blank *)
  CH := CALC[ PT ];
  IF CH IN DIGITS THEN SETNUM              (* set Page number *)
  ELSE
    IF CH = 'C' THEN
      BEGIN  ACONST := TRUE;  PT := PT + 1;  SETNUM  END  (* set Const number *)
    ELSE
      IF CH IN OPERATORS THEN PT := PT + 1;
  IF CH = '#' THEN PT := PT - 1
END;   (* of scanner *)

PROCEDURE GETVALUE( VAR ACONST: BOOLEAN );
BEGIN
  SCANNER( ACONST );
  IF ACONST THEN     (* Thing was a constant, init NUMBER1 to it *)
    BEGIN
      SEEKCON(NUM,ANDGET);
      NUMBER1 := FORM_CON_FILE^
    END;
END;

BEGIN  (* MATH *)
  ONEMOMENT('Consolidation in Progress');
  
  MEMORY;
  
  PT := 1;
  CALC := CONCAT(CALC,'#');
  GETVALUE( ACONST );
  WITH DIRECTORY^ DO BEGIN
    FOR I := 1 TO NO_ROWS DO       (* initialize temp page *)
      FOR J := 1 TO NO_COLS DO
        BEGIN
          IF NOT ACONST THEN       (* set THENUMBER *)
            NUMBER(FORM_DAT_FILE,FORM_DAT_DESC,NUM,I,J,NUMBER1,ANDGET,ERR);
          NUMBER(TEMP_DAT_FILE,TEMP_DAT_DESC,1,I,J,NUMBER1,ANDPUT,ERR)
        END;
    SCANNER( ACONST );             (* get operator *)
    WHILE (CH IN OPERATORS) AND (CH <> '#') DO
      BEGIN
        OP := CH;                  (* Save operator *)
        GETVALUE( ACONST );
        FOR I := 1 TO NO_ROWS DO   (* do math *)
          FOR J := 1 TO NO_COLS DO
            BEGIN
              IF NOT ACONST THEN       (* set NUMBER1 *)
                NUMBER(FORM_DAT_FILE,FORM_DAT_DESC,NUM,I,J,NUMBER1,ANDGET,ERR);
              NUMBER(TEMP_DAT_FILE,TEMP_DAT_DESC,1,I,J,NUMBER2,ANDGET,ERR);
              IF FIGURE(NUMBER2,NUMBER2,NUMBER1,OP) THEN;
              NUMBER(TEMP_DAT_FILE,TEMP_DAT_DESC,1,I,J,NUMBER2,ANDPUT,ERR);
            END;
        SCANNER( ACONST )
      END;
    ONEMOMENT('Saving Consolidated Page');
    FOR I := 1 TO NO_ROWS DO
      FOR J := 1 TO NO_COLS DO
        BEGIN
          NUMBER(TEMP_DAT_FILE,TEMP_DAT_DESC,1,I,J,NUMBER1,ANDGET,ERR);
          NUMBER(FORM_DAT_FILE,FORM_DAT_DESC,CONSPAGE,I,J,NUMBER1,ANDPUT,ERR)
        END
  END;
  DELETE(CALC,LENGTH(CALC),1)  (* Delete the EOF character *)
END;   (* of math *)

PROCEDURE DOCONSOL;

PROCEDURE OPENOUTPUTFILE( OLD: BOOLEAN );
BEGIN
  REPEAT
    GETRESPONSE(TRUE, 'Volume Name: ',VOL, ':', 7, VOL);
    IF VOL   = 'ESCAPE' THEN EXIT(DOCONSOL);
    GETRESPONSE(TRUE, 'File Name: ', FNAME, '.TEXT', 10, FNAME);
    IF FNAME = 'ESCAPE' THEN EXIT(DOCONSOL);
    IF OLD THEN   RESET(PRINTER, CONCAT(VOL,':',FNAME,'.TEXT'))
    ELSE        REWRITE(PRINTER, CONCAT(VOL,':',FNAME,'.TEXT'));
    PRINTER_ON := IORESULT = 0;
    IF NOT PRINTER_ON THEN
      PRESSRETURN(CONCAT('Unable to open ',VOL,':',FNAME,'.TEXT'),MSG_LINE)
  UNTIL PRINTER_ON
END;   (* of open output file *)

PROCEDURE CLOSEFILE;
BEGIN
  CLOSE(PRINTER, LOCK);  PRINTER_ON := FALSE
END;   (* of close file *)

BEGIN  (* DOCONSOL *)
  IF YESNO('Is there a Control file to use','N') THEN
    BEGIN
      OPENOUTPUTFILE(TRUE);
      READLN(PRINTER,CONSPAGE);
      READLN(PRINTER,CALC);
      CLOSEFILE
    END;
  (*$B 40COL- *)
  GETNUM(1,DIRECTORY^.NO_PAGES,CONSPAGE,'Enter Consolidation Page #',CONSPAGE);
  (*$E 40COL  *)
  (*$B 40COL+ *)
  GETNUM(1,DIRECTORY^.NO_PAGES,CONSPAGE,'Consol Page #',CONSPAGE);
  (*$E 40COL  *)
  EVALUATE;
  IF YESNO('Perform Consolidation','Y') THEN MATH;
  ERASE(MSG_LINE-1);
  (*$B 40COL- *)
  IF YESNO('Save this information in a Control file','N') THEN
  (*$E 40COL  *)
  (*$B 40COL+ *)
  IF YESNO('Save info in Control file','N') THEN
  (*$E 40COL  *)
    BEGIN
      OPENOUTPUTFILE(FALSE);
      WRITELN(PRINTER,CONSPAGE);
      WRITELN(PRINTER,CALC);
      CLOSEFILE
    END
END;   (* of do consols *)

BEGIN  (* CONSOLIDATE *)
  OPERATORS := ['+','-','*','/','^','#'];
  {WRITELN(OUTPUT,CLEAR);}
  sc_clr_screen;
  (*$B 40COL- *)
  WRITELN(OUTPUT,'F R E E F O R M   C O N S O L I D A T I O N');
  (*$E 40COL  *)
  (*$B 40COL+ *)
  WRITELN(OUTPUT,'F R E E F O R M   CONSOLIDATION');
  (*$E 40COL  *)
  
  MEMORY;
  
  IF DISK_DIR THEN
    IF NAME_FORM(REQUESTED_FORM, RECNUMBER) THEN
      BEGIN
        ONEMOMENT('Opening Constant, Data and Temp files');
        IF NOT OPEN_CON(REQUESTED_FORM) THEN ERROR(12) ELSE
          IF NOT OPEN_DAT(REQUESTED_FORM,FORM_DAT_FILE,FORM_DAT_DESC,
                            'CONSOLIDATE,FIGURE',FALSE) THEN ERROR(5)
          ELSE
            IF OPEN_DAT_TEMP( DAT_TEMP ) THEN
              BEGIN
                IF OPEN_DAT(TEMP_FILE_NAME,TEMP_DAT_FILE,TEMP_DAT_DESC,
                              'CONSOLIDATE,FIGURE',TRUE) THEN;
                
  MEMORY;
    
                VOL := DISKDRIVE;  FNAME := '';  CALC := '';  CONSPAGE := -1;
                
                REPEAT
                  DOCONSOL
                UNTIL NOT YESNO(CONCAT('More to Consolidate in ',
                                                          REQUESTED_FORM),'N');
                FREEMEM(TEMP_DAT_DESC);
                CLOSE(TEMP_DAT_FILE,PURGE)
              END
      END;
  FINISHUP
END;   (* of consolidate *)

BEGIN  (* MISC *)
  CASE OPTION OF
    5: CONSOLIDATE;
    6: ROLL
  END
END;   (* of misc *)


========================================================================================
DOCUMENT :usus Folder:VOL27:readme.1st.text
========================================================================================


     FreeForm is a 3-D spreadsheet.  It is very useful in certain types
of problems and useless in others.

     FreeForm assumes that calculations are done on entire rows or columns at a
time and the results are deposited in other entire rows or columns.  It
therefore is well suited to ledger sheets sort of applications.  The 3-D nature
becomes apparent when you realize that you can set up a sheet, for example, for
each month's activity of a business.  Each month's sheet can be stacked behind
the next month's sheet and year end consolidations can be done on all twelve
sheets to end up with grand totals.  Up to 100 sheets (all must be of identical
format) can be stacked.

     FreeForm does not allow calculations of individual cells so that it is
nearly useless in an application such as a tax calculator.  You pays your money
and takes your chances.

     FreeForm uses real numbers for all of it calculations so that 4 word reals
are necessary to obtain any kind of precision.  A 2 word real version is
provided for those that don't have 4 word reals on their iron, but its use 
is strictly limited as dollar figures can only be represented to $9,999.99
before you start losing track of the odd cents.  Also, if you build data files
with two word reals, and then switch to 4 word reals, THE DATA WILL NOT BE
COMPATIBLE!!!

     The screen control features of FreeForm have been modified extensively
by the reviewer (yours truly, gws) to allow the software to be transported
to different types of terminals.  The author used the screen control values
found in KERNEL to obtain the values of the arrow keys and such.  However, he
did not allow for terminals with two-character sequences (such as an H-19). The
use of KERNEL also made the program un-compilable on most hardware without
extended memory as the compilation of KERNEL uses up most of memory for mere
mortal iron.

     The program has been modified to eliminate the dependance on KERNEL.
It now uses SCREENOPS instead.  In this way it becomes terminal independant.
However, since SCREENOPS does not support HOME, KEY_TO_INSERT_CHARACTER, or
KEY_TO_DELETE_CHARACTER, these features are no longer available.  The
modifications have been done in a haphazard style (typical of this
particular reviewer) so that some of the old code has been commented out and
some of it has been entirely removed.  It will now compile on most IV.x
p-systems.  If you are using a p-system older than IV.1 then you must comment
out the selective uses list for SCREENOPS (found in FF.FREEFRM).

     regards - gws


========================================================================================
DOCUMENT :usus Folder:VOL27:vol27.doc.text
========================================================================================

                             USUS Library Volume 27
                      FreeForm (a 3-D spreadsheet) Sources
                   Documentation and code files on Volume 28
                                        
                               --> IV.x ONLY <--
                            4 word reals recommended

FF.FREEFRM.TEXT   22  The main program of FreeForm
FF.COPY2.TEXT     18     an include file
FF.DATA1.TEXT     20     an include file
FF.FORMS3.TEXT    22     an include file
FF.DATA3.TEXT     20     an include file
FF.DATA2.TEXT     20     an include file
FF.DATA5.TEXT     22     an include file
FF.FORMS5.TEXT    26     an include file
FF.FORMS1.TEXT    24     an include file
FF.FORMS2.TEXT    14     an include file
FF.FORMS4.TEXT    16     an include file
FF.MISC2.TEXT     20     an include file
FF.BASICS1.TEXT   30     an include file
FF.COPY1.TEXT     26     an include file
FF.BASICS3.TEXT   24     an include file
FF.BASICS2.TEXT   24     an include file
FF.MISC1.TEXT     32     an include file
FF.DATA4.TEXT     32     an include file
README.1ST.TEXT    8  Read this FIRST!
VOL27.DOC.TEXT     6  You're reading it
-----------------------------------------------------------------------------
Please transfer the text below to a disk label if you copy this volume.

    USUS Volume 27 -***- USUS Software Library
                         
   For not-for-profit use by USUS members only.
  May be used and distributed only according to 
      stated policy and the author's wishes.



This volume was assembled by George Schreyer from material collected by
the Library committee.
__________________________________________________________________________



========================================================================================
DOCUMENT :usus Folder:VOL28:ff.2word.code
========================================================================================

< binary file -- not listed >

========================================================================================
DOCUMENT :usus Folder:VOL28:ff.4word.code
========================================================================================

< binary file -- not listed >

========================================================================================
DOCUMENT :usus Folder:VOL28:ff.a.text
========================================================================================

Freeform [F.4] 
Introduction and Overview 
8/82 


1. FREEFORM 
 

1.1  FREEFORM INTRODUCTION AND OVERVIEW 
 
     Freeform is a math package which allows a user to define a form under UCSD
p-SYSTEMTM.  The form consists of pages of rows and columns of numbers. Algebra
ic calculations, specified by the user, can then be performs on the data.  
 
Operation 
 
     Upon initiating the Freeform program, the user will be prompted with a 
main menu describing Freeform's options and capabilities.  Typically, a user
would begin by selecting the form definition option which prompts the user for
the dimensions of the form, the headings for the rows, columns, and pages and
the calculations to be performed.  Once the form is defined, the user may 
proceed to the data entry mode and enter data, have the math performed, alter
data, or list desired data to a printer.  Other options in the main menu prompt
the user through the other features decribed in this document.  
 
     The following is an example of a simple table (Form) representing the 
distribution of inventory for three part types in five locations.  A total of 
each part type at each location is also computed. 
 
Form Example - Distribution of Inventory by Location 
 
                 loc 1     loc 2     loc 3     loc 4     loc 5     Total 
        
        part 1    100       200       300        -         50       650 
        
        part 2     10        50        80       30          -       170 
        
        part 3    200         -         -      120         90       410 
        
        Total     310       250       380      150        140      1230 
 
 
1.1.1 The Freeform Form 
 
     Many numerical problems, particularly those in business applications, can 
be represented as tables or matrices.  In general terms, a matrix is a set of 
related data in which each element of the set is ordered by qualifiers called 
coordinates, the bounds of which form the dimensions of the matrix.  Any 
element in the set may be referenced by specifying the values of each 
coordinate.  A FREEFORM matrix has three dimensions and is referred to
throughout this  documentation as a Form.  Each Form will be assigned a unique
name by the user in addition to the specification of the three dimensions of
the Page, Row, and Column.  A Form is defined by its dimensions and 'attributes
' which describe the row and column names, types, calculations, and editing 
formats.  A visual model of how the inventory example on the previous page 
would be represented by a FREEFORM matrix or Form is shown on the next page.  
Note, an additional page has been provided for a second month's data. 
 
 
 
 
 
 
                      .___.___.___.___.___.___.___.___.___.___.___.___.
                     /       /       /       /       /       /       /
           month 2  /       /       /       /       /       /       /
    Pages          .___.___.___.___.___.___.___.___.___.___.___.___.  .
  _.    month 1  /       /       /       /       /       /       /
   /            / loc 1 / loc 2 / loc 3 / loc 4 / loc 5 / Total /
  /             .___.___.___.___.___.___.___.___.___.___.___.___.     .
 +-> Columns                                               ./
                 100    200    300     -      50    650   /  .        .
 v      part 1  __________________________________________
Rows                                                        ./        .
                   10     50     80     30     -     170   /  .
        part 2  __________________________________________
                                                            ./
                  200     -      -     120     90    410   /  .
        part 3  __________________________________________
                                                            ./
                  310    250    380    150    140   1230   /
        Total   __________________________________________


     Version F.4 of FREEFORM is limited to a maximum Form size of 100 pages.  
Each page has the same number of rows and columns with the constraints of 
having no more than 32,704 numbers in a page with no more than 101 columns.
up to 18 forms may be stored on one disk.  Details of this process and further
definition of terms are found in section 1.2.

     At this point, a brief word about disk files and the structure of FREEFORM
is appropriate.

1.1.2 System Environment

     The FREEFORM program is named FF/VER4.CODE.  FREEFORM uses one file to
keep reference information about Forms which are stored on the disk.  This
'directory' file is not to be confused with the disk directory.  It is just
another file on the disk and is named FREEFORM.DIR.  For each Form defined,
FREEFORM creates a Control, Constants, Titles, and Data file.  The Control,
Constants, Titles, and Data files' file names are made up of the Form name
concatenated with the suffix '.CTL', '.CON', '.TIT', and '.DAT' respectively.
The Control file contains the information which describes the Form, and the
Data file contains the values input by the user and/or which are computed by
FREEFORM under the user's direction.

     To run FREEFORM eXecute the file FF/VER4.CODE.  The FREEFORM main function
menu is then displayed in the following format.



















     *********************************************************************

 
 
 
          F R E E F O R M   The Electronic Worksheet  [F.4] 
          ========================================== 
                                        June 24, 1981
 
 
          0.   Data Entry Procedure 
          1.   Define new FORM controls 
          2.   Modify FORM controls 
          3.   Display or List directory 
          4.   Display or List FORM controls 
          5.   Consolidate Procedure 
          6.   Roll a FORM 
          7.   Copy a FORM 
          8.   Delete a FORM 
          9.   Help and User's Guide 
 
 
 
          Enter desired option # _      Press ESC to leave 
 
     ********************************************************************* 
 
     The cursor will stop on the function selection prompt.  Select the
appropriate function by typing its respective number.  Terminate FREEFORM by
pressing the <esc> key.  If a FREEFORM function is selected, there will be a
pause while the appropriate program is loaded and the system responds with its
next prompt.  Most inputs to FREEFORM prompts have been designed to be brief
yet self-explanatory and allow for error corrections. 
 
 
1.1.3 Standard Keyboard Procedures 
 
     Each program requests input from the user via "prompts".  These indicate
what information is being requested.  To enter a response, type as though using
a standard typewriter keyboard.  Each character entered will appear on the
video screen.  Pressing the <return> key terminates the input and sends the
response to the program.  Prior to pressing <return>, one may backspace one
character at a time by pressing the <left-arrow> or the <char> key.  A number 
of other keys to perform special functions when entering a string response 
(as opposed to a numerical response) exist.  The <del char> key, for example, 
deletes the character at the current cursor position. The <erase input> key 
erases all the characters from the current cursor position to the end of the 
field.  The <erase field> key redisplays the field with its original value.  
The <ins char> key allows characters to be inserted into the middle of a 
response.  After pressing the <ins char> key, simply enter the characters to be
added.  To get out of the insert mode, press a different function key.  These 
functions allow the user to correct input prior to sending it to the program.  
All prompts are pre-programmed to expect a certain range or type of response 
to which the program can properly react.  If a user attempts to enter invalid 
data, the cursor will neither move nor print the character which is being 
entered.  To speed the process of using FREEFORM, many prompts are preset to 
specific defaults which they will assume if <return> is pressed.  These are 
typically one-character responses to multiple choice prompts. 
 
     Throughout this documentation, prompts will be highlighted by three
leading asterisks (***) to prevent confusing them with the surrounding
explanatory text.  These leading asterisks will not appear on the video display
during actual program execution.  A FREEFORM prompt takes the general form 
 
*** {Prompt text}?  (valid responses)  default [optional comment] 
 
Example: 
 
*** Select another Form? (Y/N)  Y 
 
 
    Most FREEFORM program modules will begin with the prompt 
 
*** Form Name (8 alpha max.) __________    Press ESC to leave  
 
     A valid Form name consists of 1 to 8 alphanumeric characters.  
The special characters  
          
       " # $ % & ' ( ) * : = - { } [ ] ^ ~ + ; ` @ |    _ < > , . ? / 
 
and embedded blanks are not allowed. 
 



========================================================================================
DOCUMENT :usus Folder:VOL28:ff.b.text
========================================================================================

Form Definition Procedures 


1.2 FORM DEFINITION PROCEDURES 
 
1.2.1 How to Define a Form 
 
     Defining a Form involves specifying to FREEFORM the dimensions and the
data to be represented.  As pointed out in section 1.1, the dimensions of the
Forms are Page, Row, and Column.  FREEFORM creates a computerized
representation of the sheets of paper on which numerical problems are solved. 
 
     A Form definition consists of: (1) giving the Form a unique name, 
(2) specifying the dimensions and parameters of the Form pages, rows, and 
columns, and (3) describing the calculations, if any, to be performed.  These 
steps are only necessary the first time a Form is to be used.  All parameters 
which describe a Form and its contents are stored in disk files. 
 
     The Form definition program does the following: (1) creates an entry the 
directory file describing the dimensions and other attributes of the Form,
(2) creates and loads the control file per its specifications, detailing the
row and column parameters and calculations to be performed, (3) creates and
initializes a file to hold any constants that may be defined in the Form, (4)
creates and initializes a file to hold all the page titles, and (5) initializes
a data file of the proper size to hold the prescribed information. 
 
*<Note>  To avoid confusion, review the Standard Keyboard Procedures (1.1.3). 
 
   To envoke the new Form definition procedure select menu option number 1. 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
     ********************************************************************* 
 
          F R E E F O R M   The Electronic Worksheet  [F.4] 
          ========================================== 
                                        June 24, 1981
 
 
          0. 
          1.  Define new FORM controls <===== Form definition 
          2. 
          3. 
          4. 
          5. 
          6. 
          7. 
          8. 
          9. 
 
 
 
          Enter desired option # _      Press ESC to leave  
 
     ********************************************************************* 
 
     When the program has been loaded, the screen will clear, and a new title 
will be displayed. 
 
               F R E E F O R M   F O R M S   C O N T R O L S 
               New Forms Definition 
 
     If FREEFORM does not find a 'directory' file it will display an error
message stating there is no directory.  If this happens, FREEFORM will ask if
another disk should be looked at.  If so, press <return> otherwise type <N>.  
If <return> was pressed the program will prompt for the disk drive number to 
search in for a directory file.  After receiving a valid disk drive number, the
program will instruct the user to insert a disk into that drive and press 
<return>. 
 
     If no FREEFORM directory exists then one needs to be created.  FREEFORM 
should be instructed to look on the disk that is to have a directory for a 
FREEFORM form.  An error message should appear stating that a directory was not
found and then FREEFORM will ask if another disk should be checked.  One should
respond by typing <N>.  FREEFORM will ask if a new directory should be created.
Press <return> or <Y>.  FREEFORM will create a directory on the last disk 
searched which is the reason for searching for a directory on one that does not
have one.  FREEFORM will display: 
 
*** Creating FREEFORM directory ... one moment, please 
 
Simply wait until this message disappears (several seconds). 
 
*<Note> The term 'directory' should not be confused with the system directory. 
 
     The program then checks to verify there is available space on the diskette
to add a new Form.  If there is not enough space, the message 
 
*** FREEFORM directory is full ... press RETURN 
 
will appear and FREEFORM automatically returns to the main menu. The options of
initializing a new diskette or deleting one or more Forms from the current
diskette are then available.  (For instructions on deleting Forms, see 1.5 Form
Controls Modification Procedures.) 
 
*** Form name (8 alpha max.)__________    Press ESC to leave 
 
*<Note> This prompt will only accept letters of the alphabet and the numbers
zero through nine. 
 
Respond by typing the name to be assigned to the new Form and pressing 
<return>.  If <esc> alone is pressed, control returns to the main menu.  If a 
valid Form name request is entered, the program then checks the directory to 
ensure against duplication of Form names.  If an existing Form is found with 
the input name, the option to replace the existing definition and data is 
given.  Replace the form by responding with a <Y> to the prompt 
 
*** Replace existing FORM? (Y/N)  N 
 
To avoid replacing a Form, simply press <return>.  The program will then prompt
for a new name. 
 
*<Note> Use with care as the replaced Form can not be recovered! 
 
     The program will then ask if checkpoint prompts are desired.  These 
prompts give the user a chance to review progress at various intervals during
Form definition.  Until experienced with the sequence of events and comfortable
with the various prompts, users should respond <Y> to this option. 
 
*<Note> Input will be displayed on the screen for visual verification. If 
errors are produced during definition, they can be corrected. 
 
     The Form definition program next prompts for descriptive information about
the Form being defined.  Optional identifiers such as user initials, 
descriptive comment, and definition date are provided to help the user keep
track of the location of Forms.  FREEFORM will function satisfactorily without
this information. 
 
     If space is available, the program then asks for the number of pages
desired, displaying the maximum number allowed.  The program will not allow the
user to exceed the maximum. 
 
*** How many Pages? __ (max. available is 100) 
 
     Next, the format of the Form is selected.  There are two choices: 
Row or Column formatting.  Formatting indicates whether data is homogenous
by row or column and the order in which calculations are performed.  Calculated
rows are done before calculated columns in row-formatted forms and vice versa 
in column formatted forms. 
 
*** Format Rows or Columns? (R/C)  R 
 
 
Examples: 
                   Row Formatted        |           Column Formatted   
            Col 1  Col 2  Col 3  Total  |           Col 1 Col 2  Col 3 
                                        |  
    Row 1    10.0  215.2   65.8  291.0  |   Row 1    10.0    20  0.500 
                                        |
    Row 2      20    460    135    615  |   Row 2   215.2   460  0.468
                                        |
    Row 3   0.500  0.468  0.489  1.457  |   Row 3    65.8   135  0.489
                                        |
                                        |   Total   291.0   615  1.457  
 
 



========================================================================================
DOCUMENT :usus Folder:VOL28:ff.c.text
========================================================================================

*** Do you want automatic month descriptions? (Y/N)  N 
 
allows the program to assign the standard month abbreviations either for rows
or columns in the Form.  If this option is selected, additional prompts will
ask if the headings are for rows or for columns and for the starting month
number. 
 
*** How many Calculation constants? __  (max. 200) 
 
allows the user to preset the constants which will be required in the
calculations.  Input the number of constants required; the program then asks
for the values to be assigned. 
 
*** CHECKPOINT ***  
 
     At this point, the user may elect to make corrections or change any or all
of the previous control data, terminate definition of this Form, or continue. 
First the user is prompted 
 
*** Anything to change? (Y/N)  N 
 
     If the response is <Y> the program returns to the number of pages prompt. 
If the response is <N>, the program continues gathering form parameters.  It
then asks  
 
*** How many columns might ever be in the FORM ? __  (max. 101) 
*** How many rows might ever be in the FORM ? __  (max. XXXX) 
 
The response to these prompts are critical to the definition of the FORM.  
These responses set limits to the size that the FORM will ever be able to
obtain.  The FORM may be altered later to contain fewer columns or rows but no
more. It is suggested to select maximums that are equal to the final number
desired currently plus enough for any additions to the FORM.  There is one way
to expand a FORM beyond these maximums and that is by using the Copy command
(see 1.6.3) 
 
*<Note> A FORM may contain no more than 32,704 numbers per page, therefore the 
maximum number of rows allowed will be a function of the maximum number of 
columns. 
 
     After the maximums have been set, the number of rows and columns that are 
actually going to be in the FORM at the present time are gathered.  The
maximum responses allowed here are determined by the answers just gathered. 
 
*** How many rows? __  (max. XXXX) 
*** How many columns? __  (max. XXX) 
 
These prompts accept only numeric values >=1  and <=max. specified. 
 
*** Are the dimensions ok as specified? (Y/N)  Y 
 
If the response is N, the maximum number of rows and columns and the actual
number of rows and columns prompts are repeated. 
 
The program will then update the FREEFORM directory file on the user diskette
and create the necessary control files. 
 
*** Enter Title for Page (60 char. max.)_______________ 
 
Each page of the Form may have its own unique title which will be displayed
when viewing and printed when listing.  This title may be up to 60 characters
max. and consist of most alphanumeric characters.  Invalid characters will not
be accepted from the keyboard. 
 
*** CHECKPOINT *** 
***Is Title Correct? (Y/N)  Y 
 
allows repeat of title entry until correct. 
 
 
1.2.2 Row and Column Parameter Definition 
 
     There are three parameters which must be defined for both rows and columns
of a Form:  description, type and cross calculation. 
 
     The description is a user-defined label which will be displayed and 
printed when using FREEFORM. 
 
     Type refers to one of the following valid types:  D-data, I-initial
calculations, F-final calculations, and H-heading.  Data type indicates the
values assigned to a row or column will be input by the user and are variable.
Calculated types indicate the values will be computed based on instructions
input by the user.  The precedence of calculations will vary according to one
of several cases which is determined by the mix of operations to be performed.
Initial calculations will be done before Final calculations.  For example, in a
Form formatted by rows, calculations will proceed as follows:  Initial
calculated rows, Initial calculated columns, Final calculated rows, and Final
calculated columns.  In a Form formatted by columns calculations will be
performed in the following order:  Initial calculated columns, Initial
calculated rows, Final calculated columns and Final calculated rows.  Heading
type is only a valid option for a row.  A row that is of Heading type will
not contain any data. 
 
     The third parameter refers to whether or not a cross-calculation can be 
done.  When defining a row, the question "O.K. to set values from Column
Calculations?" will be asked.  Type <N> if none of the data items in the row
being defined are allowed to be the direct result of a column calculation,
otherwise press <return>.  When defining a column, the question "O.K. to set
values from Row calculations?" will be asked.  Type <N> if none of the data
items in the column being defined are allowed to be the direct result of a row
calculation, otherwise press <return>. 
 
     A fourth parameter, Calculate string, will be prompted if the type of a 
row, or column, is specified as I or F.  Simple arithmetic relationships may
be expressed using the algebraic operators, + - / * ^  (^ is exponentiation),
row or column numbers, parenthesis to force the precedence of operators and any
constants if needed as explained earlier.  The exponentiation operator has the 
highest precedence, then multiplication and division and then addition and 
subtraction.  Sequences of operators of the same precedence are executed from 
left to right. 
 
Calculate examples: 
 
1.  Row 3 is to be the sum of rows 1 and 2.  Row 3 is declared to be type I and
the calculate string is entered as simply 1 + 2. 
 
2.  Column 1 is to be divided by column 8 and added to column 5 giving column 
12.  Column 12 must be declared as type I (or type F) and the calculate string 
is 1 / 8 + 5.  Other possibilities that will give the same results are 
( 1 / 8 ) + 5 and 5 + 1 / 8. 
 
3. Row 4 is the product of row 1 and row 2 divided by 1000 and minus row 3. A 
constant must have been pre-defined as 1000.  Assume it is the only constant 
for this Form, therefore it is constant (1).  Row 4 is declared type I and the 
calculate string ((1 * 2) / C1) - 3. 
 
*<Note> If automatic month headings for either rows or columns are specified, 
the parameters are preset, and all prompts are skipped. 
 
*<Note> If checkpoint prompts are suppressed, the user is not given the
opportunity to change any of the row or column parameters during Form 
definition. 
 
     Upon completion of the row and column parameter definition sequences,
the program will update the Form control file and create a data file 
initialized with no values. 
 
     A fifth parameter, Editing Format, must be specified for either rows or 
columns in accordance with the formatting option chosen earlier in the Form
definition process.  One may specify the print format to be used to display or
print Form data.  Each numeric field will hold thirteen characters and no more
than eleven may be to the right of the decimal point. 
 
Example: 1234.567        Editing Format      Result 
                                 
                                 ###            ***
                                ####           1235 
                              ####.#         1234.6 
                            ####.###       1234.567 
 
*<Note> If a number will not fit in its specified field, asterisks will be
displayed. 
*<Note> Rounding is done only on the display of the number and not on the
number's internal representation. 
 
If formatting is specified by rows, no prompts for editing columns will appear,
and the reverse is true if formatting is specified by columns. 
 
The Form is now stored and ready for use, and the user is returned to the main
menu. 
 



========================================================================================
DOCUMENT :usus Folder:VOL28:ff.d.text
========================================================================================

Data Entry Procedures 


1.3 DATA ENTRY PROCEDURES 
 
1.3.1 How to Update Form Data 
 
     FREEFORM's data entry procedure allows a user to change values stored in
a Form, compute those rows or columns which have prescribed calculations,
prepare printed copies of the Form for presentation, and store the results for
future reference. 
 
   To envoke the Form DATA ENTRY procedure, select menu option number 0. 
 
 
 
 
 
 
 
 
 
 
 
     ********************************************************************* 
 
          F R E E F O R M   The Electronic Worksheet  [F.4] 
          ========================================== 
                                        June 24, 1981
 
 
          0.  Data Entry Procedure    <===== Form update procedure 
          1. 
          2. 
          3. 
          4. 
          5. 
          6. 
          7. 
          8. 
          9. 
 
 
 
          Enter desired option # _      Press ESC to leave 
 
     ********************************************************************* 
 
 
    Once the program has loaded, the screen will clear and a new title will be 
displayed. 
 
F R E E F O R M   D A T A   E N T R Y 
 
*<Note> If FREEFORM does not find a 'directory' file on its first try
(FREEFORM searches on the prefix disk unless another drive was previously
specified), it displays an error message stating there is no directory.  If
this happens, FREEFORM will ask if it should try another disk.  If so, press
<return> otherwise type <N>.  If <return> was pressed, the program will
prompt for the disk drive number to search in for a directory file.  After
receiving a valid disk drive number, the program will instruct the user to
insert a disk into that drive and press <return>. 
 
*<Note> To avoid confusion, review the Standard Keyboard Procedures (1.1.3). 
 
The program then displays the prompt 
 
*** Form Name (8 alpha max.) __________    Press ESC to leave 
 
     There are three possible responses to this command.  Press <esc> to return 
to the FREEFORM main menu, supply a Form name, or press <?>.  Each time <?> is 
pressed FREEFORM looks at the Freeform directory and displays a possible Form 
name.  If a selected Form name is not found on the user diskette, the prompt 
 
*** Form named <name given> not found... 
*** Try another Form name? (Y/N)  Y 
 
will appear.  The user may now try another Form name, by supplying the desired
Form name in the manner previously described.  If a user chooses not to select
another Form name by typing <N>, control will return to the FREEFORM main menu. 
 
    If the Form name selected is valid, however, the program will continue its 
normal progress and inform the user that the Form controls are being loaded. 
 
   Data in a Form may be accessed on any plane: row-column, page-column, or 
row-page.  Data may be listed and entered on any plane.  A work file may be 
used, and Math can be done, only when data is accessed on the row-column plane.
To access data on the row-column plane press <Y> in response to the following 
prompt: 
 
*** Access Data by Pages ? (Y/N)  N 
 
If <return> or <N> is pressed, FREEFORM will ask if the data is to be accessed 
by Columns (the row-page plane) and then by Rows (the page-column plane).  If 
data is accessed by Pages then the program will prompt: 
 
*** Use a Work File ? (Y/N)  Y 
 
If a work file is used, the program will always copy the data in the page being
worked on into a separate file.  This protects the original information in a
page from any changes made.  The contents of the work file may, or may not, be
saved.  If a work file is not used, the original data is used and modified when
changes are made to the pages.  It may be impossible to use a work file if
there is not enough room on the data disk.  If this is the case Freeform will
display an error message. 
 
    If there is more than one page (or column or row depending upon the plane 
of access chosen) in the selected Form, then the program will ask for the page 
(or column or row) to read in.  For example, if access is by Pages then
FREEFORM will prompt: 
 
*** Enter Page #  1  (max. XX) 
 
XX is the number of pages defined for the selected Form.  If this is a 
"Map page" to be used with the Planline to Freeform Interface Program (PuFF)
then end the page number entered with the letter M. 
 
    The program will now display the selected plane of the Form on the screen. 
The title of the page (or column or row description depending on the access 
plane) will appear on the first line of the screen.  The column descriptions 
(or page numbers if access is by Columns) will appear on the third line.  The 
row descriptions (or page numbers if access is by Rows) will be displayed along
the left-hand side of the screen and if data has never been stored in the Form,
dashes (a dash means no value or null) will appear at each data element 
position.  The position at the intersection of the left most column and 
uppermost row is known as the Anchor position. 
 
Finally, the command line 
 
*** Enter Command =>       A,U,M,Z,N,L,S,<ESC>  (H for Help) 
 
will appear below the form.  Each of the letters and the <esc> key represent
a data entry command.  When one of the letters is pressed the appropriate
command will be executed.  A description of each of the commands follows. 
 
 
1.3.2 A - Anchor 
 
     As many rows and columns of data as the screen size allows will be
displayed.  In order to move beyond this physical screen size limit, a concept
called the 'anchor' provides the bridge between the Form and the screen.  By
changing the value of the anchor, it is possible to access, display, and update
any portion of a Form. 
 
    The anchor command calls in a routine which allows the user to change the 
current value of the anchor.  The anchor is specified by giving a page number, 
row number and column number.  Two levels of modifying the anchor exist: one 
from the command line, and one as described below in the update mode.  The 
command mode allows the changing of pages, whereas the update mode keeps the 
same page and only resets row and column. 
 
    Upon pressing A in response to the command prompt, the current anchor
coordinates will be displayed.  To change a value, simply type over the current
coordinates with the new values. 
 
 
1.3.3 U - Update 
 
     When the <U> is typed, the cursor will immediately move to the first data 
element position.  The user is now ready to enter data into that portion of the
Form appearing on the screen.  Do not enter commas, when entering numbers.  
When data has been entered, press <return>, <space>, <cursor-up>, <left>, 
<down>, <right>, <home>, <tab>, or <enter>.  If the Form is formatted by row, 
the cursor will move to the right one data element position in the same row 
when <space> or <tab> are pressed.  When the last data element position in a 
row is reached, the cursor moves to the leftmost data element position in the 
next data row.  Similarly, if the Form is formatted by column, the cursor moves
to the next element of the same data column when <space> or <tab> are pressed. 
When the last data element position has been entered the cursor will again move
to the very first data element position of the next data column. 
 
 



========================================================================================
DOCUMENT :usus Folder:VOL28:ff.e.text
========================================================================================

1.3.4 The Keyboard 
 
     The use of the keyboard is restricted during the update mode.  There are 
only a few special keys, other than the numbers, that can be utilized during up
date.  Move directly to a data element on the screen by using one of the 
following combination of keys. 
 
<Cursor-Left>  moves the cursor left one element position.  If the cursor is in
the leftmost element position of a row, it will move to the rightmost element 
position of the next row. 
 
<Cursor-Down>  moves the cursor down one data element position.  If the cursor
is in the bottom element position of a column, it will move to the top element 
position of the next column. 
 
<Cursor-Up>  moves the cursor up one data element position.  If the cursor is 
in the top element position of a column, it will move to the bottom element 
position of the next column. 
 
<Cursor-Right>  moves the cursor right one element position.  If the cursor is 
in the rightmost element position of a row, it will move to the leftmost 
element position of the next row. 
 
<enter>  exits update mode and returns to the command line. 
 
<home>  moves the cursor to the top, leftmost element position on the screen. 
 
<A>  automatically resets the anchor position to the coordinates specified by 
the cursor position.  The screen will clear and the Form will be redisplayed at
the new anchor. 
 
*<Note> The <return>, <space>, <tab>, <home>, <cursor right>, <cursor left>, 
<cursor up>, <cursor down>, and <A> keys terminate a numeric field for 
transmittal to the data entry program. 
 
*<Note> the program prevents the user from moving the cursor to an element that
is in a row of type heading. 
 
*<Note> The commands U and A, described above, only affect that portion of the 
Form which is currently displayed on the screen.  The following commands affect
the currently anchored page. 
 
1.3.5 M - Math 
 
     From the command line, press <M> and the computer performs all the 
prescribed calculations which have been defined for the rows and/or columns of 
the page.  The number and complexity of stored calculations, and the number of 
rows and columns defined in the Form will effect the speed at which the
calculations are performed.  In any case, it is many times faster than manually
keying the data into a calculator. 
 
1.3.6 S - Save 
 
     The Save command only works if a workfile is being used.  To save the 
current page, type <S> from the command line and the information in the 
workfile will be transferred to the Form data file.  Upon completion, the
command line will be redisplayed and the user may continue. 
 
1.3.7 Z - Zero 
 
     This command sets specified elements of the current plane to zero.  The 
specific data items to set to zero are determined by first giving a sequence
or sequences of rows (or pages) to zero and then a sequence or sequences of
columns (or pages) to zero.  If access is by Pages, or Columns, Freeform will
first prompt 
 
*** Enter sequences of Rows (XX-XX,YY-YY) to Zero below (there are XX) 
*** ____________________________________ 
 
The number shown in 'there are XX' tells how many rows the Form contains.  For
example to set all of row two to zeros enter 2 and press <return>.  Next,
Freeform prompts for sequences of columns, or pages to Zero.  Enter 1| followed
by a dash followed by the number of columns, or pages, in the Form, then press
<return>. 
 
1.3.8 N - Nullify 
 
     This command sets specified elements of the current plane to null.  The 
specific data items to be nullified are denoted in the same manner as in the 
Zero command (see 1.3.7). 
 
1.3.9 L - List 
 
     The listing command allows for the printing of reports for use in
presentations. The response to the L command by FREEFORM is: 
 
*** Is there a Control file to use ? (Y/N) N 
 
FREEFORM allows the listing controls (page, row and column specifications, 
titles, and footing gathered at List time) to be saved in a text file which is
referred to as a Control file.  To use a Control file, type <Y>.  FREEFORM will
prompt for the file name of the Control file.  If <esc> is pressed the Data 
Entry command line is redisplayed.  If the file name entered is not available, 
the program will prompt for the file name again.  When a Control file is used 
FREEFORM will use the values read as default values when the listing controls 
are gathered. 
 
*** Enter sequences of Rows (XX-XX,YY-YY) to List below (there are XX) 
*** ____________________________________ 
 
For example, to list rows one through ten, row thirteen, and rows 25 through 20
enter 
 
1-10, 13, 25-20 
 
     Next a prompt to obtain sequences of columns will appear.  An error
message will be displayed if an invalid page, row or column is selected, more
than the maximum number of pages, rows or columns in a Form are selected to be
listed, or more columns of data are selected than will fit in the specified
line size.  If access is by Pages, the rows and columns to list will be
gathered, otherwise if access is by Columns, the rows and pages to list will be
gathered, or if access is by Rows, the pages and columns to list will be
gathered. 
 
     The user is then prompted for three title lines and a footing.  The three 
additional title lines are provided in addition to the stored page title and 
column headings.  If entered, all titles will be automatically centered above 
the body of the Form.  The page footing will be flush left at the bottom of the
page.  The page footing feature is optional and must be entered each time the 
report is to be printed. 
 
    FREEFORM then prompts 
 
*** Save this information in a Control file (Y/N) N 
 
To save the listing controls specified, type <Y>, otherwise press
<return>. 
 
    The following prompt then appears 
 
*** List to the printer ? (Y/N) Y 
 
     If <return> is pressed then the user is asked how many characters will fit 
on one line and how many lines will fit per page and is then advised to set the
printer alignment and press <return>.  After printing, the page will eject and 
control will return to the command line. 
 
     If <N> is pressed, FREEFORM assumes that the user wishes to send the
output to a disk file.  A file title consisting of a Volume name and a File
name (a type of TEXT is used automatically) are prompted for until FREEFORM can
'open up' the file specified for output or <esc> is pressed.  If a file is
'opened' successfully, the user is asked if the output is to be for Word
Processing.  The user should type <N> since the Word Processor package is not
available at this time.  
 
     When the Listing is complete FREEFORM will redisplay the Data Entry 
command line. 
 
1.3.10 H - Help 
 
     This command will display a brief explanation of valid FREEFORM data entry
commands, one line at a time. 
 
1.3.11 <esc> - Escape 
 
     The command line services the <esc> key in the usual manner.  When 
pressed, FREEFORM will return to the main menu. 




========================================================================================
DOCUMENT :usus Folder:VOL28:ff.f.text
========================================================================================

Directory and Control Files 


1.4 DIRECTORY AND CONTROL FILES 
 
1.4.1 How to List the Freeform Directory 
 
     By selecting function #3 (Display or List Directory) from the main menu, 
the user can get a display or printed listing of the currently stored Forms on 
the FREEFORM disk.  This is useful for keeping track of which diskette has 
which Forms stored on it.  If FREEFORM does not find a FREEFORM directory on
the first disk it searches, the program will advise and allow the user to
specify a disk drive to look in and to insert another disk or opt to abort.  If
a valid directory file is found, the user is allowed to select display or
hardcopy listing.  It is a good idea to periodically print directory listings
of all FREEFORM diskettes to maintain a current catalogue of all the files on
the disks. 
 
1.4.2 How to List or Display Controls 
 
     Function selection #4 (Display or List Form controls) gives either a
printout or display of the controls for a Form stored on the currently logged
user disk.  The prompts for doing so are straightforward. 
 
     As in most FREEFORM programs the user is prompted to supply the Form name.
After being entered the prompt below appears. 
 
*** Listing on Printer? (Y/N)  N 
 
     To display the controls on the console, press <return>.  After each screen
is displayed the user is prompted to press <return>.  This allows plenty of 
time to study each screen. 
 
     To get a printout of the Form controls, press a <Y>.  The user may then
set the printer alignment and press <return> when ready.  The controls will be 
read from the control file for the requested Form and printed in a readable
format.  It is suggested that files of such listings be maintained for each
Form used.  This will save time in the event it is necessary to redefine or
modify a Form. 
 
     When the requested Form controls have been displayed or printed, control 
will pass to the FREEFORM main menu. 
 



========================================================================================
DOCUMENT :usus Folder:VOL28:ff.g.text
========================================================================================

Controls Modification Procedures 


1.5 CONTROLS MODIFICATION PROCEDURES 
 
1.5.1 How to Modify a Form 
 
      Modifying a Form involves changing the dimensions of existing Forms are 
stored in the Form control files. 
 
*<Note> Review the procedures described in the Form Definition Procedures
section (1.2) as use of the modification program requires that the user be
completely familiar with it. 
 
    The Form modification program allows the user to:  change the dimensions 
and other attributes of a Form, change the row and column descriptions and 
calculations to be performed and load the control file accordingly.  The 
formatting of a Form cannot be changed. 
 
1.5.2 Calling the Modify Procedure 
 
To envoke the Form modification procedure select menu option number 
 
        ********************************************************************

             F R E E F O R M   The Electronic Worksheet  [F.4] 
             ========================================== 
                                           June 24, 1981


             0. 
             1. 
             2.  Modify FORM controls <===== Form modification 
             3. 
             4. 
             5. 
             6. 
             7. 
             8. 
             9. 



             Enter desired option # _      Press ESC to leave 

        ********************************************************************
 
 
    When the program has loaded, the screen will clear and a new title will be 
displayed. 
 
                F R E E F O R M   F O R M S   C O N T R O L S 
                Forms Modification 
 
*<Note> If FREEFORM does not find a 'directory' file on its first try
(FREEFORM searches on the prefix disk unless another drive was previously
specified), it displays an error message stating there is no directory.  If
this happens, FREEFORM will ask if you wish to try another disk.  If so, press
<return> otherwise type <N>.  If <return> was pressed, the program will prompt 
for the disk drive number to search in for a directory file.  After receiving a
valid disk drive number, the program will instruct the user to insert a disk in
to that drive and press <return>. 
 
*<Note> A review of the Standard Keyboard Procedures (1.1.3) is recommended. 
 
    The program then displays the prompt: 
 
*** Form Name (8 alpha max.)__________    Press ESC to leave 
 
     There are three possible responses to this command.  Press <esc> to
return to the FREEFORM main menu, supply a Form name, or press <?>.  Each
time <?> is pressed FREEFORM looks at the FreeForm directory and displays a
possible Form name.  If a selected Form name is not found on the user diskette,
the prompt 
 
*** Form named <name given> not found... 
*** Try another Form name? (Y/N)  Y 
 
will appear.  The user may now try another Form name by supplying the desired
Form name in the manner previously described.  If a user chooses not to select
another Form name by typing <N>, control will return to the FREEFORM main menu. 
 
    When a valid Form name is selected FREEFORM will continue its normal
progress and inform the user that the Form controls are being loaded. 
 
1.5.3 Modifying a Form 
 
     The modification portion of the FREEFORM program is now entered.  The
program then asks whether or not it is desired to change certain controls.  The
change prompts are of the form: 
 
*** Change <text>? (Y/N)  N 
 
where <text> is the control in question.  If a control is to be changed respond
with a <Y>, else press <return>.  Once a <Y> response is given, the control may
be changed in the same way as in the Form definition program.  The user is 
allowed to do such things as inserting and/or deleting rows and columns from a 
form, adding pages, changing various descriptions, etc. 
 
EXAMPLE: 
 
Change Row Controls? Y 
 
Enter row # to be modified?  23  (max. XX) 
 
     The controls for row 23 will be displayed and the user may then elect to
change the fields of description, type, editing format, and calculation string
as necessary.  The parameters are the same as those detailed in How to Define a
Form (1.2.1). 
 
1.5.4 Special Hints on Modify 
 
     It is not possible to change the format of a Form once it has been 
created. 
 
     No rows or columns may be added to a Form once the maximum values set for 
them, at Form definition time, have been reached.  It is possible to use the 
Copy utility (see 1.6.3) to create a new Form, just like the old one but, with 
larger maximums for either the number of rows, or columns, or both.  It will 
then be possible to add rows, or columns, to the new Form. 
 
     To add pages to a Form there has to be fewer than 100 pages in it already 
and there must be empty space on the data disk immediately below the data file 
that is to be extended.  To create empty space below the data file use the 
Extended List Directory command and note the block number just below the data 
file.  Then use the Krunch command and Krunch, not the whole disk but, from the
block number noted. 
 
1.5.5 Exiting the Modify Program 
 
     After modifications for a Form have been completed, the program will
return to the FREEFORM main menu. 
 



========================================================================================
DOCUMENT :usus Folder:VOL28:ff.h.text
========================================================================================

Roll, Copy and Delete Utilities 


1.6 ROLL, COPY AND DELETE UTILITIES 
 
1.6.1 How to Use the Roll, Copy and Delete Utilities 
 
     The purpose of the roll utility is to allow the user to change, to some
degree, the order in which rows and/or columns appear in a form.  The copy
utility offers the user the capability of setting up duplicate Forms under
different Form names without having to repeat Form definition.  Using Copy is
also a way of expanding the limits set on the numbers of rows and columns of a
Form which are set at Form definition time.  The delete utility will delete a
Form from the 'directory' file and erase the control and data files associated
with that Form. 
 
*<Note> To avoid confusion review Standard Keyboard Procedures (1.1.3). 
 
   To envoke the ROLL, COPY or DELETE procedures, select the proper menu
option number. 
 
        ********************************************************************

             F R E E F O R M   The Electronic Worksheet  [F.4] 
             ========================================== 
                                           June 24, 1981


             0. 
             1. 
             2. 
             3. 
             4. 
             5. 
             6.  Roll a FORM          <=====  ROLL procedure 
             7.  Copy a FORM          <=====  COPY procedure 
             8.  Delete a FORM        <=====  DELETE procedure 
             9. 
    
    
             Enter desired option # _      Press ESC to leave 

        ********************************************************************
 
    When the program has loaded, the screen will clear and a new title will be 
displayed. 
 
*<Note> If FREEFORM does not find a 'directory' file on its first try (FREEFORM
searches on the prefix disk unless another drive was previously specified), it 
displays an error message stating there is no directory.  If this happens, 
FREEFORM will ask if you wish to try another disk.  If so, press <return> 
otherwise type <N>.  If <return> is pressed the program will prompt for the 
disk drive number to search for a directory file.  After receiving a valid disk
drive number, the program will instruct the user to insert a disk into that 
drive and press <return>. 
 
1.6.2 Roll 
 
*<Note> This option best applies to Forms used in trending information. 
 
     As stated at the beginning of this module, the roll allows the user 
change, to some degree, the order in which rows and columns appear in a Form.
An easy way of seeing this is by example.  If a Form has the following column
headings 
 
JAN  FEB  MAR  APR  MAY  JUN  JUL  AUG  SEP  OCT  NOV  DEC 
 
    By using the roll option one may change this to 
 
APR  MAY  JUN  JUL  AUG  SEP  OCT  NOV  DEC  JAN  FEB  MAR 
 
by 'rolling' 3 columns to the left.  Of course, whenever a heading is moved,
the data associated with that heading is moved as well. 
 
*<Note> Calculation strings are adjusted when they are moved. 
 
    The program will respond to the user's request for a roll with the prompt: 
 
*** Form name (8 alpha max.) __________    Press ESC to leave 
 
If the requested Form is not found on the current diskette, a standard error 
message will be displayed.  The user may try a different Form name, use the '?'
option, or elect to return to the main menu.  If the Form is found, the process
continues. 
 
*** Roll rows or columns? (R/C)  C 
 
To roll rows, type <R>.  If column rolls are desired, press <return> only. 
 
    This prompt appears if the roll column option has been selected. 
 
*** Roll columns left or right? (L/R)  L 
 
The columns will move in the specified direction.  The program will then ask
how many columns are to be rolled. 
 
   For example, if prior to the roll the headings are: 
 
JAN  FEB  MAR  APR  MAY  JUN  JUL  AUG  SEP  OCT  NOV  DEC 
 
and the response to the above prompts is as follows: 
 
*** Roll rows or columns? (R/C)  C 
 
*** Roll columns left or right? (L/R)  L 
 
*** Roll 03 columns left....(enter number) 
 
    The result will be: 
 
APR  MAY  JUN  JUL  AUG  SEP  OCT  NOV  DEC  JAN  FEB  MAR 
 
     Row rolls are like column rolls, except that the user is asked to specify 
how many rows are to be rolled and whether they are to be rolled up or down. 
 
     When the roll has been completed, control will be returned to the FREEFORM 
main menu. 
 
1.6.3 Copy 
 
     The Copy command is very powerful, and if the instructions provided by
FREEFORM are followed, it is very simple to use.  Forms, pages of Forms,
portions of Forms, and portions of pages of Forms, may be copied to Forms that
already exist or used to create new Forms.  Form controls do not have to match
to do these copies and Forms may be copied onto different disks. 
 
     After the Copy command is given, the prompt: 
 
*** Copy from one disk to another ? (Y/N) N 
 
will be displayed.  Type <Y> if information is going to be transferred from one
disk to another, otherwise press <return>.  If <Y> was pressed, then the 
program will prompt to find out which drive the source and destination disks 
will be placed in. 
 
*<Note> The user should not do any disk swapping until instructed by FREEFORM
to do so.  When swapping is done, it should be done very carefully so as not to
confuse the source with the destination disks. 
 
The program will prompt: 
 
*** Copy a Form or just Pages ? (F/P) F 
 
If only the pages from an existing Form are to be copied to another existing
Form on the same or different disk type <P>, otherwise press <return> to create
a new Form from an old one. 
 
Then FREEFORM prompts: 
 
*** Copy a Complete page or Portions of a page ? (C/P) C 
 
A subset of one Form may be used to create a new Form or a subset of each page 
of an existing form may be copied into an existing Form.  To copy portions of 
pages type <P>, otherwise press <return> and whole page(s) will be copied. 
 
     If information is being copied from one disk to another, the program will
at this time instruct the user to insert the destination disk into the drive
that was specified previously. 
 
   FREEFORM now prompts: 
 
*** Destination Form name 
*** Form name (8 alpha max.) __________    Press ESC to leave 
 
This Form is referred to as the Destination Form.  The name of an existing Form
must be given if only a single page is being copied.  Note that a question mark
may be typed and FREEFORM will supply a name of an existing Form on the 
destination disk.  If a new Form is being created, the question mark option 
does not work because FREEFORM expects to be given the name of a Form that does
not exist.  If the Destination Form name already exists on the current 
diskette, an error message will appear. 
 
     If information is being copied from one disk to another, the program will 
at this time instruct the user to insert the source disk into the drive that 
was specified previously. 
 
     Then FREEFORM prompts: 
 
*** Source Form name 
*** Form name (8 alpha max.) __________    Press ESC to leave 
 
Respond with a valid, existing Form name (the question mark option may be used
to find the proper Form name).  This Form is referred to as the Source Form. 
If the requested Form is not found on the current diskette, a standard error
message will be displayed.  The user may try a different Form name or elect to
return to the main menu.  If the Form is found, the process continues with the
prompt: 
 
*** Searching for Source FORM files, one moment please... 
 
      If the contents of one Form are being copied to another Form (the Just 
Pages option) then Freeform will prompt for starting locations to put the 
copied pages, rows, and columns.  For example to copy pages one through four of
the source Form into pages two through five of the destination Form the answer
to the place to start putting the pages would be two.  Later specify that pages
one through four are to be copied. 
 
     The sequences of pages, rows, and columns of the source form to copy will 
be gathered as is done with the List command (1.3.9) during Data Entry. 
 
*** Enter sequences of Pages (XX-XX,YY-YY) to copy below (there are XX) 
*** _____________________________________ 
 
*** Enter sequences of Rows (XX-XX,YY-YY) to copy below (there are XX) 
***_____________________________________ 
 
*** Enter sequences of Columns (XX-XX,YY-YY) to copy below (there are XX) 
***_____________________________________ 
 
For example to copy pages one through four, rows one through ten, row thirteen,
and row 25, and columns seven through one enter 
 
1-4 
 
in response to the Pages prompt, and 
 
1-10, 13, 25 
 
in response to the Rows prompt, and 
 
7-1 
 
in response to the Columns prompt. 
 
      If a new Form is being created, the program will now copy the Control
files. 
 
      The Page(s) are copied now by the program, but before doing so, the user
is prompted: 
 
*** Copy or Empty data fields? (C/E)  _ 
 
     The C response will cause the data in the old Form to be duplicated in the
new Form.  The E response will initialize all the data in the new Form to null. 
 
     When the Copy has been completed, the user is instructed to return all 
disks to their original drives, i.e., all disks should be back where they where
before the Copy command was entered.  Then, the program returns to the FREEFORM
main menu. 

 
1.6.4 Delete 
 
     When the Delete command is entered, the user is prompted for a Form name.
When an existing Form has been specified the prompt 
 
*** Delete <requested form>? (Y/N)  N 
 
will be displayed on the console screen.  If the Form is not to be deleted,
simply press <return>.  However, if the Form is to be deleted, respond with a
<Y>.  At this point, the program will display an update message, the file will 
be removed from the directory, and the associated control and data files will 
be erased. 
 
*<Note> Once a form has been deleted, it can not be restored. 
 



========================================================================================
DOCUMENT :usus Folder:VOL28:ff.i.text
========================================================================================

Form Consolidation 


1.7 FORM CONSOLIDATION 
 
     FREEFORM provides a facility for numerical consolidation of multi-page
Forms.  Consolidation sequencing is not preset and may be changed at will. 
Typical applications for consolidation would be instances where the same data
is prepared for multiple entities and the summation to one or more overall
entity levels is desired. 
 
     Prior to Form definition of a multi-page Form, consider the extra pages
needed to serve as 'scratch pads' for what-if consolidations and add these to
the total number of pages required during a Form definition. 
 
   To envoke the Form CONSOLIDATE procedure select menu option number 5. 
 
     ********************************************************************* 
 
          F R E E F O R M   The Electronic Worksheet  [F.4] 
          ========================================== 
                                        June 24, 1981
 
 
          0. 
          1. 
          2. 
          3. 
          4. 
          5.  Consolidation Utility        <======== CONSOLIDATE routine 
          6. 
          7. 
          8. 
          9. 
 
 
 
          Enter desired option # _      Press ESC to leave 
 
     ********************************************************************* 
 
     Once the program has loaded, the screen will clear and a new title will be 
displayed. 
 
     F R E E F O R M   C O N S O L I D A T I O N 
 
*<Note> If FREEFORM does not find a 'directory' file on its first try (FREEFORM
searches on the prefix disk unless another drive was previously specified), it 
displays an error message stating there is no directory.  If this happens, 
FREEFORM will ask if you wish to try another disk.  If so press <return>; 
otherwise type <N>.  If <return> was pressed, the program will prompt for the 
disk drive number to search in for a directory file.  After receiving a valid 
disk drive number, the program will instruct the user to insert a disk into 
that drive and press <return>. 
 
*<Note> To avoid confusion, review the Standard Keyboard Procedures
(1.1.3). 
 
     The program then displays the prompt... 
 
*** Form Name (8 alpha max.) __________    Press ESC to leave 
 
     There are three possible responses to this command.  Press <esc> to
return to the FREEFORM main menu, supply a Form name, or press <?>.  Each
time <?> is pressed FREEFORM looks at the FreeForm directory and displays a
possible Form name.  If a selected Form name is not found on the user diskette,
the prompt 
 
*** Form named <name given> not found... 
*** Try another Form name? (Y/N)  Y 
 
will appear.  The user may now try another Form name by supplying the desired
Form name in the manner previously described.  If a user chooses not to select
another Form name, by typing <N> control will return to the FREEFORM main menu. 
 
     If the Form name selected is valid, the program will operate normally and 
inform the user that the Form controls are being loaded.  Freeform then asks if
there is a control file to use.  Consolidation control files contain the 
destination page number as well as the consolidation expression to use.  To use
an existing control file the Volume name of the disk it is on and its name must
be specified.  When this has been accomplished the program will prompt: 
 
*** Enter Consolidation Page # __  (max. is XX) 
 
      Enter the page number into which the results of the consolidation are to 
be stored.  This should be done carefully to avoid unintentionally writing over
other pages. 
 
*** Enter Consolidation Control 
***=_________________________________ 
 
     A prompt is given for a calculation string which will govern the
consolidation process.  The syntax and capabilities of this calculate string
are similar to those used in defining row and column calculations.  Constants
may be specified, however, parenthesis are not permitted.  All operators are of
equal precedence and are therefore executed in left-to-right order. 
 
Examples: 
 
(1) Pages 1, 2, and 3 represent three department profit and loss statements.  A
division total profit and loss statement is requested for the three pages.  In 
FORMDEF, 4 pages are allocated; 1 for each department, and 1 for a division 
total.  The consolidation page for this problem is 4.  The calculation string 
which defines the consolidation control is 1 + 2 + 3. 
 
(2) If, on the other hand, the division total and department 1 and 2 data is 
known, the objective would be to compute or 'squeeze' department 3 data.  The 
consolidation page for this would be 3, and the appropriate calculation string 
would be 4 - 1 - 2. 
 
(3) A different Form may contain inventory in Dollar amounts on page one.  To 
get the amounts in British pounds on page two, a constant would have to exist 
containing the exchange rate for Dollars and Pounds.  Suppose C1 equals 2.1900.
The appropriate calculation string would be 2 / C1 with the consolidation page 
set to two. 
 
(4) The inventory of 12 items in seven warehouses exists.  Three of the 
warehouses are in Texas, two are in Oklahoma, and two are in Louisiana.  A
record of beginning inventory, issues, receipts, and computed ending inventory
by item in each warehouse, a total of all items in each state, and a grand
total of all warehouses has been requested.  The Form to define would consist
of 11 pages; one for each warehouse, one for each state total, and one for a
total of all warehouses.  Each page would have 12 data rows to represent each
of the 12 inventory items and one calculated row to total the 12 items, plus
three data columns in which the quantities would be entered and one column for
computing the ending inventories.  The user would probably want to sequence the
pages so the display would be most meaningful.  Any sequence will work.  Some
examples are: 
 
 
 
 
 
 
               Sequence #1         Sequence #2         Sequence #3 
            pg 1 Tex. WH 1           Tex. WH 1         Grand Tot. 
            pg 2 Tex. WH 2           Tex. WH 2         Tex. SUB 
            pg 3 Tex. WH 3           Tex. WH 3         Okl. SUB 
            pg 4 Okl. WH 1           Tex. SUB          La.  SUB
            pg 5 Okl. WH 2           Okl. WH 1         Tex. WH 1
            pg 6 La.  WH 1           Okl. WH 2         Tex. WH 2 
            pg 7 La.  WH 2           Okl. SUB          Tex. WH 3 
            pg 8 Tex. SUB            La. WH 1          Okl. WH 1 
            pg 9 Okl. SUB            La. WH 2          Okl. WH 2 
            pg10 La.  SUB            La. SUB           La . WH 1 
            pg11 Grand Tot.          Grand Tot.        La . WH 2 
 
    The consolidation controls and sequence for these cases: 
 
          8 = 1 + 2 + 3       4 = 1 + 2 + 3       2 = 5 + 6 + 7 
          9 = 4 + 5           7 = 5 + 6           3 = 8 + 9 
         10 = 6 + 7          10 = 8 + 9           4 = 10 + 11 
         11 = 8 + 9 + 10     11 = 4 + 7 + 10      1 = 2 + 3 + 4 
 
*<Note> The user may want to define an extra page to be used as a scratchpad 
for hypothetical cases;  for example, in the inventory example above, Tex. WH 1
and La. WH 2 are both within 100 miles of a customer.  What is the total supply
of item 6 available in these locations? 
 
     After the consolidation string is entered, the program will perform the 
prescribed consolidation math and rewrite the consolidation page to the Form 
data file. 
 
     When this process has completed (time required will vary with the number
of pages in the consolidation and the number of calculated rows and columns in
the Form), FREEFORM will ask if the consolidation controls used should be
saved.  It will then ask if there are more consolidations to be done with the
current Form.  When there are no more consolidations to be done with the 
current Form, FREEFORM will return to the main menu. 
 
 



========================================================================================
DOCUMENT :usus Folder:VOL28:ff.j.text
========================================================================================

Form Creation Example 


1.8  FORM CREATION EXAMPLE 
 
     The following instructions will create a Form which could be used in
doing a financial Forecast. 
 
     Step one is to set the Prefix to whichever Volume FREEFORM is to put the 
'directory' file on or to the disk which already contains a FREEFORM directory.
This can be done by typing /SP (Set Prefix) while at Freeform's main menu or 
while in the Filer program using the P)refix command. 
 
     Step two is to execute FREEFORM.  This is done by eXecuting the code file 
FF/VER4. 
 
     The following exchange will then take place: 
 
FREEFORM:    Puts up FREEFORM main menu. 
User Enters: 1 
Explanation: Selected Define new FORM controls option. 
 
FREEFORM:    Enters Forms Control mode, creates FREEFORM directory
             if one was not found on the prefixed disk, and prompts for a Form 
             name. 
             Form Name (8 alpha max.)________ 
User Enters: FORECAST<return> 
Explanation: User named Form FORECAST. 
 
FREEFORM:    Are checkpoint prompts desired? N 
User Enters: Y 
Explanation: This turns on the Checkpoint option.  With the Checkpoint option 
             on, FREEFORM will give the option of re-entering a bad input.  An 
             experienced user will normally press <return> so this option will 
             not be turned on. 
 
FREEFORM:    Enter user initials 
User Enters: DA<return> 
Explanation: This is optional.  It is O.K. to just press <return>. 
 
FREEFORM:    Enter optional descriptive comment -> 
User Enters: Forecast Form<return> 
Explanation: This comment is displayed when the FREEFORM directory is listed.  
             This helps one recognize what a Form contains, and is therefore 
             recommended for use, although it is optional. 
 
FREEFORM:    Enter today's date (MMDDYY) -> 
User Enters: 080680<return> 
Explanation: This is displayed as the date of creation when the Form controls 
             are listed.  It is optional also. 
 
FREEFORM:    How many pages? 
User Enters: 1<return> 
Explanation: Only one page is wanted in this Form.  If more are wanted later, 
             it is possible to add them. 
 
FREEFORM:    Format Rows or Columns? R 
User Enters: <return> 
Explanation: Form will be formatted by Row because R is the default. Row
             formatting lets the user define the decimal point position for an 
             entire row, one row at a time.  This means that the number of 
             digits to the left and the right of the decimal point will not 
             vary across a row but may vary down a column.  With column 
             formatting, the number of digits to the left and the right of the 
             decimal point is fixed for each column but may vary across a row. 
             In either case all numbers will line up when the form and its data
             are printed. 
 
FREEFORM:    Do you want automatic month descriptions? N 
User Enters: Y 
Explanation: This is a forecast and will contain monthly information as well as
             a year and quarterly totals.  The columns containing the totals 
             will be added to the Form after the initial definition is 
             complete.  For now only the columns with month names for headings 
             will be put into the Form. 
 
FREEFORM:    Month descriptions for rows or columns? C 
User Enters: <return> 
Explanation: Descriptions will be for the columns because C is the default. 
 
FREEFORM:    Enter starting month # 1 
User Enters: <return> 
Explanation: The first column will be labeled Jan, one was the default, and the
             last will be labeled Dec.  It is possible to start with any month 
             by picking a different number in the range one through twelve. 
 
FREEFORM:    How many Calculation Constants? 
User Enters: 1<return> 
Explanation: One constant wanted. 
 
FREEFORM:    CONSTANT(1) = - 
User Enters: .95<return> 
Explanation: FREEFORM will set C1 equal to 0.9500. 
 
FREEFORM:    Anything to change? N 
User Enters: <return> 
Explanation: Default is N.  If something had been entered wrong so far
             <Y> should be typed.  If <Y> is pressed FREEFORM will repeat all 
             questions asked so far again.  This question would not have been 
             asked if the Checkpoint option had not been turned on. 
 
FREEFORM:    How many columns might ever be in the FORM? 
User Enters: 20<return> 
Explanation: In this Form a total of 17 columns will be used.  By responding 
             with 20 there will be a little room for expansion later. 
 
FREEFORM:    How many rows might ever be in the FORM? 
User Enters: 40<return> 
Explanation: A total of nine rows will be used in this Form now.  By telling 
             Freeform 40 there will be plenty of room for expansion. 
 
FREEFORM:    How many columns? 
User Enters: 12<return> 
Explanation: Twelve columns are desired in this Form, one for each month.  
             Quarterly totals will be added later. 
 
FREEFORM:    How many rows? 
User Enters: 9<return> 
Explanation: Nine rows are desired in this Form. 
 
FREEFORM:    Are the dimensions o.k. as specified? Y 
User Enters: <return> 
Explanation: To change the number of rows or columns just specified type <N>. 
 
FREEFORM:    Updating directory ...one moment, please 
             Creating Control and Data files ...one moment, please 
User: 
Explanation: These are displayed while FREEFORM writes the information just 
             given it into the FREEFORM directory.  FREEFORM then creates new 
             Control and Data files. 
 
FREEFORM:    Enter Title for Page 1 ______________________________________ 
User Enters: PCIF FORECAST<return> 
Explanation: Enter the title on the dashed line below the prompt.  The title 
             entered will always appear whenever page one of this Form is 
             listed. 
 
FREEFORM:    Is Title correct? Y 
User Enters: <return> 
Explanation: Yes is the default.  If the Title was entered incorrectly typing 
             <N> would allow you to re-enter the Title. 
 
FREEFORM:    This title will be written to the disk.  FREEFORM then prompts 
             Enter Description for Row 1 _______________ 
User Enters: EX PEOPLE<return> 
Explanation:  
 
FREEFORM:    Enter 1 Type (D/I/F/H) D 
User Enters: <return> 
Explanation: This is where the option of defining a Row as Data, Initial
             calculation, Final calculation or Heading is given.  Data is the 
             default and was chosen. 
 
FREEFORM:    O.K. to set values from Column calculations? Y 
User Enters: N 
Explanation: This will not be a calculated row.  Therefore it is not okay to 
             set values from column calculations in this row.  This will be 
             more evident when the Form is finished and being used. 
 
FREEFORM:    Enter Row 1 Editing Format ####.##__ 
User Enters: ##<erase input><return> 
Explanation: Just defined the field to be two digits wide.  This row will be 
             able to store integers in the range -99 through 99.  A user must 
             define the field to have at least one digit to the left of the 
             decimal point and at most four digits to the right of the decimal 
             point. 
 
FREEFORM:    Are Controls for Row 1 o.k.? Y 
User Enters: <return> 
Explanation: Type <N> if an error was made while defining the controls for Row 
             one and all questions asked to describe it will be repeated. 
 
FREEFORM:    Enter Description for Row 2 _______________ 
User Enters: NON-EX PEOPLE<return> 
Explanation: This is the description for Row two.  Answer all the rest of the 
             questions about Row two in the same way as for Row one. 
 
FREEFORM:    Enter Description for Row 3 _______________ 
User Enters: <return> 
Explanation: You want to have a blank line before Row four.  The Row type will 
             be the heading. 
 
FREEFORM:    Enter 3 Type (D/I/F/H) D 
User Enters: H 
Explanation: Row type of heading was chosen. 
 
FREEFORM:    Are Controls for Row 3 o.k.? Y 
User Enters: <return> 
Explanation: Type <N> if an error was made while defining the controls for Row 
             three, and all questions asked to describe it will be repeated. 
 
FREEFORM:    Enter Description for Row 4 _______________ 
User Enters: TOTAL PEOPLE<return> 
Explanation:  
 
FREEFORM:    Enter 4 Type (D/I/F/H) D 
User Enters: I 
Explanation: This is to be a Initial calculation row. 
 
FREEFORM:     =___________________________
User Enters: 1 + 2<return> 
Explanation: This tells FREEFORM that Row four is the sum of Row one and Row 
             two. 
 
FREEFORM:    O.K. to set values from Column calculations? Y 
User Enters: N 
Explanation:  
 
FREEFORM:    Enter Row 4 Editing Format ##_______ 
User Enters: <return> 
Explanation: This defines the field to be two digits wide as the default was 
             ##. 
 
FREEFORM:    Are Controls for Row 4 o.k.? Y 
User Enters: <return> 
Explanation: Type <N> if an error was made while defining the controls for Row 
             four, and all questions asked to describe it will be repeated. 
 
FREEFORM:    Enter Description for Row 5
_______________ 
User Enters: <return> 
Explanation: You want to have a blank line before Row six just like the one 
             before Row four. 
 
FREEFORM:    Enter 5 Type (D/I/F/H) D 
User Enters: H 
Explanation:  
 
FREEFORM:    Are Controls for Row 5 o.k.? Y 
User Enters: <return> 
Explanation: Type <N> if an error was made while defining the controls for Row 
             five, and all questions asked to describe it will be repeated. 
 
FREEFORM:    Enter Description for Row 6 _______________ 
User Enters: LABOR<return> 
Explanation:  
 
FREEFORM:    Enter 6 Type (D/I/F/H) D 
User Enters: <return> 
Explanation: This is to be a Data row (Data is the default). 
 
FREEFORM:    O.K. to set values from Column calculations? Y 
User Enters: <return> 
Explanation:  
 
FREEFORM:    Enter Row 6 Editing Format ##_______ 
User Enters: ####.##<return> 
Explanation: You want the field to have up to four digits before the decimal 
             point and two after it. 
 
FREEFORM:    Are Controls for Row 6 o.k.? Y 
User Enters: <return> 
Explanation: Type <N> if an error was made while defining the controls for Row 
             six, and all questions asked to describe it will be repeated. 
 
FREEFORM:    Enter Description for Row 7 _______________ 
User Enters: LESS BILLINGS<return> 
Explanation:  
 
FREEFORM:    Enter 7 Type (D/I/F/H) D 
User Enters: <return> 
Explanation: This is to be a Data row (Data is the default). 
 
FREEFORM:    O.K. to set values from Column calculations? Y 
User Enters: <return> 
Explanation:  
 
FREEFORM:    Enter Row 7 Editing Format ####.##__ 
User Enters: <return> 
Explanation: Just defined the field to have up to four digits before the
             decimal point and two after it. 
 
FREEFORM:    Are Controls for Row 7 o.k.? Y 
User Enters: <return> 
Explanation: Type <N> if an error was made while defining the controls for Row 
             seven, and all questions asked to describe it will be repeated. 
 
FREEFORM:    Enter Description for Row 8 _______________ 
User Enters: <return> 
Explanation: Want to have a blank line before Row nine just like the one before
             Row four. 
 
FREEFORM:    Enter 8 Type (D/I/F/H) D 
User Enters: H 
Explanation:  
 
FREEFORM:    Are Controls for Row 8 o.k.? Y 
User Enters: <return> 
Explanation: Type <N> if an error was made while defining the controls for Row 
             eight, and all questions asked to describe it will be repeated. 
 



========================================================================================
DOCUMENT :usus Folder:VOL28:ff.k.text
========================================================================================

 
FREEFORM:    Enter Description for Row 9 _______________ 
User Enters: NET PROJECT EXP<return> 
Explanation:  
 
FREEFORM:    Enter 9 Type (D/I/F/H) D 
User Enters: I 
Explanation: This is to be a Calculated row. 
 
FREEFORM:     =___________________________
User Enters: (6 - 7) * C1<return> 
Explanation: This tells FREEFORM that Row nine is the Row six minus Row seven, 
             all multiplied by C1 which is 0.95. 
 
FREEFORM:    O.K. to set values from Column calculations? Y 
User Enters: <return> 
Explanation:  
 
FREEFORM:    Enter Row 9 Editing Format ####.##__ 
User Enters: <return> 
Explanation: Just defined the field to have up to four digits before the
             decimal point and two after it. 
 
FREEFORM:    Are Controls for Row 9 o.k.? Y 
User Enters: <return> 
Explanation: Type <N> if an error was made while defining the controls for Row 
             nine, and all questions asked to describe it will be repeated. 
 
FREEFORM:    (Will ask if the controls for each column are ok, one at a time.) 
User Enters: <return>    (12 times) 
Explanation: FREEFORM will not let the user change column descriptions here 
             because automatic month descriptions were asked for.  Modify may 
             be used later to change this information. 
 
FREEFORM:    FREEFORM definition process completed for FORECAST.  FREEFORM 
             redisplays the main menu and continues. 
User Enters: 
Explanation: The definition of the form is finished.  The form FORECAST,
             however, will not be complete until Quarter totals have been 
             inserted. 
 
FREEFORM:    Enter desired option # 
User Enters: 2 
Explanation: Picked Modify procedure. 
 
FREEFORM:    Form Name (8 alpha max.) 
User Enters: FORECAST<return> 
Explanation: It is necessary to modify the definition of the Form named
             FORECAST.  Columns are to be inserted in the current Form to 
             provide totals for each of the quarters and for the year's total. 
             Quarter totals are to be inserted in reverse order.  This makes 
             entering calculation strings simpler as the postions of the 
             columns that are being summed have not been moved due to 
             insertions. 
 
FREEFORM:    Opening Control and Data files ... one moment, please 
             When the files are opened, FREEFORM will prompt 
Change User ID? N 
User Enters: <return> 
Explanation: FREEFORM first tries to open the Control and Data files associated
             with the Form name specified once the Form name is found in the 
             'directory' file.  Then all the 'Change' prompts appear.  All 
             'Change' prompts default to No, so whenever it is desirable to 
             leave a value alone, press <return>. 
 
FREEFORM:    Change Form description? N 
User Enters: <return> 
Explanation: Do not change it. 
 
FREEFORM:    Change Form creation date? N 
User Enters: <return> 
Explanation: Do not change it. 
 
FREEFORM:    Change number of Pages? N 
User Enters: <return> 
Explanation: Do not change it. 
 
FREEFORM:    Change number of Constants? N 
User Enters: <return> 
Explanation: Do not change it. 
 
FREEFORM:    Change Value of a Constant? N 
User Enters: <return> 
Explanation: Do not change any. 
 
FREEFORM:    Change Number of Rows? N 
User Enters: <return> 
Explanation: Do not change it. 
 
FREEFORM:    Change Number of Columns? N 
User Enters: Y 
Explanation: Add a Column. 
 
FREEFORM:    Insert a Column? N 
User Enters: Y 
Explanation: Insert a Total column. 
 
FREEFORM:    Enter Column # to Insert After 
User Enters: 12<return> 
Explanation: Insert the 4th quarter total. 
 
FREEFORM:    Insert how many columns ? 1 
User Enters: <return> 
Explanation: Just want to insert one column immediately after column twelve. 
 
FREEFORM:    Enter Description for Column 13 
User Enters: 4th QTR<return> 
Explanation:  
 
FREEFORM:    Enter 13 Type (D/I/F/H) D 
User Enters: I 
Explanation: An Initial calculation column. 
 
FREEFORM:     =___________________________
User Enters: 10+11+12<return> 
Explanation: October, November and December. 
 
FREEFORM:    O.K. to set values from Row calculations? Y 
User Enters: <return> 
Explanation: "Yes" is the default. 
 
FREEFORM:    Delete a Column? N 
User Enters: <return> 
Explanation: "No" is the default. 
 
FREEFORM:    Change Number of Columns? N 
User Enters: Y 
Explanation: Add a Column. 
 
FREEFORM:    Insert a Column? N 
User Enters: Y 
Explanation: Insert a Total column. 
 
FREEFORM:    Enter Column # to Insert After 
User Enters: 9<return> 
Explanation: Insert the 3rd quarter total. 
 
FREEFORM:    Insert how many columns ? 1 
User Enters: <return> 
Explanation: Just want to insert one column immediately after column nine. 
 
FREEFORM:    Enter Description for Column 10 
User Enters: 3rd QTR<return> 
Explanation:  
 
FREEFORM:    Enter 12 Type (D/I/F/H) D 
User Enters: I 
Explanation: An Initial calculation column. 
 
FREEFORM:     =___________________________
User Enters: 7+8+9<return> 
Explanation: July, August and September. 
 
FREEFORM:    O.K. to set values from Row calculations? Y 
User Enters: <return> 
Explanation: "Yes" is the default. 
 
FREEFORM:    Delete a Column? N 
User Enters: <return> 
Explanation: "No" is the default. 
 
FREEFORM:    Change Number of Columns? N 
User Enters: Y 
Explanation: Add a Column. 
 
FREEFORM:    Insert a Column? N 
User Enters: Y 
Explanation: Insert a Total column. 
 
FREEFORM:    Enter Column # to Insert After 
User Enters: 6<return> 
Explanation: Insert the 2nd quarter total. 
 
FREEFORM:    Insert how many columns ? 1 
User Enters: <return> 
Explanation: Just want to insert one column immediately after column six. 
 
FREEFORM:    Enter Description for Column 7 
User Enters: 2nd QTR<return> 
Explanation:  
 
FREEFORM:    Enter 7 Type (D/I/F/H) D 
User Enters: I 
Explanation: An Initial calculation column. 
 
FREEFORM:     =___________________________
User Enters: 4+5+6<return> 
Explanation: April, May and June. 
 
FREEFORM:    O.K. to set values from Row calculations? Y 
User Enters: <return> 
Explanation: "Yes" is the default. 
 
FREEFORM:    Delete a Column? N 
User Enters: <return> 
Explanation: "No" is the default. 
 
FREEFORM:    Change Number of Columns? N 
User Enters: Y 
Explanation: Add a Column. 
 
FREEFORM:    Insert a Column? N 
User Enters: Y 
Explanation: Insert a Total column. 
 
FREEFORM:    Enter Column # to Insert After 
User Enters: 3<return> 
Explanation: Insert the 1st quarter total. 
 
FREEFORM:    Insert how many columns ? 1 
User Enters: <return> 
Explanation: Just want to insert one column immediately after column three. 
 
FREEFORM:    Enter Description for Column 4 
User Enters: 1st QTR<return> 
Explanation:  
 
FREEFORM:    Enter 4 Type (D/I/F/H) D 
User Enters: I 
Explanation: An Initial calculation column. 
 
FREEFORM:     =___________________________
User Enters: 1+2+3<return> 
Explanation: January, February and March. 
 
FREEFORM:    O.K. to set values from Row calculations? Y 
User Enters: <return> 
Explanation: "Yes" is the default. 
 
FREEFORM:    Delete a Column? N 
User Enters: <return> 
Explanation: "No" is the default. 
 
FREEFORM:    Change Number of Columns? N 
User Enters: Y 
Explanation: Add a Column. 
 
FREEFORM:    Insert a Column? N 
User Enters: Y 
Explanation: Insert a Total column. 
 
FREEFORM:    Enter Column # to Insert After 
User Enters: 16<return> 
Explanation: Insert the Year total. 
 
FREEFORM:    Insert how many columns ? 1 
User Enters: <return> 
Explanation: Just want to insert one column immediately after column sixteen. 
 
FREEFORM:    Enter Description for Column 17 
User Enters: YEAR 1980<return> 
Explanation:  
 
FREEFORM:    Enter 17 Type (D/I/F/H) D 
User Enters: I 
Explanation: An Initial calculation column. 
 
FREEFORM:     =___________________________
User Enters: 4+8+12+16<return> 
Explanation: 1st, 2nd, 3rd and 4th QTR's. 
 
FREEFORM:    O.K. to set values from Row calculations? Y 
User Enters: <return> 
Explanation: "Yes" is the default. 
 
FREEFORM:    Delete a Column? N 
User Enters: <return> 
Explanation: "No" is the default. 
 
FREEFORM:    Change Number of Columns? N 
User Enters: <return> 
Explanation: Do not add any more. 
 
FREEFORM:    Are these new specifications ok? Y 
User Enters: <return> 
Explanation: If a mistake has been made type <N>. 
 
FREEFORM:    Change Page Titles? N 
User Enters: <return> 
Explanation: Do not change any. 
 
FREEFORM:    Change Row controls? N 
User Enters: <return> 
Explanation: Do not change any. 
 
FREEFORM:    Change Column controls? N 
User Enters: <return> 
Explanation: Do not change any. 
 
FREEFORM:    Are these new specifications ok? Y 
User Enters: <return> 
Explanation: If a mistake has been made type <N>. 
 
FREEFORM:    Updating Directory, Control and Data files, one moment please... 
User Enters:  
Explanation: The program is now updating all the mentioned files.  FREEFORM 
             will return to the main menu, and the Form named FORECAST is 
             complete.  At this point, the user can run the data entry portion 
             of FREEFORM and enter data into the form named FORECAST.  For 
             instructions on the Data Entry procedure see Section 1.3. 
 



========================================================================================
DOCUMENT :usus Folder:VOL28:readme.1st.text
========================================================================================


     FreeForm is a 3-D spreadsheet.  It is very useful in certain types
of problems and useless in others.

     FreeForm assumes that calculations are done on entire rows or columns at a
time and the results are deposited in other entire rows or columns.  It
therefore is well suited to ledger sheets sort of applications.  The 3-D nature
becomes apparent when you realize that you can set up a sheet, for example, for
each month's activity of a business.  Each month's sheet can be stacked behind
the next month's sheet and year end consolidations can be done on all twelve
sheets to end up with grand totals.  Up to 100 sheets (all must be of identical
format) can be stacked.

     FreeForm does not allow calculations of individual cells so that it is
nearly useless in an application such as a tax calculator.  You pays your money
and takes your chances.

     FreeForm uses real numbers for all of it calculations so that 4 word reals
are necessary to obtain any kind of precision.  A 2 word real version is
provided for those that don't have 4 word reals on their iron, but its use 
is strictly limited as dollar figures can only be represented to $9,999.99
before you start losing track of the odd cents.  Also, if you build data files
with two word reals, and then switch to 4 word reals, THE DATA WILL NOT BE
COMPATIBLE!!!

     The screen control features of FreeForm have been modified extensively
by the reviewer (yours truly, gws) to allow the software to be transported
to different types of terminals.  The author used the screen control values
found in KERNEL to obtain the values of the arrow keys and such.  However, he
did not allow for terminals with two-character sequences (such as an H-19). The
use of KERNEL also made the program un-compilable on most hardware without
extended memory as the compilation of KERNEL uses up most of memory for mere
mortal iron.

     The program has been modified to eliminate the dependance on KERNEL.
It now uses SCREENOPS instead.  In this way it becomes terminal independant.
However, since SCREENOPS does not support HOME, KEY_TO_INSERT_CHARACTER, or
KEY_TO_DELETE_CHARACTER, these features are no longer available.  The
modifications have been done in a haphazard style (typical of this
particular reviewer) so that some of the old code has been commented out and
some of it has been entirely removed.  It will now compile on most IV.x
p-systems.  If you are using a p-system older than IV.1 then you must comment
out the selective uses list for SCREENOPS (found in FF.FREEFRM).

     regards - gws


========================================================================================
DOCUMENT :usus Folder:VOL28:vol28.doc.text
========================================================================================

                             USUS Library Volume 28
                          FreeForm (a 3-D spreadsheet)
                         Documentation and Run Modules
                             (Sources on Volume 27)
                                        
                           --> Version IV.x ONLY <--
                            4 word reals recommended

FF.A.TEXT         20  FreeForm Documentation
FF.B.TEXT         16    ditto   
FF.C.TEXT         18    ditto
FF.D.TEXT         18    ditto
FF.E.TEXT         18    ditto
FF.F.TEXT          8    ditto
FF.G.TEXT         14    ditto
FF.H.TEXT         22    ditto
FF.I.TEXT         18    ditto
FF.J.TEXT         26    ditto
FF.K.TEXT         20    ditto
FF.4WORD.CODE    125  FreeForm for 4 word reals   IV.x only
FF.2WORD.CODE    124  FreeForm for 2 word reals   IV.x only
README.1ST.TEXT    8  Read this first!
VOL28.DOC.TEXT     6  You're reading it
-----------------------------------------------------------------------------
Please transfer the text below to a disk label if you copy this volume.

    USUS Volume 28 -***- USUS Software Library
                         
   For not-for-profit use by USUS members only.
  May be used and distributed only according to 
      stated policy and the author's wishes.



This volume was assembled by George Schreyer from material collected by
the Library committee.
__________________________________________________________________________


========================================================================================
DOCUMENT :usus Folder:VOL29:convdoc.text
========================================================================================

1                                                                     1
                                                               84/04/16

                          Program CONVERS - Users Manual

                                 John W. Dykstra

                                  April 14, 1984





           CONVERS handles communication between two computers  over  a
           character-oriented  full-duplex  link, such as serial modems
           connected  by  a  dial-up  telephone  line.   Usually,   the
           computer  running  CONVERS  (referred to in this document as
           the workstation) is micro- or mini-sized,  and  a  mainframe
           machine (called the host) is on the other end of the link.

           CONVERS interacts  with the host via standard host commands.
           No special programming or modification of the host system is
           necessary,  because  CONVERS  appears to the host as a human
           user.  CONVERS can be used with virtually  any  host  system
           hardware, operating system or applications programs, because
           all interactions are controlled by  easily-written  scripts.
           The  commands  contained  in  these  scripts actually form a
           simple  programming  language,   which   is   interpretively
           executed by CONVERS.

           CONVERS  has  been implemented in Pascal on a system running
           the UCSD P-system.  The design and implementation have  been
           oriented  to  making  transportation of the program to other
           hardware and software systems as easy as possible.

           This document specifically describes Revision C of  CONVERS,
           but  most  of the material presented applies to earlier (and
           probably later) versions of the program.






















1                                                                   1-1
                                                               84/04/16
        ---------------------------------------------------------------
        1.0 CONVERS CONCEPTS AND DEFINITIONS

        ---------------------------------------------------------------

           1.0 CONVERS CONCEPTS AND DEFINITIONS
+              ________________________________


           1.1 PRINCIPLES OF CONVERS OPERATION
+              _______________________________

           CONVERS is controlled by text files called scripts, each  of
           which  contains  a  sequence  of  commands.  When CONVERS is
           started by the user or from another workstation program,  it
           is  passed  a  parameter  string  containing the name of the
           first script to interpret, possibly accompanied by parameter
           definitions  for  that  script.  The initial script may pass
           control to  other  scripts  through  operations  similar  to
           subroutine   calls  and/or  program  branches.   Control  is
           finally  passed  to  the  workstation  operating  system  or
           another user program, under control of script commands.

           The  language  used  in  writting scripts is similar to many
           block-oriented programming languages.  The usual data  types
           are available,  as are variables, constants and expressions.
           Language statements are used to communicate with  the  host,
           manipulate variables, and control script execution.

           1.2 DATA TYPES
+              __________

           CONVERS  supports  data  types of string, integer, name, and
           boolean.

           1.2.1 STRINGS

           A string contains zero or  more  characters  from  the  full
           7-bit  ASCII  set  (  including  control  characters ).  The
           maximum permissible length of  a  string  is  determined  at
           CONVERS compile time, and is currently set at 80 characters.

           1.2.2 INTEGERS

           The  range  of  values  that  an   integer   may   take   is
           implementation  dependent,  but is guaranteed to be at least
           0...32767.   CONVERS  does  not  support  negative   integer
           values.

           1.2.3 NAMES

           Names  are used to denote CONVERS variables and files on the
           local processor (workstation).  Variables of type  name  are
           often used in communication with the host system.

           Names  may  be  from 1 to 32 characters in length, with each
           character selected from the alphabetic and digit characters,
           and  the  special  characters  period  (.),  underscore (_),
           asterisk (*), currency sign ($), and colon (:).   The  first


1                                                                   1-2
                                                               84/04/16
        ---------------------------------------------------------------
        1.0 CONVERS CONCEPTS AND DEFINITIONS
        1.2.3 NAMES
        ---------------------------------------------------------------

           character of a name must not be a digit.

           All names used by CONVERS are case-insensitive, and  may  be
           written   in   any   combination  of  upper  and  lower-case
           characters.  CONVERS translates user-  provided  names  into
           upper-case, and returns them in this form if a name assigned
           to a variable.

           Names used to identify workstation files  must  follow  both
           the  above  rules,  and any additional rules required by the
           workstation operating system.

           1.3 STRING, INTEGER AND BOOLEAN CONSTANTS
+              _____________________________________

           String constants are defined with ASCII characters contained
           within  single  quote  marks.   Any graphic character may be
           included in a string defined in this way except  the  single
           quote.   If  it  is necessary to use a single quote or ASCII
           control character in a string constant, the constant may  be
           built using the concatenation operator and the $CHR function
           (see below).

           An integer constant is expressed in decimal modulus, with no
           embedded commas or trailing periods.

           Boolean  constants  are  represented  by  the reserved words
           TRUE, YES, FALSE and NO.

           1.4 VARIABLES
+              _________

           Variables may be assigned values and used (with  the  $VALUE
           function)   in   any  expression.   There  are  no  variable
           declarations.  The type of a variable is determined  by  the
           type  of  the  value  assigned  to  it.   Variables  may  be
           redefined, and the type of the new value  may  be  different
           from  the  type  of  the  old  value.   There  is  no way to
           "undefine" a variable.  The number of variables that can  be
           defined is  a compile-time contant, currently set to thirty.

           Variable names follow the standard rules for name formation.

           Several  variable names are reserved.  Assignment of a value
           to one of these  variables  changes  the  way  that  CONVERS
           behaves.  These variables, and their effect, are:

           DISPLAY_COMMANDS  This  variable is a boolean.  If it is set
                             to  TRUE,  CONVERS  displays  each  script
                             command line as it is executed.

           DISPLAY_LINK      This variable is also a boolean.  If it is
                             set to TRUE, the text  arriving  from  the


1                                                                   1-3
                                                               84/04/16
        ---------------------------------------------------------------
        1.0 CONVERS CONCEPTS AND DEFINITIONS
        1.4 VARIABLES
        ---------------------------------------------------------------

                             host during MATCH commands is displayed.

           The value of reserved variables can be changed at any  time.
           Reserved  variable names can be used as parameters to $VALUE
           only if they have been previously defined by a script.

           The distinction between variable names and  variable  values
           may  be difficult to understand.  A variable name used alone
           denotes only that name.  The  $VALUE  function  (see  below)
           must be used to obtain the value of that variable.

           1.5 STRING OPERATORS
+              ________________

           Terms  of  type  string  may be concatenated with the binary
           operator //.

           1.6 BOOLEAN OPERATORS
+              _________________

           Terms of  type  boolean  may  be  prefixed  with  the  unary
           operator NOT to negate their value.

           1.7 FUNCTIONS
+              _________

           CONVERS  includes a number of built-in functions that may be
           used in expressions.  All function names begin with a dollar
           sign,  and  are  case  insensitive.   The  parameters of the
           function follow the name, enclosed in parentheses.

           1.7.1 THE $CHR FUNCTION

           This function has a single integer parameter, which must  be
           in  the  range  0..127.   The  value  of the function is the
           one-character string formed by interpreting the value of the
           parameter as an ASCII character.

           1.7.2 THE $VALUE FUNCTION

           This function has a single name parameter, which must be the
           name of a previously-defined variable.  The  value  of  that
           variable  is  returned as the value of the function.  If the
           $VALUE function is applied to a variable name that  has  not
           been explicitly defined, an error message will be issued.

           1.7.3 THE $DEF FUNCTION

           The  single  parameter  of  this  function  is a name.  If a
           variable of that name has been defined, the function  return
           a  boolean  value of TRUE.  Otherwise, it returns a value of
           FALSE.




1                                                                   1-4
                                                               84/04/16
        ---------------------------------------------------------------
        1.0 CONVERS CONCEPTS AND DEFINITIONS
        1.7.4 THE $READ FUNCTION
        ---------------------------------------------------------------

           1.7.4 THE $READ FUNCTION

           The parameter of this function is the name of a file on  the
           workstation.  This file is opened, if it is not already, and
           then the next line in the  file  is  read  and  returned  in
           string  form as the value of the function.  Successive calls
           to $READ with the same file name will result  in  successive
           lines  being  transfered from the file.  The number of files
           that can be open simultaneously is a compile-time  constant,
           currently  set  at  five.   (See  the  LINE parameter of the
           TRANSFER command.)

           1.7.5 THE $EOF FUNCTION

           The parameter of this function is the name of a file on  the
           workstation.  This file is opened, if it is not already, and
           then the status of that file is checked.   If  the  file  is
           positioned  at  end-of-file,  then  this  function returns a
           boolean value of  TRUE;  otherwise,  a  value  of  FALSE  is
           returned.    The  limitation  on  simultaneously-open  files
           described above applies.

           1.7.6 THE $EQ FUNCTION

           The two parameters of this function are expressions  of  any
           matching type.  The boolean value of the function is TRUE if
           the values of the expressions are identical; otherwise,  the
           value of the function is FALSE.

           1.7.7 THE $STR FUNCTION

           The  single  parameter  of  this  function  is  a name.  The
           characters making up this name are converted into a  string,
           and the string is returned as the value of the function.

           1.7.8 THE $NAME FUNCTION

           The  single  parameter of this function is a string.  A name
           is formed from the string, and returned as the value of  the
           function.

           1.8 SCRIPT COMMANDS
+              _______________

           Each  script  command  occupies  one line.  Blank lines, and
           lines  whose  first  non-blank  character  is  an   asterisk
           (comment  lines),  are  ignored.   Blank  characters  at the
           beginning  of  each  command,  and  between  parts  of  each
           command,  are  ignored.   Script  lines  can  be  up  to  80
           characters long.

           Command lines must begin with a command name, which  follows


1                                                                   1-5
                                                               84/04/16
        ---------------------------------------------------------------
        1.0 CONVERS CONCEPTS AND DEFINITIONS
        1.8 SCRIPT COMMANDS
        ---------------------------------------------------------------

           the usual rules for name formation.  The  remainder  of  the
           line  specifies  parameters  (if any) for the command.  Each
           parameter is either positional,  or  specified  by  a  name.
           Named  parameters  cannot be specified positionally, nor can
           positional parameters be specified with a name.   The  first
           parameter in a command is usually positional, and subsequent
           parameters are identified by names.

           Named parameters that  do  not  require  values  are  called
           keywords.   If a value is required, it follows an equal sign
           ( "=" ).

           Commands cannot be continued from one line to the next.

           1.9 ERRORS DURING COMMAND EXECUTION
+              _______________________________

           Various abnormal situations may cause  a  command  to  abort
           during execution.  CONVERS needs a general control structure
           to intercept these  aborts,  and  attempt  a  retry  of  the
           failing script sequence.  However, no workable structure has
           yet been devised.  Anyone  with  ideas  should  contact  the
           author.

           At present, CONVERS ends execution with an appropriate error
           message if any command aborts.




























1                                                                   2-1
                                                               84/04/16
        ---------------------------------------------------------------
        2.0 SCRIPT COMMANDS

        ---------------------------------------------------------------

           2.0 SCRIPT COMMANDS
+              _______________


           2.1 THE SEND COMMAND
+              ________________

           This command sends a text line  to  the  host  system.   The
           first (positional) parameter is the string to be transmitted
           over the link.   This  is  followed  by  a  carriage  return
           character, unless the NOCC parameter has been specified (see
           below).  If the  string  parameter  is  omitted  or  a  null
           string, only a carriage return will be transmitted.

           The only possible Parameter is:

            NOCR If  this  keyword  is  specified,  the  string  is not
                 followed by a  carriage  return  character.   If  this
                 parameter   is   omitted,   the   carriage  return  is
                 transmitted.

           This command aborts if the link carrier drops during command
           execution.

           2.2 THE MATCH COMMAND
+              _________________

           This  command suspends execution of the current script until
           a given string is received from the host system.  The  first
           (positional)  parameter  is the string or name to be matched
           against.  Optional parameters may follow, separated from the
           match string by a comma.

           Allowable name parameters are:

           ENDING  If this keyword is coded, the matched string must be
                   the last non- blank, non-control character  received
                   from the host for at least 1/2 second.

         ANYWHERE  If this keyword is coded, the matched string will be
                   recognized anywhere in the character stream received
                   from the host.  This is the default if ENDING is not
                   specified.

           PERIOD  If this parameter is coded, CONVERS  will  abort  if
                   the matching conditions are not satisfied within the
                   specified period.  This period is  expressed  as  an
                   integer  number  of  tenths  of  seconds.   If  this
                   parameter is not specified,  CONVERS  will  wait  30
                   seconds before aborting.

           This  command  aborts  if  the link carrier drops, or if the
           match is not made within the specified time period.



1                                                                   2-2
                                                               84/04/16
        ---------------------------------------------------------------
        2.0 SCRIPT COMMANDS
        2.3 THE TRANSFER COMMAND
        ---------------------------------------------------------------

           2.3 THE TRANSFER COMMAND
+              ____________________

           This command transfers data to/from a workstation file.  The
           first  (positional) parameter of this command is the name of
           the workstation file to be transfered.  The remainder of the
           parameters are specified with named parameters:

           UPLOAD  This  keyword  specifies  that  the direction of the
                   transfer is from the workstation to the host system.

         DOWNLOAD  This  keyword  specifies  that  the direction of the
                   transfer is from the host system to the workstation.
                   It is assumed if UPLOAD is not specified.

           TERM    This  parameter  specifies the character string from
                   the host that terminates a DOWNLOAD operation.   All
                   text  received from the host is compared against the
                   contents of this string.  When a match  occurs,  the
                   destination  file  is closed, and execution proceeds
                   to  the  next  command.   The  line  in  which   the
                   termination  string  was detected is not included in
                   the file.  This parameter must  be  supplied  for  a
                   DOWNLOAD, and has no meaning for an UPLOAD.

           USECC   This  keyword  specifies that the host file includes
                   FORTRAN-style carriage control characters.   If  the
                   transfer   direction   is   DOWNLOAD,  '1'  carriage
                   controls are converted to ASCII form-feeds, and  all
                   other  carriage  controls are ignored (deleted).  If
                   the transfer direction is UPLOAD,  lines  containing
                   form-feeds  are  prefixed  with  '1',  and all other
                   lines are prefixed with ' '.  Additionally,  a  line
                   containing  only  a '1' carriage control is uploaded
                   before the first line of the file.  The  default  if
                   the  USECC  keyword  is not specified is to transmit
                   each text line unchanged.

           LINE    This keyword specifies that only one line is  to  be
                   transfered.   The  specified  file  remains open, so
                   that  additional  lines   can   be   transfered   by
                   subsequent  commands.   The number of files that can
                   be left open is a compile-time  constant,  currently
                   set to five.

           PROMPT  This  parameter  specifies  a  string  that  must be
                   received from the host system before  each  line  is
                   transfered on an UPLOAD.  The prompt is not required
                   before the first line of the transfer, or after  the
                   last line.




1                                                                   2-3
                                                               84/04/16
        ---------------------------------------------------------------
        2.0 SCRIPT COMMANDS
        2.3 THE TRANSFER COMMAND
        ---------------------------------------------------------------

           PERIOD  If this parameter is coded, CONVERS  will  abort  if
                   the  string specified by the PROMPT parameter is not
                   detected within the specified period.   This  period
                   is  expressed  as  an integer numbers of tenths of a
                   second.  If this parameter is not specified, CONVERS
                   will wait 30 seconds for each prompt.

           During  uploads,  each  line  is  transmitted  followed by a
           carriage return character.  During downloads,  the  carriage
           return  character  is  interpreted  as  end-of-line, and all
           other ASCII control characters are ignored.

           This command aborts if the  link  carrier  drops,  or  if  a
           prompt string is not detected within the specifed period.

           2.4 THE WAIT COMMAND
+              ________________

           This  command  suspends  execution  of  the  script  until a
           carrier is detected on the link.  This command aborts if the
           carrier is not detected within 30 seconds.

           2.5 THE PAUSE COMMAND
+              _________________

           This  command  suspends  execution  of  the  script  for one
           second.

           2.6 THE DEFINE COMMAND
+              __________________

           This command is used to define one or more  variables.   The
           remainder  of  the command line contains symbol definitions,
           of the form:

                   variable_name = expression

           Each definition is separated from the next by a comma.

           The number of variables that may be  defined  is  a  CONVERS
           compile-time parameter, currently set at 30.  The definition
           of a variable cannot be deleted.

           2.7 THE EXECUTE COMMAND
+              ___________________

           This command saves the current state of CONVERS, and  begins
           execution  of  a  specified program.  The first (positional)
           parameter specifies the program name.  The remainder of  the
           command  line is passed to the called program as a parameter
           string.






1                                                                   2-4
                                                               84/04/16
        ---------------------------------------------------------------
        2.0 SCRIPT COMMANDS
        2.8 THE CALL COMMAND
        ---------------------------------------------------------------

           2.8 THE CALL COMMAND
+              ________________

           This command passes control to another script.   The  action
           is  quite  similar  to  a  subroutine call, in that when the
           called script executes a RETURN command, the calling  script
           will resume execution with the command immediately following
           the CALL.

           The first (positional) parameter is the name of  the  called
           script.  Variable definitions may follow, separated from the
           script name by a comma.   These  definitions  are  performed
           before  execution  of  the  called script begins, and may be
           used as parameters to the called script.

           All variable definitions  remain  valid  across  CALL's  and
           RETURN's;  i.e.,  variables  are declared globally.  Scripts
           may be called recursively.   The  maximum  depth  of  script
           nesting is  a compile-time parameter, currently set at five.

           2.9 THE RETURN COMMAND
+              __________________

           This command returns control to the script that  called  the
           current  one.   If  the  current  script  was  called by the
           CONVERS parameter string,  execution  of  the  program  ends
           normally.

           2.10 THE QUIT COMMAND
+               ________________

           This  command  immediately  terminates execution of CONVERS.
           If the current script is not the top level, a trace-back  of
           script CALL's will be displayed.

           2.11 THE IF COMMAND
+               ______________

           This  command  marks the beginning of a sequence of commands
           that are conditionally executed.  The sole parameter of  the
           command is a boolean expression.  If the expression is true,
           commands between this IF and a matching IFEND or  ELSE  will
           be  executed.   If the value of the expression is false, the
           following commands will be skipped.

           IF, ELSE and WHILE ranges may be nested to a  maximum  depth
           that is a compile- time constant (currently set to five).

           2.12 THE ELSE COMMAND
+               ________________

           This   command  reverses  the  effect  of  the  most  recent
           outstanding IF command.  If the expression in the IF command
           was  true,  commands following the ELSE will be skipped.  If
           the IF expression was false,  commands  following  the  ELSE
           will  be  executed.   The ELSE command is illegal outside of


1                                                                   2-5
                                                               84/04/16
        ---------------------------------------------------------------
        2.0 SCRIPT COMMANDS
        2.12 THE ELSE COMMAND
        ---------------------------------------------------------------

           the range of an IF command.

           2.13 THE IFEND COMMAND
+               _________________

           This command marks the end of the range  of  a  matching  IF
           command.

           2.14 THE WHILE COMMAND
+               _________________

           This  command  marks the beginning of a sequence of commands
           (terminated by a WHILEND  command)  that  will  be  executed
           repeatedly.    The  boolean  expression  that  is  the  only
           parameter of the WHILE command controls the repetition.   If
           this  expression  is  false  the  first  time  the  WHILE is
           executed, the commands within the range  of  the  WHILE  are
           skipped.

           2.15 THE WHILEND COMMAND
+               ___________________

           This  command marks the end of the range of a matching WHILE
           command.

           2.16 THE DIAL COMMAND
+               ________________

           This command executes an  autodial  operation  on  equipment
           with  that  feature.   The  single positional parameter is a
           string  specifying  the  number  to  be  dialed.   The   ':'
           character  is  used  to indicate where the modem should wait
           for a new dial tone before proceeding.

           This command  aborts  if  the  equipment  does  not  support
           autodialing,  or  if  the communications software detects an
           error.

           2.17 THE HANGUP COMMAND
+               __________________

           This command terminates the communication link on  equipment
           with  this  feature.   This command is usually used with the
           DIAL command.














1                                                                   3-1
                                                               84/04/16
        ---------------------------------------------------------------
        3.0 EXECUTION OF CONVERS

        ---------------------------------------------------------------

           3.0 EXECUTION OF CONVERS
+              ____________________


           Each CONVERS script exists as a separate text  file  on  the
           workstation.  The file name is the name of the script.

           When CONVERS is started by the workstation operating system,
           it looks for a workstation file called CMDLINE.  If the file
           exists,  the  first line is used as CONVERS' command string.
           If the file does not exist, CONVERS gets a parameter  string
           from  the  user  via  the keyboard.  (Hitting the escape key
           results in immediate exit from CONVERS.)

           The first expression in the parameter string is the name  of
           the  first script to be executed.  The remainder of the line
           is interpreted as a series of variable definitions.

           The variables DISPLAY_COMMANDS and DISPLAY_LINK control  the
           display  of  debugging information (see the previous section
           on variables).  When either of these variables is true,  the
           information  requested is shown in a "window" on the display
           screen.  During script debugging, these variables can be set
           to  TRUE  in  the  parameter  string.   (See  the section on
           variables for more information.)

           (Note: The link display advances to the first position of  a
           new  line upon receipt of an ASCII line-feed character.  The
           carriage return character is ignored.)

           The escape key on the workstation keyboard may  be  used  to
           abort  CONVERS  execution  at  any time.  This is especially
           useful during script debugging, when CONVERS cannot  find  a
           string that it is trying to MATCH.

           The UCSD operating system currently does not provide a means
           to  pass  a  parameter  string  to  an  executing   program.
           Therefore, the program first looks for a parameter string on
           a file called CMDLINE.TEXT on the system  device.   If  that
           file  does  not  exist or is empty, the user is prompted for
           the parameter string after program execution begins.

           If the EXECUTE command includes a  parameter  string  to  be
           passed  to  the  called program, that string is written as a
           one-line file called CMDLINE.TEXT on the system device.









1                                                                   4-1
                                                               84/04/16
        ---------------------------------------------------------------
        4.0 SAMPLE SCRIPTS

        ---------------------------------------------------------------

           4.0 SAMPLE SCRIPTS
+              ______________




           Script ON_CIS:

               *
               *  this script logs onto the CompuServ network.
               *
               Display, 'Waiting for carrier...'
               Wait
               Display, 'Logging onto system...'
               Pause
               Send
               Match, 'NAME:'
               Send, 'CIS'
               Match,       'ID:', ANYWHERE
               *
               *  Substitute your own user id in the following command.
               *
               Send,      'userid'
               Match,       'WORD:', ANYWHERE
               *
               *  Substitute your own password in the following command.
               *
               Send,      'password'
               Display, 'Waiting for prompt from MUSUS...'
               Match,     'FUNCTION:', ANYWHERE
               Send,      'op;br;t'
               Match, 'Function:', ANYWHERE
               Display, 'Logged onto MUSUS'
               Return




















1                                                                   4-2
                                                               84/04/16
        ---------------------------------------------------------------
        4.0 SAMPLE SCRIPTS

        ---------------------------------------------------------------

           Script GET_LATEST:

               *
               *  this script gets the latest mail summary from MUSUS,
               *  and puts it into file MUSUS_SUM.TEXT.
               *
               Display, 'Logging onto CompuServ...'
               Call, on_cis
               Display, 'Downloading message summary...'
               Send, 'qs;n'
               Transfer,musus_sum, term='Function:'
               Display, 'Logging off CompuServ...'
               Send, 'off'
               Match, 'CONNECT', ANYWHERE
               Display, 'Executing summary review program...'
               Execute, look_sum
               *
               *  Program look_sum displays each summary line,
               *  and asks whether I want to see the full message.
               *  If I do, the program writes the message number
               *  into file MUSUS_NUM.  At the end of the
               *  summary, CONVERS is called with script GET_MSGS.
               *


           Script GET_MSGS:

               *
               *  This script downloads selected messages from
               *  MUSUS to the workstation.  The message numbers
               *  are specified, one per line, on file musus_num.
               *
               Display, 'Logging onto CompuServ...'
               Call, on_cis
               Define, cret_prompt = 'T)', to_end_prompt = 'END):'
               While, NOT $EOF ( musus_num )
                 Define, line = $READ ( musus_num )
                 Display, 'Downloading message ' // $VALUE( line )
                 Send, 'ri;' // $VALUE ( line )
                 Transfer, log, DOWNLOAD, TERM = $VALUE ( cret_prompt )
                 Send, 'rr'
                 Transfer, log, DOWNLOAD, TERM = $VALUE ( cret_prompt )
                 Send, 'ns'
                 Transfer, log, DOWNLOAD, TERM = $VALUE (to_end_prompt )
                 Send, 't'
               Whilend
               Display, 'Logging off CompuServ...'
               Send, 'off'
               Match, 'CONNECT', ANYWHERE
               Return



1                                                                   4-3
                                                               84/04/16
        ---------------------------------------------------------------
        4.0 SAMPLE SCRIPTS

        ---------------------------------------------------------------


           Script PRINT:

               *               Script PRINT
               *
               *                Version C5
               *
               *  This script prints a file (with added
               *  carriage controls) on a system running
               *  the Control Data NOS/VE operating system.
               *
               *  Parameters:   FILE - name of the file on local
               *                       processor (defaults to
               *                       *LISTING );
               *                TITLE - banner page heading for
               *                        listing (defaults to name
               *                        specified for parameter FILE)
               *
               *
               If, NOT $DEF( file )
                 Define, file = *LISTING
               Ifend
               *
               If, NOT $DEF( title )
                 Define, title = $VALUE( file )
               Ifend
               *
               Define, ctl_t = $CHR( 20 ), quote = $CHR ( 39 )
               Display, 'Configuring host for file transfer...'
               Send, 'collect_text, $LOCAL.listing'
               Match, '?'
               Display, 'Uploading file ' // $STR( $VALUE( file ))
               Transfer, $VALUE(file), UPLOAD, ADDCC, prompt='?'
               Send, '**'
               Match, '/'
               Display, 'Executing host print command...'
               Send, 'prif $LOCAL.listing,title='//$STR($VALUE(title))
               Match, '/'
               Display, 'Printing competed'
               Return













1                                                                     1
                                                               84/04/16

                                 Table of Contents


           1.0 CONVERS CONCEPTS AND DEFINITIONS  . . . . . . . .    1-1
           1.1 PRINCIPLES OF CONVERS OPERATION . . . . . . . . .    1-1
           1.2 DATA TYPES  . . . . . . . . . . . . . . . . . . .    1-1
             1.2.1 STRINGS . . . . . . . . . . . . . . . . . . .    1-1
             1.2.2 INTEGERS  . . . . . . . . . . . . . . . . . .    1-1
             1.2.3 NAMES . . . . . . . . . . . . . . . . . . . .    1-1
           1.3 STRING, INTEGER AND BOOLEAN CONSTANTS . . . . . .    1-2
           1.4 VARIABLES . . . . . . . . . . . . . . . . . . . .    1-2
           1.5 STRING OPERATORS  . . . . . . . . . . . . . . . .    1-3
           1.6 BOOLEAN OPERATORS . . . . . . . . . . . . . . . .    1-3
           1.7 FUNCTIONS . . . . . . . . . . . . . . . . . . . .    1-3
             1.7.1 THE $CHR FUNCTION . . . . . . . . . . . . . .    1-3
             1.7.2 THE $VALUE FUNCTION . . . . . . . . . . . . .    1-3
             1.7.3 THE $DEF FUNCTION . . . . . . . . . . . . . .    1-3
             1.7.4 THE $READ FUNCTION  . . . . . . . . . . . . .    1-4
             1.7.5 THE $EOF FUNCTION . . . . . . . . . . . . . .    1-4
             1.7.6 THE $EQ FUNCTION  . . . . . . . . . . . . . .    1-4
             1.7.7 THE $STR FUNCTION . . . . . . . . . . . . . .    1-4
             1.7.8 THE $NAME FUNCTION  . . . . . . . . . . . . .    1-4
           1.8 SCRIPT COMMANDS . . . . . . . . . . . . . . . . .    1-4
           1.9 ERRORS DURING COMMAND EXECUTION . . . . . . . . .    1-5

           2.0 SCRIPT COMMANDS . . . . . . . . . . . . . . . . .    2-1
           2.1 THE SEND COMMAND  . . . . . . . . . . . . . . . .    2-1
           2.2 THE MATCH COMMAND . . . . . . . . . . . . . . . .    2-1
           2.3 THE TRANSFER COMMAND  . . . . . . . . . . . . . .    2-2
           2.4 THE WAIT COMMAND  . . . . . . . . . . . . . . . .    2-3
           2.5 THE PAUSE COMMAND . . . . . . . . . . . . . . . .    2-3
           2.6 THE DEFINE COMMAND  . . . . . . . . . . . . . . .    2-3
           2.7 THE EXECUTE COMMAND . . . . . . . . . . . . . . .    2-3
           2.8 THE CALL COMMAND  . . . . . . . . . . . . . . . .    2-4
           2.9 THE RETURN COMMAND  . . . . . . . . . . . . . . .    2-4
           2.10 THE QUIT COMMAND . . . . . . . . . . . . . . . .    2-4
           2.11 THE IF COMMAND . . . . . . . . . . . . . . . . .    2-4
           2.12 THE ELSE COMMAND . . . . . . . . . . . . . . . .    2-4
           2.13 THE IFEND COMMAND  . . . . . . . . . . . . . . .    2-5
           2.14 THE WHILE COMMAND  . . . . . . . . . . . . . . .    2-5
           2.15 THE WHILEND COMMAND  . . . . . . . . . . . . . .    2-5
           2.16 THE DIAL COMMAND . . . . . . . . . . . . . . . .    2-5
           2.17 THE HANGUP COMMAND . . . . . . . . . . . . . . .    2-5

           3.0 EXECUTION OF CONVERS  . . . . . . . . . . . . . .    3-1

           4.0 SAMPLE SCRIPTS  . . . . . . . . . . . . . . . . .    4-1










1
--EOR--

========================================================================================
DOCUMENT :usus Folder:VOL29:convers.text
========================================================================================

{$S++}
PROGRAM convers;

{$C Copyright 1981, 1982, 1983, 1984 by John Dykstra.  All rights reserved.  }


{       CONVERS - Release 1 - 7/3/82  }
{                 Release 2 - 1/10/83  }
{                 Release 3 - 1/01/84  }




USES  screenops, 
      (*$U remunit.code*) remunit, 
      (*$U textio.code*) textio, 
      (*$U osmisc.code*) osmisc;

{$P}

CONST
  
  {  Constants that define the characteristics of the serial link.  }
  
  default_baud = 0;             {  Default baud rate used - zero means search  }
  use_par = TRUE;               {  Use parity checking  }
  even_par = TRUE;              {  Even parity  }
  char_size = 7;                {  Link character size, in bits  }
  stop_bits = 1;                {  Number of stop bits for link  }
  
  {  Miscellaneous program constants which may be changed in the future.  }
  
  version = 'C9';               {  Program version  }
  copyr_msg=
    'Copyright 1981, 1982, 1983, 1984 by John Dykstra.  All rights reserved.';
  
  max_open_files = 5;           {  Number of transfer files open at once  }
  sym_tbl_size = 30;            {  size of the symbol table  }
  max_nest_level = 5;           {  max levels of script nesting  }
  max_cnd_level = 5;            {  max levels of conditional nesting  }
  max_name_size = 32;           {  Max size of names  }
  max_cmd_size = 8;             {  max chars in a command name  }
  max_script_line = 80;         {  Max length of line in script  }
  
  {  Program constants that will probably never change.  }
  
  ch_lf = 10;                   {  ASCII line feed character  }
  ch_cr = 13;                   {  ASCII carriage return character  }
  ch_ff = 12;                   {  ASCII form feed character  }
  ch_esc = 27;                  {  ASCII <ESC> }
  console = 1;                  {  unit number of CONSOLE:  }
  
  {  Screen format addresses  }
  
  header_x = 31;  header_y = 0; {  Program identification header  }
  status_x = 0;  status_y = 5;  {  Start of status box  }
  cmd_x = 0;  cmd_y = 7 ;       {  Start of command box  }
  link_x = 0;  link_y = 11;     {  Start of text display field  }

{$P}

TYPE
  script_line = STRING [ max_script_line ];
  
  command_name = STRING [ max_cmd_size ];
  
  long_string = STRING [ 255 ];
  
  script_index = 1 .. max_script_line;

  name_type = STRING [ max_name_size ];
  
  string_type = STRING [ max_script_line ];
  
  {  The script status types  }
  
  script_status = ARRAY [ 1..max_nest_level ] OF  RECORD
    script_name:  STRING;
    line_number:  INTEGER;
    END;        {  RECEND  }
    
  {  Conditional status types  }
  
  cnd_kinds = (  if_cnd, el_cnd, wh_cnd );
  
  cnd_status = ARRAY [ 1..max_cnd_level ] OF 
    RECORD 
      skip_flag:  BOOLEAN;
      CASE cnd_kind:  cnd_kinds OF
        wh_cnd:  ( line_num:  INTEGER );
        if_cnd:  (  );
        el_cnd:  (  );
    END;        {  RECEND  }
  
  {  Lexical tokens definitions  }
  
  token_kinds = ( nam_tok, str_tok, int_tok, equ_tok, com_tok, eol_tok, 
                  con_tok, fun_tok, lpn_tok, rpn_tok, log_tok, not_tok,
                  bad_tok, no_tok );

  set_of_token_kinds = SET OF token_kinds;
  
  token_type = RECORD CASE tok_kind:  token_kinds OF
    int_tok:  ( int_val:  INTEGER );
    str_tok:  ( str_val:  string_type );
    nam_tok:  ( nam_val:  name_type );
    fun_tok:  ( fun_val:  name_type );
    log_tok:  ( log_val:  BOOLEAN );
    END;        {  RECEND  }

  {  function definitions  }
  
  fun_kinds = ( chr_fun, val_fun, read_fun, eof_fun, eq_fun, str_fun, nam_fun,
                def_fun, bad_fun );
  
  {  error message severity levels  }
  
  error_level = ( warning, fatal, catastrophic );

  time_period = INTEGER;
  
  {  Command definitions  }
  
  cmd_kinds = ( cal_cmd, com_cmd, def_cmd, dis_cmd, exe_cmd, mat_cmd, qui_cmd,
                ret_cmd, sen_cmd, pau_cmd, tra_cmd, wai_cmd, if_cmd, 
                els_cmd, ife_cmd, whi_cmd, whe_cmd, dia_cmd, han_cmd, 
                bad_cmd  );
                
  {  reserved variable names  }
  
  res_kinds = ( res_command, res_line, res_unknown );
  
  {  Symbol table types  }
  
  symtbl_entry = RECORD
    name:  name_type;
    value:  token_type; 
    END;                {  RECEND  }
  
  sym_tbl_index =  1..sym_tbl_size;

  {  Transfer file table entry  }
  
  tran_entry = RECORD
    name:  name_type;
    now_open:  BOOLEAN;
    direction:  io_direction;
    file_blk:  io_file;
    END;

  tran_range = 1..max_open_files;
  
  {  The translate table is used to translate ASCII characters into upper-case
  {  or printable (non-control) characters only.                              }
  
  xlate_entry = RECORD
    upper:  CHAR;
    no_ctl:  CHAR;
    END;
    
{$P}

VAR
  cur_script_line:  script_line;        {  current script line  }
  exit_requested:  BOOLEAN;             {  user hit ESC on keyboard  }
  command:  token_type;                 {  current command name  }
  delim_tok:  token_type;               {  delimiter of command name  }
  alpha_chars:  SET OF CHAR;            {  All alphabetic characters  }
  visible_chars:  SET OF CHAR;          {  All printables (not space)  }
  script_file:  io_file;                {  The script input file  }
  script_name:  STRING;                 {  the script file title  }
  exit_condition:  BOOLEAN;             {  Some reason found to exit prog  }
  successful:  BOOLEAN;                 {  Command processor was successful  }
  sym_table:  ARRAY [ sym_tbl_index ]
    OF symtbl_entry;                    {  The symbol table  }
  highest_entry_index:  0..sym_tbl_size;{  Index of top entry in symbol table  }
  nest_stack:  script_status;           {  Keeps track of script nesting  }
  script_level:  1..max_nest_level;     {  current script nesting level  }
  cnd_stack:  cnd_status;               {  keeps track of condition nesting  }
  cnd_level:  0..max_cnd_level;         {  current conditional nesting level  }
  tok_table:  ARRAY [ token_kinds ] 
    OF STRING [ 7 ];                    {  Names of tokens for error messages  }
  tran_tbl:  ARRAY [ tran_range ] OF 
    tran_entry;                         {  Table of open transfer files  }
  fun_names:  ARRAY [ fun_kinds ] OF
    STRING [ 7 ];                       {  Names of functions  }
  cmd_names:  ARRAY [ cmd_kinds ] OF
    command_name;                       {  Names of all commands  }
  var_names:  ARRAY [ res_kinds ] OF
    name_type;                          {  Names of reserved variables  }
  cmd_index:  cmd_kinds;                {  Index of current command  }
  skipping:  BOOLEAN;                   {  Currently skipping command  }
  cnd_cmds:  SET OF cmd_kinds;          {  Conditional commands  }
  xlate_tbl:  ARRAY [ CHAR ] OF 
    xlate_entry;                        {  Translates characters  }     
  link_dis_line:  INTEGER;              {  Where we're displaying text  }
  cmd_display:  BOOLEAN;                {  Display all commands  }
  link_display:  BOOLEAN;               {  Display downline text  }
  max_screen_y:  INTEGER;               {  Maximum y for GOTOXY  }

{$P}


{  Forward procedure declarations  }


PROCEDURE get_token ( VAR line:  script_line;
                      expected:  set_of_token_kinds;
                      VAR  token:  token_type );  FORWARD;
  
PROCEDURE eval_expr ( VAR line:  script_line;
                      exp_type:  set_of_token_kinds;
                      exp_delim:  set_of_token_kinds;
                      VAR value:  token_type;
                      VAR delim:  token_type  );  FORWARD;

PROCEDURE error ( level:  error_level;
                  message:  STRING );  FORWARD;

PROCEDURE make_upper ( VAR symbol:  STRING );  FORWARD;

PROCEDURE get_tran_file ( file_name:  script_line;
                            direction:  io_direction;
                            VAR tbl_index:  tran_range );  FORWARD;

PROCEDURE close_all_files;  FORWARD;

PROCEDURE close_tran_file ( tbl_index:  tran_range );  FORWARD;

PROCEDURE match ( text_line:  string_type;
                  quiet_ending:  BOOLEAN;
                  period:  time_period;
              VAR complete_match:  BOOLEAN );  FORWARD;
 
PROCEDURE do_define ( line:  script_line );  FORWARD;

PROCEDURE check_kb ( VAR exit_seen:  BOOLEAN);  FORWARD;

{$P}

SEGMENT PROCEDURE initialize;

  
  TYPE
    baud_rates = ( baud_9600, baud_1200, baud_300, baud_110, all_tried );
    
  VAR
    rem_exists, dialer_exists:  BOOLEAN;
    bauds:  ARRAY [ baud_rates ] OF INTEGER;
    attempted_baud_rate:  baud_rates;
    table_index:  1..max_open_files;
    result:  cr_baud_result;
    index:  CHAR;
    
    
  PROCEDURE init_screen;
  
    VAR
      info:  sc_info_type;
      box_line:  STRING [ 80 ];
    
    BEGIN       {  PROCEDURE init_screen  }
    
    {  Get the screen height from SCREENOPS.  This is used to decide how far
    {  we can write while displaying downlink data.                           }
    
    sc_use_info ( sc_get, info );
    max_screen_y := info.misc_info.height;
    
    sc_clr_screen;
    GOTOXY ( header_x, header_y );
    WRITE ( 'CONVERS  Version ', version );
    GOTOXY ( header_x - 26, header_y + 2 );
    WRITE ( copyr_msg );
    
    {  Put the status box onto the screen, with an initializing message.
    {  This message will be overlaid with the first message from the script.  }
    
    box_line :=  '----------------------------------------';
    box_line := CONCAT ( box_line, box_line );
      
    GOTOXY ( status_x, status_y );
    WRITE ( box_line );
    GOTOXY ( status_x, status_y + 1 );
    WRITE ( '|   Status:  Initializing' );
    GOTOXY ( 79, status_y + 1 );
    WRITE ( '|' );
    GOTOXY ( status_x, status_y + 2 );
    WRITE ( box_line );
    
    END;        {  PROCEDURE init_screen  }
    
    
  PROCEDURE init_tables;
  
    BEGIN
    
    {  Initialize the token table, used for error messages by get_token.  }
    
    tok_table [ nam_tok ] := 'name';
    tok_table [ str_tok ] := 'string';
    tok_table [ int_tok ] := 'integer';
    tok_table [ equ_tok ] := '"="';
    tok_table [ com_tok ] := '","';
    tok_table [ eol_tok ] := '<EOL>';
    tok_table [ con_tok ] := '"//"';
    tok_table [ fun_tok ] := 'functn';
    tok_table [ lpn_tok ] := '"("';
    tok_table [ rpn_tok ] := '")"';
    tok_table [ log_tok ] := 'bool';
    tok_table [ not_tok ] := '"NOT"';
    tok_table [ bad_tok ] := 'int err';
    tok_table [ no_tok ]  := 'int err';
    
    {  Initialize the command name table.  }
    
    cmd_names [ cal_cmd ] := 'CALL';
    cmd_names [ com_cmd ] := '*';
    cmd_names [ def_cmd ] := 'DEFINE';
    cmd_names [ dis_cmd ] := 'DISPLAY';
    cmd_names [ els_cmd ] := 'ELSE';
    cmd_names [ if_cmd  ] := 'IF';
    cmd_names [ ife_cmd ] := 'IFEND';
    cmd_names [ exe_cmd ] := 'EXECUTE';
    cmd_names [ mat_cmd ] := 'MATCH';
    cmd_names [ pau_cmd ] := 'PAUSE';
    cmd_names [ qui_cmd ] := 'QUIT';
    cmd_names [ ret_cmd ] := 'RETURN';
    cmd_names [ sen_cmd ] := 'SEND';
    cmd_names [ tra_cmd ] := 'TRANSFER';
    cmd_names [ wai_cmd ] := 'WAIT';
    cmd_names [ whe_cmd ] := 'WHILEND';
    cmd_names [ whi_cmd ] := 'WHILE';
    cmd_names [ dia_cmd ] := 'DIAL';
    cmd_names [ han_cmd ] := 'HANGUP';
    cmd_names [ bad_cmd ] := '';
    
    {  Initialize the function name table  }
    
    fun_names [ chr_fun ]  := '$CHR';
    fun_names [ val_fun ]  := '$VALUE';
    fun_names [ read_fun ] := '$READ';
    fun_names [ eof_fun ]  := '$EOF';
    fun_names [ eq_fun ]   := '$EQ';
    fun_names [ nam_fun ] := '$NAME';
    fun_names [ str_fun ] := '$STR';
    fun_names [ def_fun ] := '$DEF';
    
    {  Initialize the reserved variable table  }
    
    var_names [ res_command ] := 'DISPLAY_COMMANDS';
    var_names [ res_line ] := 'DISPLAY_LINK';
    var_names [ res_unknown ] := '';
    
    END;        {  PROCEDURE init_tables  }
    
    
  PROCEDURE process_parameters;
  
    VAR
      param_line:  script_line;             {  Program parameter line }
      script:  token_type;
      delim:  token_type;
      successful:  BOOLEAN;
      
    BEGIN       {  PROCEDURE process_parameters  }
    
    os_get_param_line ( param_line );
    
    {  The following IF/EXIT is present to kludge around a IV bug that
    {  prevents EXIT from UNITs.                                        }
    
    IF LENGTH ( param_line ) = 0 THEN
      EXIT ( PROGRAM );
      
    eval_expr ( param_line, [ nam_tok ], [ eol_tok, com_tok ], command, 
      delim_tok );
    nest_stack [ 1 ] . script_name := command.nam_val;
    io_open_file ( script_file, nest_stack [ 1 ].script_name, io_input,
      successful );
    IF NOT successful THEN
      error ( fatal, CONCAT ( 'Cannot find script ', command.nam_val ) );
    IF IORESULT <> 0 THEN
      error ( fatal, 'I/O device error while opening script file' );

    do_define ( param_line );
    
    END;        {  PROCEDURE process_parameters  }
    
    
  BEGIN         {  SEGMENT PROCEDURE initialize  }
  
  {  Preset the display screen.  }
  
  init_screen;
  
  {  Initialize the serial interface link  }

  bauds [ baud_9600 ] := 9600;
  bauds [ baud_1200 ] := 1200;
  bauds [ baud_300 ] := 300;
  bauds [ baud_110 ] := 110;

  cr_comminit ( cr_orig, CHR ( ch_esc ), rem_exists, dialer_exists );
  IF NOT rem_exists THEN
    error ( catastrophic,  'Remote interface cannot be initialized' );

  {  If no default baud rate has been specified by a compilation constant
  {  (the usual case), try each baud rate in turn until REMUNIT accepts one.
  {  If a default baud rate has been specified, just try that one.            }
  
  IF default_baud = 0 THEN
    BEGIN
    attempted_baud_rate := baud_9600;
    REPEAT
      cr_setcommunications ( use_par, even_par, bauds [ attempted_baud_rate ],
        char_size, stop_bits, cr_orig, '', result );
      attempted_baud_rate := SUCC ( attempted_baud_rate );
    UNTIL ( result = cr_rate_set_ok ) OR ( result = cr_select_not_supported ) OR
      ( attempted_baud_rate = all_tried );
    END
  ELSE
    cr_setcommunications ( TRUE, TRUE, default_baud,
      char_size, stop_bits, cr_orig, '', result );
  
  IF ( result <> cr_rate_set_ok ) AND (result <> cr_select_not_supported ) THEN
    error ( catastrophic, 'Cannot set link baud rate' );

  alpha_chars := [ 'A'..'Z', 'a'..'z' ];
  visible_chars := [ '!' .. CHR ( 127 ) ];
  script_level := 1;
  highest_entry_index := 0;
  skipping := FALSE;
  cnd_cmds := [ if_cmd, ife_cmd, els_cmd, whi_cmd, whe_cmd ];
  
  {  Initialize the transfer file table.  }
  
  FOR table_index := 1 TO max_open_files DO
    tran_tbl [ table_index ] . now_open := FALSE;
    
  
  {  Initialize the Pascal variables that implement the reserved variables.  }
  
  cmd_display := FALSE;
  link_display := FALSE;
  
  {  Initialize the condition stack.  }
  
  cnd_level := 0;
  
  {  Initialize xlate_tbl.  This table is used to translate names (and other
  {  character strings) to all-upper-case, or non-control characters.         }
  
  FOR index := CHR ( 0 ) TO CHR ( 127 ) DO
    BEGIN
    IF index IN [ 'a'..'z' ] THEN
      xlate_tbl [ index ].upper := CHR ( ORD ( index ) - 32 )
    ELSE
      xlate_tbl [ index ] . upper := index;
    IF index <= ' ' THEN
      xlate_tbl [ index ] . no_ctl := ' '
    ELSE
      xlate_tbl [ index ] . no_ctl := index;
    END;        {  FOREND  }
    
  {  Initialize other "constant" tables.  This is done in a separate procedure
  {  due to a UCSD II.0 limitation on the size of a procedure.                 }
  
  init_tables;
  
  {  Process the program parameters.  }
  
  process_parameters;
  
  END;          {  SEGMENT PROCEDURE initialize  }

{$P}
  



SEGMENT PROCEDURE transfer_command ( line:  script_line;
                         VAR  successful:  BOOLEAN );

  CONST
    ch_cr = 13;         {  ASCII carriage return  }
    
  TYPE
    trans_direction = ( download, upload );
    
  VAR
    direction:  trans_direction;
    usecc_mode:  BOOLEAN;
    line_mode:  BOOLEAN;
    term_string:  name_type;
    prompt_string:  script_line;
    file_name:  name_type;
    period:  time_period;
    
  
  PROCEDURE scan_command ( line:  script_line;
                       VAR file_name:  name_type;
                       VAR direction:  trans_direction;
                       VAR usecc_mode:  BOOLEAN;
                       VAR term_string:  name_type;
                       VAR period:  time_period  );
    VAR
      value:  token_type;
      token:  token_type;
      keyword:  token_type;
    
    BEGIN       {  PROCEDURE scan_command  }
    
    {  Get the filename ( first symbol in the command ).  }
    
    eval_expr ( line, [ nam_tok ], [ com_tok, eol_tok ], value, token );
    file_name := value.nam_val;
    
    {  Set the defaults if the appropriate keywords are not encountered.  }
    
    direction := download;
    usecc_mode := FALSE;
    line_mode := FALSE;
    term_string := '';
    prompt_string := '';
    period := 300;
    
    {  Scan the command line for keywords.  }
    
    WHILE token.tok_kind <> eol_tok DO
      BEGIN
      eval_expr ( line, [ nam_tok ], [ com_tok, eol_tok, equ_tok ], keyword, 
        token );
      IF keyword.nam_val = 'UPLOAD' THEN  direction := upload;
      IF keyword.nam_val = 'DOWNLOAD' THEN  direction := download;
      IF keyword.nam_val = 'ADDCC' THEN  usecc_mode := TRUE;
      IF keyword.nam_val = 'USECC' THEN  usecc_mode := TRUE;
      IF keyword.nam_val = 'LINE' THEN line_mode := TRUE;
      IF keyword.nam_val = 'TERM' THEN
        BEGIN
        eval_expr ( line, [ str_tok ], [ com_tok, eol_tok ], value, token );
        term_string := value.str_val;
        make_upper ( term_string );
        END;
      IF keyword.nam_val = 'PROMPT' THEN
        BEGIN
        eval_expr ( line, [ str_tok ], [ com_tok, eol_tok ], value, token );
        prompt_string := value.str_val;
        make_upper ( prompt_string );
        END;
      IF keyword.nam_val = 'PERIOD' THEN
        BEGIN
        eval_expr ( line, [ int_tok ], [ com_tok, eol_tok], value, token );
        period := value.int_val;
        END;
    
      END;      {  WHILEND  }
    
    END;        {  PROCEDURE scan_command  }
  
  PROCEDURE do_upload ( file_name:  name_type;
                        usecc_mode:  BOOLEAN;
                        line_mode:  BOOLEAN;
                        prompt_string:  script_line;
                        period:  time_period  );
  
    CONST
      ch_ff = 12;       {  ASCII form feed character  }
      
    VAR
      buffer:  STRING [ 255 ];
      index:  0..255;
      successful:  BOOLEAN;
      tbl_index:  tran_range;
      
    BEGIN       {  PROCEDURE do_upload  }
    
    {  Open the transfer file.  If we are in ADDCC mode, write
    {  a first line containing only a carriage control of "1".               }
    
    get_tran_file ( file_name, io_input, tbl_index );
    
    IF usecc_mode THEN
      BEGIN
      cr_putrem ( '1' );
      cr_putrem ( CHR ( ch_cr )  );
      END;    {  IFEND  }
    
    IF NOT io_end_of_file ( tran_tbl [ tbl_index ] . file_blk ) THEN
      BEGIN
      REPEAT
        io_read_line ( tran_tbl [ tbl_index ] . file_blk, buffer );
        IF IORESULT <> 0 THEN
          error ( fatal, 'I/O device error while transfering file' );
        IF usecc_mode AND ( LENGTH ( buffer ) > 0 ) THEN
          BEGIN       {  Add carriage control character  }
          index := SCAN( LENGTH ( buffer ), = CHR ( ch_ff ), buffer [ 1 ] ) + 1;
          IF ( index < LENGTH ( buffer ) ) THEN
            BEGIN
            DELETE ( buffer, index, 1 );
            cr_putrem ( '1' );
            END
          ELSE
            cr_putrem ( ' ' );
          END;            {  IFEND  Add carriage control  }
        FOR index := 1 to LENGTH ( buffer ) DO
          BEGIN
          IF NOT cr_carrier THEN
            error ( fatal, 'Lost carrier during upload' );
          cr_putrem ( buffer [ index ] );
          END;    {  FOREND  }
        
        cr_putrem ( CHR ( ch_cr ) );
          
        IF ( LENGTH ( prompt_string ) > 0 ) AND NOT
         io_end_of_file ( tran_tbl [ tbl_index ] . file_blk ) THEN
          BEGIN
          match ( prompt_string, FALSE, period, successful );
          IF NOT successful THEN
            error ( fatal, 'Did not see prompt within specified period' );
          END;
        
        check_kb ( exit_requested );
        
      UNTIL io_end_of_file ( tran_tbl [ tbl_index ] . file_blk ) OR
       exit_requested OR line_mode;
      END;      {  IFEND  }
    
    IF io_end_of_file ( tran_tbl [ tbl_index ] . file_blk ) THEN
      close_tran_file ( tbl_index );
      
    END;        {  PROCEDURE do_upload  }
  
  
  PROCEDURE do_download ( file_name:  name_type;
                          term_string:  name_type;
                          usecc_mode:  BOOLEAN  );
  
    VAR
      buffer:  long_string;
      buffer_index:  1..255;
      ch:  CHAR;
      term_index:  script_index;
      terminated:  BOOLEAN;
      tbl_index:  tran_range;
    
    BEGIN       {  PROCEDURE do_download  }
    
    get_tran_file ( file_name, io_output, tbl_index );
    
    {$R-}  {  Disable range checking for speed in these loops.  }
    
    REPEAT      {  for each line  }
      
      buffer [ 0 ] := CHR ( 255 );
      buffer_index := 1;
      term_index := 1;
      terminated := FALSE;
      
      REPEAT    {  for each character  }
      
        REPEAT
          check_kb ( exit_requested );
        UNTIL cr_remstat OR exit_requested;
        
        IF NOT exit_requested THEN
          BEGIN
          ch := cr_getrem;
          IF  ch >=  ' '  THEN
            BEGIN
            buffer [ buffer_index ] := ch;
            buffer_index := buffer_index + 1;
            END;          {    IFEND  }
          
          IF xlate_tbl [ ch ] . upper  = term_string [ term_index ] THEN
            BEGIN
            IF term_index < LENGTH ( term_string ) THEN
              term_index := term_index + 1
            ELSE
              terminated := TRUE;
            END
          ELSE
            term_index := 1;
          END;
        
      UNTIL terminated OR ( ch = CHR ( ch_cr ) ) OR
        exit_requested OR NOT cr_carrier;
    
      buffer [ 0 ] := CHR ( buffer_index - 1 );
      
      {  If processing carriage controls and the first character in the 
      {  line is a "1", write an ASCII FF character as the first character
      {  in the line.  Delete any other value of carriage control character. }
      
      IF usecc_mode THEN
        IF LENGTH ( buffer ) > 0 THEN
          IF buffer [ 1 ] = '1' THEN
            buffer [ 1 ] := CHR ( ch_ff )
          ELSE
            DELETE ( buffer, 1, 1 );
            
      IF NOT terminated THEN
        BEGIN
        io_write_line ( tran_tbl [ tbl_index ] . file_blk, buffer );
        IF IORESULT <> 0 THEN
          error ( fatal, 'I/O device error while writing transfer file' );
        END;
    
    UNTIL terminated OR exit_requested OR NOT cr_carrier ;
    
    {$R+}  {  Reenable range checking.  }
    
    IF NOT cr_carrier THEN
      error ( fatal, 'Carrier lost during download' );
    
    close_tran_file ( tbl_index );
    
    END;        {  PROCEDURE do_download  }
    
  

  BEGIN         {  PROCEDURE transfer_command  }
  successful := FALSE;          {  in case a called procedure exits  }
  scan_command ( line, file_name, direction, usecc_mode, term_string, period );
  
  CASE direction OF
    
    download: BEGIN
              IF LENGTH ( term_string ) = 0 THEN
                error ( fatal, 
                  'Termination string must be specifed for download.');
              do_download ( file_name, term_string, usecc_mode );
              END;     {  CASE ITEM  }
    
    upload:  do_upload ( file_name, usecc_mode, line_mode, prompt_string, 
               period );
    
    END;        {  CASEND  }
  
  successful := TRUE;
  
  END;          {  SEGMENT PROCEDURE transfer_command  }

{$P}

PROCEDURE setup_display;

  VAR
    box_line:  STRING [ 80 ];
    
  BEGIN         {  PROCEDURE setup_display  }
  box_line :=  '----------------------------------------';
  box_line := CONCAT ( box_line, box_line );
    
  sc_eras_eos ( cmd_x, cmd_y+1 );
  IF cmd_display THEN
    BEGIN
    GOTOXY ( cmd_x, cmd_y );
    WRITE ( box_line );
    GOTOXY ( cmd_x, cmd_y + 1 );
    WRITE ( '|   Command:' );
    GOTOXY ( 79, cmd_y + 1 );
    WRITE ( '|' );
    GOTOXY ( cmd_x, cmd_y + 2 );
    WRITE ( box_line );
    END;        {  IFEND  }
  
  IF link_display THEN
    BEGIN
    GOTOXY ( link_x, link_y );
    WRITE ( 'Downlink text:  ' );
    GOTOXY ( link_x, link_y + 2 );
    END;        {  IFEND  }
    
  {  Note that we always initialize link_dis_line, even if we are not
  {  displaying link text, because this is where we always put the
  {  cursor when we're not writing something to the screen.            }
  
  link_dis_line := link_y + 2;
  
  END;          {  PROCEDURE setup_display  }
  

{$P}

PROCEDURE check_kb {  ( VAR exit_seen:  BOOLEAN )  };

  CONST
    ch_esc = 27;        {  ASCII ESC character  }
    
  BEGIN         {  PROCEDURE check_kb  }
  
  {  If the user hits ESC on the keyboard, return with exit_seen TRUE.
  {  Otherwise, don't change it.                                              }
  
  IF cr_kbstat THEN
    IF cr_getkb = CHR ( ch_esc ) THEN
      exit_seen := TRUE;
  END;          {  PROCEDURE check_kb  }
  
  

  
{$P}

PROCEDURE display_status ( message:  STRING );

  BEGIN         {  PROCEDURE display_status  }
  GOTOXY ( status_x + 11, status_y + 1 );
  WRITE ( message: 64 );
  GOTOXY ( 0, link_dis_line );
  END;          {  PROCEDURE display_status  }
  
  
{$P}



PROCEDURE error {  ( level:  error_level;
                  message:  STRING )  };

  VAR
    prefix:  STRING [ 25 ];
    
  BEGIN         {  PROCEDURE error  }
  CASE level OF
    
    warning:  prefix :=  'Warning - ' ;
    
    fatal:  prefix :=  'Fatal error - ' ;
    
    catastrophic:  prefix :=  'Catastrophic error - ' ;
    
    END;        {  CASEND  }
  display_status ( CONCAT ( prefix, message ));
  IF level > warning THEN
    BEGIN
    close_all_files;
    os_clear_commands;
    EXIT ( PROGRAM );
    END;
  END;          {  PROCEDURE error  }

{$P}

PROCEDURE get_tran_file {  ( file_name:  script_line;
                            direction:  io_direction;
                            VAR tbl_index:  tran_range  )  };

  VAR
    open_successful:  BOOLEAN;
    
  BEGIN         {  PROCEDURE get_tran_file  }
  
  {  First, check to see if the file is already open.  }
  
  tbl_index := 1;
  WHILE  ( ( tran_tbl [ tbl_index ] . name <> file_name ) OR
   ( tran_tbl [ tbl_index ] . direction <> direction ) OR
   ( NOT tran_tbl [ tbl_index ] . now_open ) ) AND
   ( tbl_index < max_open_files ) DO
    tbl_index := tbl_index + 1;
  
  IF  ( tran_tbl [ tbl_index ] . name <> file_name ) OR 
   NOT tran_tbl [ tbl_index ] . now_open OR 
   ( tran_tbl [ tbl_index ] . direction <> direction ) THEN
    
    BEGIN       
    
    {  File not already open, so search for vacant table entry.  }
    
    tbl_index := 1;
    WHILE tran_tbl [ tbl_index ].now_open AND ( tbl_index < max_open_files ) DO
      tbl_index := tbl_index + 1;
    
    IF tran_tbl [ tbl_index ] . now_open THEN
      error ( fatal, 'Maximum number of files already open' );
      
    tran_tbl [ tbl_index ] . name := file_name;
    tran_tbl [ tbl_index ] . direction := direction;
    tran_tbl [ tbl_index ] . now_open := TRUE;
    io_open_file ( tran_tbl [ tbl_index ] . file_blk, file_name, direction,
      open_successful );
    IF NOT open_successful THEN
      error ( fatal, CONCAT ( 'Cannot open transfer file ', file_name ) );
    IF IORESULT <> 0 THEN
      error ( fatal, 'I/O device error while opening transfer file' );
    
    END;         {  IFEND  }
   
  END;          {  PROCEDURE get_tran_file  }
  
{$P}

PROCEDURE close_tran_file { tbl_index:  tran_range };

  BEGIN
  io_close_file ( tran_tbl [ tbl_index ] . file_blk );
  IF IORESULT <> 0 THEN
    error ( fatal, 'I/O device error while closing transfer file' );
  tran_tbl [ tbl_index ] . now_open := FALSE;
  END;          {  PROCEDURE close_tran_file  }
  
{$P}

PROCEDURE close_all_files;

  VAR
    tbl_index:  1..max_open_files;
    
  BEGIN         {  PROCEDURE close_all_files  }
  FOR tbl_index := 1 TO max_open_files DO
    IF tran_tbl [ tbl_index ] . now_open THEN
      close_tran_file ( tbl_index );
  END;          {  PROCEDURE close_all_files  }

{$P}


PROCEDURE make_upper {  ( VAR symbol:  STRING )  };

  VAR
    index:  1..255;            
    
  BEGIN         {  PROCEDURE make_upper  }
  FOR index := 1 TO LENGTH ( symbol ) DO
    symbol [ index ] := xlate_tbl [ symbol [ index ] ] . upper;
  END;          {  PROCEDURE make_upper  }
  
  {$P}


PROCEDURE get_token { ( VAR line:  script_line;
                        expected:  set_of_token_kinds;
                        VAR  token:  token_type   )  };

  VAR
    index:  script_index;
    saved_line:  script_line;
    token_index:  token_kinds;
    msg_text:  STRING [ 255 ];
    
  PROCEDURE get_symbol;
  
    VAR
      symbol_length:  0..max_name_size;
      symbol_done:  BOOLEAN;
    
    BEGIN       {  PROCEDURE get_symbol  }
    symbol_length := 0;
    REPEAT
      symbol_length := symbol_length + 1;
      IF index + symbol_length <= LENGTH ( line ) THEN
        symbol_done :=  NOT (  line [ index + symbol_length ] IN 
          [ 'a'..'z', 'A'..'Z', '0'..'9','_', '$', '.', '*', ':' ] )
      ELSE
        symbol_done := TRUE;
    UNTIL symbol_done;
    token.tok_kind := nam_tok;
    token.nam_val := COPY ( line, index, symbol_length );
    make_upper ( token.nam_val );
    IF ( token.nam_val = 'TRUE' ) OR ( token.nam_val = 'YES' ) THEN
      BEGIN
      token.tok_kind := log_tok;
      token.log_val := TRUE;
      END
    ELSE
      IF (token.nam_val = 'FALSE' ) OR ( token.nam_val = 'NO' ) THEN
        BEGIN
        token.tok_kind := log_tok;
        token.log_val := FALSE;
        END
      ELSE
        IF token.nam_val = 'NOT' THEN
          token.tok_kind := not_tok;
    index := index + symbol_length;
    END;        {  PROCEDURE get_symbol  }
    
  PROCEDURE get_number;
  
    VAR
      more_to_go:  BOOLEAN;
      
    BEGIN       {  PROCEDURE get_number  }
    token.int_val := 0;
    REPEAT
      BEGIN
      token.int_val := ORD ( line [ index ] ) - 48 + ( token.int_val * 10 );
      index := index + 1;
      IF index <= LENGTH ( line ) THEN
        more_to_go := line [ index ] IN [ '0'..'9' ] 
      ELSE
        more_to_go := FALSE;
      END;      {  WHILEND  }
    UNTIL NOT more_to_go;
    END;        {  PROCEDURE get_number  }
  
  PROCEDURE get_string;
  
    VAR
      string_length:  0..max_script_line;
      string_done:  BOOLEAN;
    
    BEGIN       {  PROCEDURE get_string  }
    string_length := 0;
    index := index + 1;
    
    REPEAT
      IF ( index + string_length <= LENGTH ( line ) ) AND ( string_length <
       max_script_line ) THEN
        string_done := line [ index + string_length ] = ''''
      ELSE
        string_done := TRUE;
      IF NOT string_done THEN
        string_length := string_length + 1;
    UNTIL string_done;
    
    token.str_val := COPY ( line, index, string_length  );
    index := index + string_length + 1;
    END;        {  PROCEDURE get_string  }
    
  BEGIN         {  PROCEDURE get_token  }
  saved_line := line;
  token.tok_kind := no_tok;
  IF LENGTH ( line ) > 0 THEN
    BEGIN
    index := 1;
    REPEAT
      CASE line [ index ] OF
        
        ' ':  index := index + 1;
        
        ',':  BEGIN
              token.tok_kind := com_tok;
              index := index + 1;
              END;
        
        'a','b','c','d','e','f','g','h','i','j','k','l','m','n','o','p','q',
        'r','s','t','u','v','w','x','y','z','A','B','C','D','E','F','G','H',
        'I','J','K','L','M','N','O','P','Q','R','S','T','U','V','W','X','Y',
        'Z','.','_','*',':':  BEGIN 
              get_symbol;
              END;
        
        '$':  BEGIN
              get_symbol;
              token.tok_kind := fun_tok;
              END;
              
        '0','1','2','3','4','5','6','7','8','9':  BEGIN
             token.tok_kind := int_tok;
             get_number;
             END;
             
        '(':  BEGIN
              token.tok_kind := lpn_tok;
              index := index + 1;
              END;
              
        ')':  BEGIN
              token.tok_kind := rpn_tok;
              index := index + 1;
              END;
              
        '=':  BEGIN
              token.tok_kind := equ_tok;
              index := index + 1;
              END;
        
        '/':  BEGIN
              IF index < LENGTH ( line ) THEN
                IF line [ index + 1 ] = '/' THEN
                  BEGIN
                  token.tok_kind := con_tok;
                  index := index + 2;
                  END;
              IF token.tok_kind <> con_tok THEN
                BEGIN
                token.tok_kind := bad_tok;
                index := index + 1;
                END;
              END;      {  CASE ITEM  }
        
        '''': BEGIN
              token.tok_kind := str_tok;
              get_string;
              END;
        
        '!','"','#','%','&','+','-',';','<','>',
        '?','@','[','\',']','^','`','{','|','}','~':  
              BEGIN
              token.tok_kind := bad_tok;
              index := index + 1;
              END;
        
        END;      {  CASEND  }
    UNTIL ( token.tok_kind <> no_tok ) OR ( index > LENGTH ( line ) );
    
    DELETE ( line, 1, index - 1 );
    END;        {  IFEND  }
  
  IF ( token.tok_kind = no_tok ) AND ( LENGTH ( line ) = 0 ) THEN
    token.tok_kind := eol_tok;
  
  IF NOT ( token.tok_kind IN expected ) THEN
    BEGIN       {  report error  }
    msg_text := 'Command syntax error - Expected ';
    FOR token_index := nam_tok TO no_tok DO
      IF token_index IN expected THEN
        msg_text := CONCAT ( msg_text, tok_table [ token_index ], ', ' );
    error ( fatal, COPY ( msg_text, 1, LENGTH ( msg_text ) - 2 ) );
    END;        {  IFEND   report error  }
    
  END;          {  PROCEDURE get_token  }
  
{$P}

PROCEDURE lookup_variable ( VAR name:  token_type;
                            VAR found:  BOOLEAN  );

  VAR
    table_index:  sym_tbl_index;
    
  BEGIN         {  PROCEDURE lookup_variable  }
  
  {  Search the variable table for a match with the variable name.  }
  
  found := TRUE;
  IF highest_entry_index > 0 THEN
    FOR table_index := 1 TO highest_entry_index DO
      IF sym_table [ table_index ] . name = name.nam_val THEN
        BEGIN           {  match found  }
        name := sym_table [ table_index ] . value;
        EXIT ( lookup_variable );
        END;            {  IFEND }
  
  {  No match was found.  }
  
  found := FALSE;
  
  END;          {  PROCEDURE lookup_variable    }

{$P}

PROCEDURE eval_func ( VAR line:  script_line;
                      exp_type:  set_of_token_kinds;
                      VAR value:  token_type );

  VAR
    temp_token:  token_type;
    temp2_token:  token_type;
    delim_token:  token_type;
    fun_index:  fun_kinds;
    tbl_index:  tran_range;
    variable_found:  BOOLEAN;
    
  BEGIN           {  PROCEDURE eval_func  }
  make_upper ( value.fun_val );
  fun_index := chr_fun;
  WHILE ( value.fun_val <> fun_names [ fun_index ] ) AND 
   ( fun_index < bad_fun ) DO
    fun_index := SUCC ( fun_index );
  CASE fun_index OF
  
    chr_fun:  BEGIN
              get_token ( line, [ lpn_tok ], delim_token );
              get_token ( line, [ int_tok ], temp_token );
              IF (temp_token.int_val < 0 ) OR ( temp_token.int_val > 127 ) THEN
                error ( fatal, '$CHR parameter not 0..127' );
              value.tok_kind := str_tok;
              value.str_val := 'x';
              value.str_val [ 1 ] := CHR ( temp_token.int_val );
              get_token ( line, [ rpn_tok ], delim_token );
              END;      {  CASE ITEM  }
    
    val_fun:  BEGIN
              
              get_token ( line, [ lpn_tok ], delim_token );
              eval_expr ( line, [ nam_tok ], [ rpn_tok ], temp_token, 
                delim_token );
              
              lookup_variable ( temp_token, variable_found );
              IF NOT variable_found THEN
                error ( fatal, CONCAT ( 'Variable ', temp_token.nam_val,
                 ' has not been defined' ));
              
              value := temp_token;
              
              END;      {  CASE ITEM  }
              
    read_fun: BEGIN
              get_token ( line, [ lpn_tok ], delim_token );
              eval_expr ( line, [ nam_tok ], [ rpn_tok ], temp_token, 
                delim_token );
              get_tran_file ( temp_token.nam_val, io_input, tbl_index );
              value.tok_kind := str_tok;
              io_read_line ( tran_tbl [ tbl_index ] . file_blk,
                value.str_val );
              IF IORESULT <> 0 THEN
                error ( fatal, 'I/O device error while reading file' );
              END;      {  CASE ITEM  }
      
    eof_fun:  BEGIN
              get_token ( line, [ lpn_tok ], delim_token );
              eval_expr ( line, [ nam_tok ], [ rpn_tok ], temp_token,
                delim_token );
              get_tran_file ( temp_token.nam_val, io_input, tbl_index );
              value.tok_kind := log_tok;
              value.log_val :=
                io_end_of_file ( tran_tbl [ tbl_index ] . file_blk );
              END;      {  CASE ITEM  }
              
    eq_fun:   BEGIN
              get_token ( line, [ lpn_tok ], delim_token );
              eval_expr ( line, [ nam_tok, str_tok, int_tok, log_tok ],
                [ com_tok ], temp_token, delim_token );
              eval_expr ( line, [ temp_token.tok_kind ], [ rpn_tok ], 
                temp2_token, delim_token );
              value.tok_kind := log_tok;
              CASE temp_token.tok_kind OF
              
                nam_tok: value.log_val:=temp_token.nam_val=temp2_token.nam_val;
              
                str_tok: value.log_val:=temp_token.str_val=temp2_token.str_val;
                
                int_tok: value.log_val:=temp_token.int_val=temp2_token.int_val;
                
                log_tok: value.log_val:=temp_token.log_val=temp2_token.log_val;
                
                END;            {  CASEND  }
                
              END;      {  CASE ITEM  }
              
    str_fun:  BEGIN
              get_token ( line, [ lpn_tok ], delim_token );
              eval_expr ( line, [ nam_tok ], [ rpn_tok ], temp_token, 
                delim_token );
              value.tok_kind := str_tok;
              value.str_val := temp_token.nam_val;
              END;      {  CASE ITEM  }
    
    nam_fun:  BEGIN
              get_token ( line, [ lpn_tok ], delim_token );
              eval_expr ( line, [ str_tok ], [ rpn_tok ], temp_token,
                delim_token  );
              value.tok_kind := nam_tok;
              value.nam_val := temp_token.str_val;
              END;      {  CASE ITEM  }
    
    def_fun:  BEGIN
              get_token ( line, [ lpn_tok ], delim_token );
              eval_expr ( line, [ nam_tok ], [ rpn_tok ], temp_token,
                delim_token );
              lookup_variable ( temp_token, variable_found );
              value.tok_kind := log_tok;
              value.log_val := variable_found;
              END;      {  CASE ITEM  }
              
    bad_fun:  error ( fatal, 'Unknown function name' );
    
    END;        {  CASEND  }
  
  IF NOT ( value.tok_kind IN exp_type ) THEN
    error ( fatal, 'Function is not of expected type' );
    
  END;          {  PROCEDURE eval_func  }

{$P}
  
PROCEDURE eval_expr {  ( VAR line:  script_line;
                      exp_type:  set_of_token_kinds;
                      exp_delim:  set_of_token_kinds;
                      VAR value:  token_type;
                      VAR delim:  token_type  )  };

  VAR
    exp_operators:  set_of_token_kinds;
    exp_term:  set_of_token_kinds;
    term_value:  token_type;
    
  PROCEDURE get_term ( VAR line:  script_line;
                       exp_type:  set_of_token_kinds;
                       VAR value:  token_type );
  
    VAR
      unary_not:  BOOLEAN;
      unary_ops:  set_of_token_kinds;
    
    BEGIN       {  PROCEDURE get_term  }
    IF log_tok IN exp_type THEN
      unary_ops := [ not_tok ]
    ELSE
      unary_ops := [];
    unary_not := FALSE;
    REPEAT
      get_token ( line, exp_type + unary_ops + [ fun_tok ], value );
      IF value.tok_kind = fun_tok THEN
        eval_func ( line, exp_type, value )
      ELSE
        IF value.tok_kind = not_tok THEN
          unary_not := NOT unary_not;
    UNTIL NOT ( value.tok_kind IN unary_ops );
    
    IF unary_not THEN
      value.log_val := NOT value.log_val;
    END;        {  PROCEDURE get_term  }
    
  
  BEGIN         {  PROCEDURE eval_expr  }
  
  get_term ( line, exp_type, value );
  
  {  Now that we know the base type of the expression, figure out which 
  {  operators are acceptable.                                            }
  
  IF value.tok_kind = str_tok THEN
    exp_operators := [ con_tok ]
  ELSE
    exp_operators := [ ];
  
  get_token ( line, exp_operators + exp_delim, delim );
  WHILE delim.tok_kind IN exp_operators DO
    BEGIN
    get_term ( line, exp_type, term_value );
    IF delim.tok_kind = con_tok THEN
      value.str_val := CONCAT ( value.str_val, term_value.str_val );
    get_token ( line, exp_operators + exp_delim, delim );
    END;        {  WHILEND  }
  END;          {  PROCEDURE eval_expr  }
  
{$P}

PROCEDURE do_define {  ( line:  script_line )  };

  VAR
    var_name:  name_type;
    var_value:  token_type;
    res_index:  res_kinds;
    token:  token_type;
    table_index:  sym_tbl_index;
  
  BEGIN         {  PROCEDURE do_define  }
  REPEAT
    BEGIN       {  repeat for each defnition  }
    get_token ( line, [  nam_tok, eol_tok ], token );
    IF token.tok_kind <> eol_tok THEN
      BEGIN  {  more defnitions on line  }
      var_name := token.nam_val;
      make_upper ( var_name );
      get_token ( line, [ equ_tok ], token );
      eval_expr ( line, [ nam_tok, int_tok, str_tok, log_tok ], 
        [ com_tok, eol_tok ], var_value, token );
      
      {  Search the reserved variable table, and change the value of the
      {  relevant Pascal variable if found.  Note that we also put an
      {  entry into the Symbol table, so that the user can refer to
      {  this variable later.                                          }
      
      res_index := res_command;
      WHILE ( res_index < res_unknown ) AND 
        ( var_name <> var_names [ res_index ] ) DO
          res_index := SUCC ( res_index );
      
      IF res_index <> res_unknown THEN
        BEGIN
        IF ( res_index IN [ res_command, res_line ] ) AND 
          ( var_value.tok_kind <> log_tok ) THEN
            error ( fatal, CONCAT ( var_name, ' can only be TRUE or FALSE' ));
        IF res_index = res_command THEN
          cmd_display := var_value.log_val;
        IF res_index = res_line THEN
          link_display := var_value.log_val;
        END;    {  IFEND  }
        
      {  Find a table entry in which to put this symbol.  }
      
      table_index := 1;
      IF highest_entry_index > 0 THEN
        BEGIN 
        WHILE ( sym_table [ table_index ] . name <> var_name ) AND
         ( table_index < highest_entry_index ) DO
          table_index := table_index + 1;
        END;    {  IFEND  }
      IF ( highest_entry_index = 0 ) OR ( sym_table [ table_index ] . name <>
       var_name ) THEN
        BEGIN         {  new table entry needed  }
        IF highest_entry_index < sym_tbl_size THEN
          BEGIN       {  make new table entry  }
          highest_entry_index := highest_entry_index + 1;
          table_index := highest_entry_index;
          END           {  IFEND  }
        ELSE
          error ( fatal, 'Variable table is full' );
        END;            {  IFEND make new table entry  }
        
      {  Put new data into the variable table entry.  }
      
      sym_table [ table_index ] . name := var_name;
      sym_table [ table_index ] . value := var_value;
      END;      {  IFEND more definitions on line  }
    END;                {  REPEATEND for all defnitions  }
  UNTIL token.tok_kind = eol_tok;
  END;          {  PROCEDURE do_define  }         

{$P}

FUNCTION get_char:  CHAR;

  VAR
    ch:  CHAR;
    translated:  xlate_entry;
  
  BEGIN         {  FUNCTION get_char  }
  
  {$R-  Turn off range checking to speed up execution  }
  
  ch := cr_getrem;
  translated := xlate_tbl [ ch ];
  IF link_display THEN
    IF ch = CHR ( ch_lf ) THEN
      BEGIN
      IF link_dis_line < max_screen_y THEN
        link_dis_line := link_dis_line + 1
      ELSE
        link_dis_line := link_y + 2;
      GOTOXY ( link_x, link_dis_line );
      sc_clr_cur_line;
      END
    ELSE
      UNITWRITE ( console, translated.no_ctl, 1,, 4+8 );
  get_char := ch;
  
  {$R+  Turn range checking on again  }
  
  END;          {  FUNCTION get_char  }
  {$P}
  


PROCEDURE match {  ( text_line:  string_type;
                  quiet_ending:  BOOLEAN;
                  period:  time_period;
              VAR complete_match:  BOOLEAN )  };
 
  VAR
    delim:  token_type;         {  delimiter of the pattern  }
    char_index:  script_index;        {  current character being matched  }
    text_match:  BOOLEAN;             {  all the text has matched  }
    input_char:  CHAR;                {  character read from serial interface  }
    total_time:  os_timer;               {  time we've been trying to match  }   
    ending_time:  os_timer;              {  wait for quiet after text match}
    visible_seen:  BOOLEAN;           {  a visible char has been received  }
    exit_condition:  BOOLEAN;
    ms_period:  INTEGER;

  BEGIN         {  PROCEDURE match  }
    
  {$R-  Disable range checking to make this run faster.  }
    
  ms_period := period * 100;
  complete_match := FALSE;
  exit_condition := FALSE;
  os_start_timer ( total_time );
  
  WHILE cr_carrier AND NOT complete_match AND ( LENGTH ( text_line ) >
    0 ) AND ( os_elapsed_time ( total_time ) < ms_period ) AND 
    NOT exit_condition DO
    
    BEGIN
    text_match := FALSE;
    char_index := 1;
    
    REPEAT
      
      BEGIN           {  text match  }
      REPEAT
        check_kb ( exit_requested );
        exit_condition := exit_requested OR NOT cr_carrier OR
          ( os_elapsed_time ( total_time ) >= ms_period );
      UNTIL exit_condition OR cr_remstat;
      IF NOT exit_condition THEN
        BEGIN
        input_char := get_char;
        IF input_char = text_line [ char_index ] THEN
          IF char_index < LENGTH ( text_line ) THEN
            char_index := char_index + 1 
          ELSE
            text_match := TRUE
        ELSE
          char_index := 1;
        END;
      END;         {  REPEATEND text match  }
     
    UNTIL text_match OR exit_condition;
     
    IF text_match THEN
      BEGIN
      visible_seen := FALSE;
      IF quiet_ending THEN
        BEGIN     {  check for quiet ending  }
        os_start_timer ( ending_time );
        WHILE cr_carrier AND NOT visible_seen AND ( os_elapsed_time(ending_time) <
         500 ) AND NOT exit_condition DO
          BEGIN
          IF cr_remstat THEN 
            visible_seen := get_char IN visible_chars;
          check_kb ( exit_requested );
          exit_condition := exit_requested;
          END;    {  WHILEND  }
        END;      {  IFEND  }
       
      complete_match := NOT visible_seen AND cr_carrier;
      END;      {  ifend  }
    END;        {  WHILEND complete match  }
 
  {$R+  Reenable range checking.  }
  
  END;          {  PROCEDURE match  }
   



{$P}



PROCEDURE if_command ( line:  script_line );

  VAR
    value:  token_type;
    delim:  token_type;
    
  BEGIN         {  PROCEDURE if_command  }
  IF cnd_level = max_cnd_level THEN
    error ( fatal, 'Maximum conditional nesting level exceeded' );
  cnd_level := cnd_level + 1;
  cnd_stack [ cnd_level ] . cnd_kind := if_cnd;
  eval_expr ( line, [ log_tok ], [ eol_tok ], value, delim );
  skipping := NOT value.log_val OR skipping;
  cnd_stack [ cnd_level ] . skip_flag := skipping;
  END;          {  PROCEDURE if_command  }

{$P}

PROCEDURE ifend_command;

  BEGIN         {  PROCEDURE ifend_command  }
  IF ( cnd_level = 0 ) OR NOT ( cnd_stack [ cnd_level ] . cnd_kind IN 
   [ if_cnd, el_cnd ] ) THEN
    error ( fatal, 'IFEND not expected here.' );
  cnd_level := cnd_level - 1;
  IF cnd_level > 0 THEN
    skipping := cnd_stack [ cnd_level ] . skip_flag
  ELSE
    skipping := FALSE;
  END;          {  PROCEDURE ifend_command  }

{$P}

PROCEDURE else_command;

  BEGIN         {  PROCEDURE else_command  }
  IF ( cnd_level = 0 ) OR ( cnd_stack [ cnd_level ] . cnd_kind <> if_cnd )
   THEN
    error ( fatal, 'ELSE not expected here' );
  IF cnd_level = 1 THEN
    skipping := NOT skipping
  ELSE
    IF cnd_stack [ cnd_level - 1 ] . skip_flag <> TRUE THEN
      skipping := NOT skipping;
  cnd_stack [ cnd_level ] . skip_flag := skipping;
  END;          {  PROCEDURE else_command  }

{$P}

PROCEDURE while_command ( line:  script_line );

  VAR
    value:  token_type;
    delim:  token_type;
    
  BEGIN         {  PROCEDURE while_command  }
  IF cnd_level = max_cnd_level THEN
    error ( fatal, 'Maximum conditional nesting level exceeded' );
  cnd_level := cnd_level + 1;
  cnd_stack [ cnd_level ] . cnd_kind := wh_cnd;
  cnd_stack [ cnd_level ] . line_num := 
    nest_stack [ script_level ] . line_number - 1;
  eval_expr ( line, [ log_tok ], [ eol_tok ], value, delim );
  skipping := NOT value.log_val OR skipping;
  cnd_stack [ cnd_level ] . skip_flag := skipping;
  END;          {  PROCEDURE while_command  }

{$P}

PROCEDURE whilend_command;

  BEGIN         {  PROCEDURE whilend_command  }
  IF ( cnd_level = 0 ) OR ( cnd_stack [ cnd_level ] . cnd_kind <> 
    wh_cnd ) THEN
    error ( fatal, 'WHILEND not expected here.' );
  IF NOT skipping THEN
    BEGIN       {  jump to the top of the loop  }
    io_seek_line ( script_file, cnd_stack [ cnd_level ] . line_num );
    IF IORESULT <> 0 THEN
      error ( fatal, 'I/O device error while reading script file' );
    nest_stack [ script_level ] . line_number :=
      cnd_stack [ cnd_level ] . line_num;
    cnd_level := cnd_level - 1;
    END         {  go to top of loop  }
  ELSE
    BEGIN       {  finished skipping over loop  }
    cnd_level := cnd_level - 1;
    IF cnd_level > 0 THEN
      skipping := cnd_stack [ cnd_level ] . skip_flag
    ELSE
      skipping := FALSE;
    END;        {  ELSEND  finished skipping over loop  }
  END;          {  PROCEDURE whilend_command  }

{$P}

PROCEDURE return_command ( VAR exit_condition:  BOOLEAN );

  VAR
    file_exists:  BOOLEAN;
    
  BEGIN         {  PROCEDURE return_command  }
  IF script_level = 1 THEN
    exit_condition := TRUE
  ELSE
    BEGIN
    exit_condition := FALSE;
    io_close_file ( script_file );
    IF IORESULT <> 0 THEN
      error ( fatal, 'I/O device error while closing script file' );
    script_level := script_level - 1;
    io_open_file ( script_file, nest_stack [ script_level ] . script_name,
     io_input, file_exists );
    IF NOT file_exists THEN
      error ( catastrophic, 'Cannot open script file during RETURN' );
    IF IORESULT <> 0 THEN
      error ( fatal, 'I/O device error while opening script file' );
    io_seek_line ( script_file, nest_stack [ script_level ] . line_number );
    IF IORESULT <> 0 THEN
      error ( fatal, 'I/O device error while reading script file' );
    END;        {  ELSEND  }
  END;          {  PROCEDURE return_command  }
  
{$P}

PROCEDURE define_command ( line: script_line );

  BEGIN         {  PROCEDURE define_command  }
  do_define ( line );
  END;          {  PROCEDURE define_command  }

{$P}

PROCEDURE display_command ( line:  script_line );

  VAR
    message:  token_type;
    delim:  token_type;
    
  BEGIN         {  PROCEDURE display_command  }
  eval_expr ( line, [ str_tok ], [ eol_tok ], message, delim );
  display_status ( message.str_val );
  END;          {  PROCEDURE display_command  }
  
{$P}

PROCEDURE match_command ( text_line:  script_line;
                      VAR complete_match:  BOOLEAN );


  VAR
    anywhere_mode:  boolean;
    pattern:   token_type;
    delim:  token_type;
    keyword:  token_type;
    value:  token_type;
    period:  time_period;
    
  BEGIN         {  PROCEDURE match_command  }
  eval_expr ( text_line, [ str_tok ], [eol_tok, com_tok ], pattern, delim );
  anywhere_mode := TRUE;
  period := 300;
  WHILE delim.tok_kind = com_tok DO
    BEGIN
    eval_expr(text_line, [nam_tok],[eol_tok,com_tok,equ_tok ], keyword, delim );
    IF keyword.nam_val = 'ENDING' THEN
      anywhere_mode := FALSE;
    IF keyword.nam_val = 'PERIOD' THEN
      BEGIN
      eval_expr ( text_line, [ int_tok ], [ eol_tok, com_tok ], value, delim );
      period := value.int_val;
      END;
    END;        {  IFEND  }
  match ( pattern.str_val, NOT anywhere_mode, period, complete_match );
  IF NOT complete_match AND NOT exit_requested THEN
    error ( fatal, CONCAT ( 'Could not match ''', pattern.str_val, 
      ''' within specified period' ));
  END;          {  PROCEDURE match_command  }

{$P}

PROCEDURE send_command ( text_line:  script_line );

  VAR
    char_index:  script_index;
    echoed_char:  CHAR;
    text_data:  token_type; 
    delim:  token_type;
    param:  token_type;
    no_cr:  BOOLEAN;
    
  BEGIN       {  PROCEDURE send_command  }
  IF LENGTH ( text_line ) > 0  THEN
    BEGIN
    eval_expr(text_line, [ str_tok ], [ com_tok,eol_tok ], text_data, delim );
    no_cr := FALSE;
    WHILE delim.tok_kind = com_tok DO
      BEGIN
      eval_expr(text_line, [nam_tok], [ com_tok,eol_tok ], param, delim );
      IF param.nam_val = 'NOCR' THEN
        no_cr := TRUE;
      END;      {  WHILEND  }
    FOR char_index := 1 TO LENGTH ( text_data.str_val ) DO
      IF cr_carrier THEN 
        BEGIN
        cr_putrem ( text_data.str_val [ char_index ] );
        IF cr_remstat THEN echoed_char := get_char;
        END;            {  IFEND  }
    END;        {  IFEND  }
  IF cr_carrier AND NOT no_cr THEN 
    cr_putrem ( CHR ( ch_cr ) );
  IF cr_remstat THEN 
    echoed_char := get_char;
  END;        {  PROCEDURE send_command  }

{$P}

PROCEDURE pause_command ( text_line:  script_line );

  VAR
    pause_time:  os_timer;
    display_char:  CHAR;
  
  BEGIN         {  PROCEDURE pause_command  }
  os_start_timer ( pause_time );
  WHILE os_elapsed_time ( pause_time ) < 1000 DO 
    IF cr_carrier THEN
      IF cr_remstat THEN 
        display_char := get_char;
  END;          {  PROCEDURE pause_command  }

{$P}
 
PROCEDURE call_command ( line:  script_line );

  VAR
    name:  token_type;
    delim:  token_type;
    file_exists:  BOOLEAN;
    
  BEGIN         {  PROCEDURE call_command  }
  IF script_level = max_nest_level THEN
    error ( fatal, 'Maximum script nesting level exceeded' )
  ELSE
    BEGIN
    io_close_file ( script_file );
    IF IORESULT <> 0 THEN
      error ( fatal, 'I/O device error while closing script file' );
    script_level := script_level + 1;
    eval_expr ( line, [ nam_tok ], [ com_tok, eol_tok ], name, delim );
    nest_stack [ script_level ] . script_name := name.nam_val;
    nest_stack [ script_level ] . line_number := 1;
    io_open_file ( script_file,  name.nam_val, io_input, file_exists );
    IF NOT file_exists THEN
      error ( fatal, CONCAT ( 'Called script ', name.nam_val,
        ' does not exist' ) );
    IF IORESULT <> 0 THEN
      error ( fatal, 'I/O device error while opening script file' );
    END;        {  ELSEND  }
    IF delim.tok_kind = com_tok THEN
      do_define ( line );
  END;          {  PROCEDURE call_command  }

{$P}

PROCEDURE execute_command ( text_line:  script_line );

   VAR
     prog_name:  token_type;
     prog_param:  os_prog_param;
     delim:  token_type;

   BEGIN        {  PROCEDURE execute_command  }

   IF LENGTH ( text_line ) = 0 THEN
     error ( fatal, '?  No codefile title specified in eXecute command.' );

   eval_expr ( text_line, [ nam_tok ], [ eol_tok, com_tok ], prog_name,
     delim );

   IF LENGTH ( text_line ) > 0 THEN
     prog_param := text_line
   ELSE
     prog_param := '';

   os_store_command ( prog_name.nam_val, prog_param );
   
   close_all_files;
   os_exit_to_next;
   
   {  The following EXIT is present to kludge around a bug in IV.03.  Delete
   {  it when no longer needed.                                               }
   
   EXIT ( PROGRAM );
   
   END;         {  PROCEDURE execute_command  }
  
  {$P}
  
PROCEDURE dial_command ( text_line:  script_line  );

  VAR
    result:  cr_dialresult;
    
  BEGIN         {  PROCEDURE dial_command  }
  
  {  Take the line off-hook.  }
  
  cr_hook ( FALSE );
  
  {  Dial the number, and check the response we get.  }
  
  cr_dial ( text_line, ':', result );
  
  CASE result OF
    
    cr_noautodial: error ( fatal, 'Dialing not supported by REMUNIT software' );
  
    cr_dialerror: error ( fatal, 'Error detected by REMUNIT during dialing' );
    
    cr_offhook:  BEGIN  END;
    
    END;        {  CASEND  }
    
  END;          {  PROCEDURE dial_command  }
  
  {$P}
  
PROCEDURE hangup_command;

  BEGIN         {  PROCEDURE hangup_command  }
  
  cr_hook ( TRUE );
  
  END;          {  PROCEDURE hangup_command  }
  
  {$P}

PROCEDURE wait_command ( VAR carrier_found:  BOOLEAN );
    
  VAR
    start_time:  os_timer;
    
  BEGIN         {  PROCEDURE wait_command  }
  os_start_timer ( start_time );
  REPEAT
    check_kb ( exit_requested );
  UNTIL cr_carrier OR exit_requested OR ( os_elapsed_time ( start_time ) > 
    30000 );
  IF cr_carrier THEN
    cr_answer
  ELSE
    IF NOT exit_requested THEN
      error ( fatal, 'Did not detect carrier within 30 seconds' );
  carrier_found := TRUE;
  END;          {  PROCEDURE wait_command  }
  




{$P}

BEGIN          {  PROGRAM convers  }

initialize;
setup_display;
nest_stack [ 1 ] . line_number := 1;
exit_condition := FALSE;
exit_requested := FALSE;
display_status ( CONCAT ( 'Beginning execution of script ',
  nest_stack [ 1 ].script_name ));

WHILE NOT exit_condition DO
  BEGIN
  successful := TRUE;
  io_read_line ( script_file, cur_script_line );
  IF IORESULT <> 0 THEN
    error ( fatal, 'I/O device error while reading script file' );
  nest_stack [ script_level ] . line_number := 
    nest_stack [ script_level ] . line_number + 1;
  IF cmd_display THEN
    BEGIN
    GOTOXY ( cmd_x + 13, cmd_y + 1 );
    WRITE ( cur_script_line: 60 );
    GOTOXY ( 0, link_dis_line );
    END;        {  IFEND  }
  eval_expr ( cur_script_line, [ nam_tok ], [ nam_tok..bad_tok ], 
    command, delim_tok );
  
  make_upper ( command.nam_val );
  cmd_index := cal_cmd;
  WHILE ( command.nam_val <> cmd_names [ cmd_index ] ) AND 
   ( cmd_index < bad_cmd ) DO  
    cmd_index := SUCC ( cmd_index );
  IF cmd_index <> bad_cmd THEN
    BEGIN               {  valid command  }
    IF ( NOT skipping ) OR ( cmd_index IN cnd_cmds ) THEN
      CASE cmd_index OF
        cal_cmd:   call_command ( cur_script_line );
        com_cmd:   BEGIN  END;
        def_cmd:   define_command ( cur_script_line );
        dis_cmd:   display_command ( cur_script_line );
        dia_cmd:   dial_command ( cur_script_line );
        els_cmd:   else_command;
        exe_cmd:   execute_command ( cur_script_line );
        han_cmd:   hangup_command;
        if_cmd:    if_command ( cur_script_line );
        ife_cmd:   ifend_command;
        mat_cmd:   match_command ( cur_script_line, successful );
        pau_cmd:   pause_command ( cur_script_line );
        qui_cmd:   exit_condition := TRUE; 
        ret_cmd:   return_command ( exit_condition );
        sen_cmd:   send_command ( cur_script_line );
        tra_cmd:   transfer_command ( cur_script_line, successful );
        wai_cmd:   wait_command ( successful );
        whe_cmd:   whilend_command;
        whi_cmd:   while_command ( cur_script_line );
        END        {  CASEND   }
    END         {  IFEND valid command  }
  ELSE
    error ( fatal, CONCAT ( 'Unrecognized command ', command.nam_val,
     ' found.' ) );
  
  IF NOT exit_requested THEN
    check_kb ( exit_requested );
  exit_condition := NOT successful OR exit_condition OR exit_requested;
  
  END;           {  WHILEND  }

IF exit_requested THEN
  error ( warning, 'Execution ended in response to ESC key' );
  
close_all_files;

cr_commquit;

END.




========================================================================================
DOCUMENT :usus Folder:VOL29:conv_test.text
========================================================================================

*               SCRIPT CONV_TEST
*
*  This script provides a primitive test that CONVERS is installed
*  and executing properly.  Execute the script by starting CONVERS,
*  and entering:
*
*       CONV_TEST, DISPLAY_COMMANDS=YES, DISPLAY_LINK=YES
*
*  to the prompt.
*
*  The comments below tell what to expect as CONVERS executes.
*
*  The following Pause commands should each execute in approximately
*  one second.
pause
*
Pause
*
PAUSE
*
*  The following statements define some variables, and then execute
*  a WHILE loop three times.  Among other things, this tests that the
*  seek_line function of TEXTIO is working.
*
define, switch1=true, switch2=true
while, $VALUE ( switch1 )
  define, switch1 = $VALUE ( switch2 )
  define, switch2 = false
whilend
*
*  The following command should wait for a carrier to be detected.  If
*  no carrier is provided in approximately 30 seconds, it should abort.
*
wait
*
*  The following commands send some junk over the link, and then wait
*  for a (highly improbable) reply.  This may catch some drastic errors
*  in the installation.  For a more effective test, write your own scripts
*  based on the system with which you are communicating.
*
send, 'Transmitted test text'
Match, 'Say what?', ANYWHERE
return


========================================================================================
DOCUMENT :usus Folder:VOL29:draw4a.1.text
========================================================================================



PROCEDURE SETUP;     {Reads all color and weave}
VAR COUNT : INTEGER; {setup parameters and sends to screen}
BEGIN
  CLEARSCREEN;
  WRITELN;
  WRITELN('             ----- DRAWDOWN FOR 4 HARNESS LOOMS -----');
  WRITELN('             ',REM);
  WRITELN('             SETUP IS FOR ',HORIZLEN,' WARP THREADS');
  WRITELN;
  WRITELN('             "A" TABBY IS TREADLE  ',TABBYA);
  WRITELN('             "B" TABBY IS TREADLE  ',TABBYB);
  WRITELN;
  COUNT := 0;
  WRITELN('             THREADING SEQUENCE IS --->');
  WRITELN;
  FOR I := 1 TO HORIZLEN DO
  BEGIN
    WRITE (THREAD[I]:3);
    COUNT := COUNT + 1;
    IF COUNT MOD 25 = 0 THEN
    WRITELN;
  END;
  WRITELN;
  WRITELN('             WARP COLOR SEQUENCE IS --->');
  WRITELN;
  COUNT := 0;
  FOR I := 1 TO HORIZLEN DO
  BEGIN
    WRITE(COLOR1[I]:3);
    COUNT := COUNT + 1;
    IF COUNT MOD 25 = 0 THEN
    WRITELN;
  END;
  WRITELN;
  WRITELN;
  OKSET := [CHR(13)];
  WRITE('               PRESS <RETURN> TO CONTINUE');
  CH := GETCHAR(OKSET);
  IF CH = CHR(13) THEN
  CLEARSCREEN;
  WRITELN;
  WRITELN('             TREADLE TIEUP IS--->');
  WRITELN;
  FOR I := 1 TO 6 DO
  BEGIN
    WRITE('TREADLE ',I:2,' TO HARNESS NUMBERS',TIE1[I]:2,' -',TIE2[I]:2);
    WRITELN(' -',TIE3[I]:2);
  END;
  WRITELN;
  COUNT := 0;
  WRITELN('            TREADLING SEQUENCE IS---> ');
  WRITELN;
  FOR I := 1 TO VERTLEN DO
  BEGIN
    WRITE(TREADL[I]:3);
    COUNT := COUNT + 1;
    IF COUNT MOD 25 = 0 THEN
    WRITELN;
  END;
  WRITELN;
  WRITELN;
  WRITELN('              WEFT COLOR SEQUENCE IS --->');
  WRITELN;
  COUNT := 0;
  FOR I := 1 TO VERTLEN DO
  BEGIN
    WRITE(COLOR2[I]:3);
    COUNT := COUNT + 1;
    IF COUNT MOD 25 = 0 THEN
    WRITELN;
  END;
  WRITELN;
  WRITELN;
  WRITELN;
  OKSET := [CHR(13)];
  WRITE('            PRESS <RETURN> TO CONTINUE');
  CH := GETCHAR(OKSET);
  IF CH = CHR(13) THEN
  EXIT(SETUP)
END;

PROCEDURE PSETUP;     {Reads all plain drawdown setup}
VAR COUNT : INTEGER;  {parameters and sends to screen}
BEGIN
  CLEARSCREEN;
  WRITELN;
  WRITELN('             ----- DRAWDOWN FOR 4 HARNESS LOOMS -----');
  WRITELN('             ',REM);
  WRITELN('             SETUP IS FOR ',HORIZLEN,' WARP THREADS');
  WRITELN;
  WRITELN('             "A" TABBY IS TREADLE  ',TABBYA);
  WRITELN('             "B" TABBY IS TREADLE  ',TABBYB);
  WRITELN;
  COUNT := 0;
  WRITELN('             THREADING SEQUENCE IS --->');
  FOR I := 1 TO HORIZLEN DO
  BEGIN
    WRITE (THREAD[I]:3);
    COUNT := COUNT + 1;
    IF COUNT MOD 25 = 0 THEN
    WRITELN;
  END;
  WRITELN;
  WRITELN;
  WRITELN('             TREADLE TIEUP IS--->');
  FOR I := 1 TO 6 DO
  BEGIN
    WRITE('TREADLE',I:2,' TO HARNESS NUMBERS',TIE1[I]:2,' -',TIE2[I]:2);
    WRITELN(' -',TIE3[I]:2);
  END;
  WRITELN;
  COUNT := 0;
  WRITELN('            TREADLING SEQUENCE IS---> ');
  FOR I := 1 TO VERTLEN DO
  BEGIN
    WRITE(TREADL[I]:3);
    COUNT := COUNT + 1;
    IF COUNT MOD 25 = 0 THEN
    WRITELN;
  END;
  WRITELN;
  WRITELN;
  OKSET := [CHR(13)];
  WRITE('            PRESS <RETURN> TO CONTINUE');
  CH := GETCHAR(OKSET);
  IF CH = CHR(13) THEN
  EXIT(PSETUP)
END;

PROCEDURE SETUP1;     {Reads all color and weave setup}
VAR COUNT : INTEGER;  {parameters and outputs to printer}
BEGIN
  COUNT := 0;
  WRITELN(FT,'DRAWDOWN FOR 4 HARNESS LOOMS (color and weave)');
  WRITELN(FT,REM);
  WRITELN(FT,'SETUP IS FOR ',HORIZLEN,' THREADS.');
  WRITELN(FT);
  WRITELN(FT,'THREADING SEQUENCE IS --->');
  FOR I := 1 TO HORIZLEN DO
  BEGIN
    WRITE (FT,THREAD[I]:2);
    COUNT := COUNT + 1;
    IF COUNT MOD 30 = 0 THEN
    WRITELN(FT);
  END;
  WRITELN(FT);
  WRITELN(FT);
  WRITELN(FT,'WARP COLOR SEQUENCE IS --->');
  COUNT := 0;
  FOR I := 1 TO HORIZLEN DO
  BEGIN
    WRITE(FT,COLOR1[I]:2);
    COUNT := COUNT + 1;
    IF COUNT MOD 30 = 0 THEN
    WRITELN(FT);
  END;
  WRITELN(FT);
  WRITELN(FT);
  WRITELN(FT,'"A" TABBY IS TREADLE',TABBYA:2);
  WRITELN(FT,'"B" TABBY IS TREADLE',TABBYB:2);
  WRITELN(FT);
  WRITELN(FT,'TREADLE TIEUP IS--->');
  FOR I := 1 TO 6 DO
  BEGIN
    WRITE(FT,'TREADLE',I:2,' TO HARNESS NUMBERS ',TIE1[I]:2,' -',TIE2[I]:2);
    WRITELN(FT,' -',TIE3[I]:2);
  END;
  WRITELN(FT);
  COUNT := 0;
  WRITELN(FT,'TREADLING SEQUENCE IS --->');
  FOR I := 1 TO VERTLEN DO
  BEGIN
    WRITE(FT,TREADL[I]:2);
    COUNT := COUNT + 1;
    IF COUNT MOD 30 = 0 THEN
    WRITELN(FT);
  END;
  WRITELN(FT);
  WRITELN(FT);
  WRITELN(FT,'WEFT COLOR SEQUENCE IS --->');
  COUNT := 0;
  FOR I := 1 TO VERTLEN DO
  BEGIN
    WRITE(FT,COLOR2[I]:2);
    COUNT := COUNT + 1;
    IF COUNT MOD 30 = 0 THEN
    WRITELN(FT);
  END;
  WRITELN(FT);
  WRITELN(FT);
END;


PROCEDURE PSETUP1;   {Reads all plain drawdown setup}
VAR COUNT : INTEGER; {parameters and outputs to printer}
BEGIN
  COUNT := 0;
  WRITELN(FT);
  WRITELN(FT,'DRAWDOWN FOR 4 HARNESS LOOMS');
  WRITELN(FT,REM);
  WRITELN(FT,'SETUP IS FOR ',HORIZLEN,' THREADS.');
  WRITELN(FT);
  WRITELN(FT,'THREADING SEQUENCE IS --->');
  FOR I := 1 TO HORIZLEN DO
  BEGIN
    WRITE (FT,THREAD[I]:2);
    COUNT := COUNT + 1;
    IF COUNT MOD 30 = 0 THEN
    WRITELN(FT);
  END;
  WRITELN(FT);
  WRITELN(FT);
  WRITELN(FT,'"A" TABBY IS TREADLE',TABBYA:2);
  WRITELN(FT,'"B" TABBY IS TREADLE',TABBYB:2);
  WRITELN(FT);
  WRITELN(FT,'TREADLE TIEUP IS--->');
  FOR I := 1 TO 6 DO
  BEGIN
    WRITE(FT,'TREADLE',I:2,' TO HARNESS NUMBERS',TIE1[I]:2,' -',TIE2[I]:2);
    WRITELN(FT,' -',TIE3[I]:2);
  END;
  WRITELN(FT);
  COUNT := 0;
  WRITELN(FT,'TREADLING SEQUENCE IS --->');
  FOR I := 1 TO VERTLEN DO
  BEGIN
    WRITE(FT,TREADL[I]:2);
    COUNT := COUNT + 1;
    IF COUNT MOD 30 = 0 THEN
    WRITELN(FT);
  END;
  WRITELN(FT);
  WRITELN(FT);
END;


PROCEDURE CRTOUT;  {Outputs color and weave pattern to screen}
BEGIN
  CLEARSCREEN;
  SETUP;
  WRITELN;
  WRITELN;
  WRITELN;
  BEGIN
    FOR I := 1 TO VERTLEN DO
    BEGIN
      FOR J := 1 TO HORIZLEN DO
      BEGIN
        K := TREADL[I];
        IF ((THREAD[J] = TIE1[K]) OR (THREAD[J] = TIE2[K]) OR 
           (THREAD[J] = TIE3[K])) AND (COLOR1[J] IN ['D','d'])
           THEN WRITE(SHOWARPD)
        ELSE IF ((THREAD[J] = TIE1[K]) OR (THREAD[J] = TIE2[K]) OR
                (THREAD[J] = TIE3[K])) AND (COLOR1[J] IN ['L','l'])
           THEN WRITE(SHOWARPL)
        ELSE IF ((THREAD[J] <> TIE1[K]) OR (THREAD[J] <> TIE2[K]) OR
                (THREAD[J] <> TIE3[K])) AND (COLOR2[I] IN ['D','d'])
           THEN WRITE(SHOWARPD)
        ELSE IF ((THREAD[J] <> TIE1[K]) OR (THREAD[J] <> TIE2[K]) OR
                (THREAD[J] <> TIE3[K])) AND (COLOR2[I] IN ['L','l'])
           THEN WRITE(SHOWARPL)
      END;
    WRITELN;
    END;
  END;
  WRITELN;
  WRITELN;
  OKSET := [CHR(13)];
  WRITE('              PRESS <RETURN> TO CONTINUE');
  CH := GETCHAR(OKSET);
  IF CH = CHR(13) THEN
  EXIT(CRTOUT)
END;
  
  
PROCEDURE PCRTOUT;  {Outputs plain drawdown pattern to screen}
BEGIN
  CLEARSCREEN;
  PSETUP;
  WRITELN;
  WRITELN;
  BEGIN
    BEGIN
      FOR I := 1 TO VERTLEN DO
      BEGIN
        FOR J := 1 TO HORIZLEN DO
        BEGIN
          K := TREADL[I];
          IF (THREAD[J] = TIE1[K]) OR (THREAD[J] = TIE2[K]) OR
             (THREAD[J] = TIE3[K])  THEN
          WRITE(SHOWARPD) ELSE
          WRITE(SHOWARPL);
        END;
      WRITELN;
      END;
    END;
    WRITELN;
    WRITELN;
    OKSET := [CHR(13)];
    WRITE('              PRESS <RETURN> TO CONTINUE');
    CH := GETCHAR(OKSET);
    IF CH = CHR(13) THEN
    EXIT(PCRTOUT)
  END;
END;


PROCEDURE HARDCOPY;  {Outputs color and weave pattern to printer}

BEGIN
  CLEARSCREEN;
  WRITELN;
  WRITELN;
  WRITELN;
  WRITELN;
  WRITELN('                    SETUP FOR  PRINTER-->');
  WRITELN('                    10 Characters per INCH');
  WRITELN('                     8 Lines per INCH');
  WRITELN;
  WRITELN('        ***  NOTE---USE ASCII 96 PRINT WHEEL ON QUME ***');
  WRITELN;
  WRITELN;
  OKSET := [CHR(13)];
  WRITELN('                   PRESS <RETURN> TO CONTINUE');
  CH := GETCHAR(OKSET);
  IF CH = CHR(13) THEN
  BEGIN
    REWRITE(FT,'PRINTER:');
    SETUP1;
    WRITELN(FT,CHR(12));
    WRITELN(FT);
    BEGIN
      FOR I := 1 TO VERTLEN DO
      BEGIN
        FOR J := 1 TO HORIZLEN DO
        BEGIN
          K := TREADL[I];
          IF ((THREAD[J] = TIE1[K]) OR (THREAD[J] = TIE2[K]) OR 
             (THREAD[J] = TIE3[K])) AND (COLOR1[J] IN ['D','d'])
             THEN WRITE(FT,SHOWARPD)
          ELSE IF ((THREAD[J] = TIE1[K]) OR (THREAD[J] = TIE2[K]) OR
                  (THREAD[J] = TIE3[K])) AND (COLOR1[J] IN ['L','l'])
             THEN WRITE(FT,SHOWARPL)
          ELSE IF ((THREAD[J] <> TIE1[K]) OR (THREAD[J] <> TIE2[K]) OR
                  (THREAD[J] <> TIE3[K])) AND (COLOR2[I] IN ['D','d'])
             THEN WRITE(FT,SHOWARPD)
          ELSE IF ((THREAD[J] <> TIE1[K]) OR (THREAD[J] <> TIE2[K]) OR
                  (THREAD[J] <> TIE3[K])) AND (COLOR2[I] IN ['L','l'])
             THEN WRITE(FT,SHOWARPL)
        END;
      WRITELN(FT);
      END;
    END;
  END;
  WRITELN(FT,CHR(12));
  CLOSE(FT);
END;


PROCEDURE PHARDCOPY;  {Outputs plain drawdown pattern to printer}

BEGIN
  CLEARSCREEN;
  WRITELN;
  WRITELN;
  WRITELN;
  WRITELN;
  WRITELN('                    SETUP FOR  PRINTER-->');
  WRITELN('                    10 Characters per INCH');
  WRITELN('                     8 Lines per INCH');
  WRITELN;
  WRITELN('        ***  NOTE---USE ASCII 96 PRINT WHEEL ON QUME ***');
  WRITELN;
  WRITELN;
  OKSET := [CHR(13)];
  WRITELN('                   PRESS <RETURN> TO CONTINUE');
  CH := GETCHAR(OKSET);
  IF CH = CHR(13) THEN
  BEGIN
    REWRITE(FT,'PRINTER:');
    WRITELN(FT);
    WRITELN(FT);
    PSETUP1;
    WRITELN(FT,CHR(12));
    WRITELN(FT);
    WRITELN(FT);
    BEGIN
      FOR I := 1 TO VERTLEN DO
      BEGIN
        FOR J := 1 TO HORIZLEN DO
        BEGIN
          K := TREADL[I];
          IF (THREAD[J] = TIE1[K]) OR (THREAD[J] = TIE2[K]) OR
             (THREAD[J] = TIE3[K])  THEN
          WRITE(FT,SHOWARPD)
          ELSE WRITE(FT,SHOWARPL);
        END;
        WRITELN(FT);
      END;
    END;
  END;
  WRITELN(FT,CHR(12));
  CLOSE(FT);
END;


PROCEDURE GRAFOUT;  {Outputs color and weave pattern}
                    {to IDS-460 graphics printer}
BEGIN
  CLEARSCREEN;
  WRITELN;
  WRITELN;
  WRITELN;
  WRITELN('                    SETUP FOR IDS-460 PRINTER-->');
  WRITELN('                    10 Characters per INCH');
  WRITELN('                     8 Lines per INCH');
  WRITELN('             ENABLE EXPANDED FUNCTION-- SWITCH NO. 7  ON ..');
  WRITELN;
  WRITELN;
  OKSET := [CHR(13)];
  WRITELN('                     PRESS <RETURN> TO CONTINUE');
  CH := GETCHAR(OKSET);
  IF CH = CHR(13) THEN
  BEGIN
    REWRITE(FT,'PRINTER:');
    SETUP1;
    WRITELN(FT);
    WRITELN(FT);
    WRITE(FT,CHR(3)); {Puts IDS-460 into graphics mode}
    BEGIN
      FOR I := 1 TO VERTLEN DO
      BEGIN
        FOR J := 1 TO HORIZLEN DO
        BEGIN
          K := TREADL[I];
          IF ((THREAD[J] = TIE1[K]) OR (THREAD[J] = TIE2[K]) OR 
             (THREAD[J] = TIE3[K])) AND (COLOR1[J] IN ['D','d'])
          THEN DPIXEL
          ELSE IF ((THREAD[J] = TIE1[K]) OR (THREAD[J] = TIE2[K]) OR
                  (THREAD[J] = TIE3[K])) AND (COLOR1[J] IN ['L','l'])
          THEN LPIXEL
          ELSE IF ((THREAD[J] <> TIE1[K]) OR (THREAD[J] <> TIE2[K]) OR
                  (THREAD[J] <> TIE3[K])) AND (COLOR2[I] IN ['D','d'])
          THEN DPIXEL
          ELSE IF ((THREAD[J] <> TIE1[K]) OR (THREAD[J] <> TIE2[K]) OR
                  (THREAD[J] <> TIE3[K])) AND (COLOR2[I] IN ['L','l'])
          THEN LPIXEL
        END;
      WRITE(FT,CHR(3),CHR(14)); {Graphics CR & LF}
      END;
    END;
  END;
  WRITELN(FT,CHR(3),CHR(2)); {Disabels graphics mode}
  WRITELN(FT,CHR(12)); {FF}
  CLOSE(FT);
END;


PROCEDURE PGRAFOUT;  {Outputs plain drawdown pattern}
                     {to IDS-460 graphics printer}
BEGIN
  CLEARSCREEN;
  WRITELN;
  WRITELN;
  WRITELN;
  WRITELN('                    SETUP FOR IDS-460 PRINTER-->');
  WRITELN('                    10 Characters per INCH');
  WRITELN('                     8 Lines per INCH');
  WRITELN('             ENABLE EXPANDED FUNCTION-- SWITCH NO. 7  ON ..');
  WRITELN;
  WRITELN;
  OKSET := [CHR(13)];
  WRITELN('                     PRESS <RETURN> TO CONTINUE');
  CH := GETCHAR(OKSET);
  IF CH = CHR(13) THEN
  BEGIN
    REWRITE(FT,'PRINTER:');
    WRITELN(FT);
    WRITELN(FT);
    PSETUP1;
    WRITELN(FT);
    WRITELN(FT);
    WRITE(FT,CHR(3)); {Puts IDS-460 into graphics mode}
    BEGIN
      FOR I := 1 TO VERTLEN DO
      BEGIN
        FOR J := 1 TO HORIZLEN DO
        BEGIN
          K := TREADL[I];
          IF (THREAD[J] = TIE1[K]) OR (THREAD[J] = TIE2[K]) OR
             (THREAD[J] = TIE3[K])  THEN
          DPIXEL
          ELSE
          LPIXEL
        END;
        WRITE(FT,CHR(3),CHR(14));  {Graphics CR & LF}
      END;
    END;
  END;
  WRITE(FT,CHR(3),CHR(2));  {Disable graphics mode}
  WRITELN(FT,CHR(12));
  CLOSE(FT);
END;


PROCEDURE PRINT;  {Secondary menu for output selection}
VAR CH : CHAR;
    OKSET : SETOFCHAR;
BEGIN
  CLEARSCREEN;
  OKSET := ['S','s','P','p','G','g','Q','q'];
  WRITELN('                 Do you want output to go to the------>');
  WRITELN;
  WRITELN;
  WRITE('    --->  S)creen,  P)rinter normal,  G)raphics IDS-460,  Q)UIT ? ');
  CH := GETCHAR(OKSET);
  CASE CH OF
    'S','s'  : CRTOUT;
    'P','p'  : HARDCOPY;
    'G','g'  : GRAFOUT;
    'Q','q'  : BEGIN
                 CLEARSCREEN;
                 EXIT(PRINT);
               END;
  END;
END;


PROCEDURE PPRINT;  {Secondary menu for output selection}
VAR CH : CHAR;
    OKSET : SETOFCHAR;
BEGIN
  CLEARSCREEN;
  OKSET := ['S','s','P','p','G','g','Q','q'];
  WRITELN('                 Do you want output to go to the------>');
  WRITELN;
  WRITELN;
  WRITE('    --->  S)creen,  P)rinter normal,  G)raphics IDS-460,  Q)UIT ? ');
  CH := GETCHAR(OKSET);
  CASE CH OF
    'S','s'  : PCRTOUT;
    'P','p'  : PHARDCOPY;
    'G','g'  : PGRAFOUT;
    'Q','q'  : BEGIN
                 CLEARSCREEN;
                 EXIT(PPRINT);
               END;
  END;
END;



PROCEDURE TITLE;  {Title block for program}
BEGIN
  OKSET := [CHR(13)];
  CLEARSCREEN;
  GOTOXY(0,2);
  WRITELN('                      ***** PROGRAM DRAW4C *****');
  GOTOXY(0,6);
  WRITELN('        This program is for four harness looms and the output');
  WRITELN;
  WRITELN('        is a Drawdown to a printer or the terminal.  The program');
  WRITELN;
  WRITELN('        was inspired by the book "COLOR AND WEAVE" by Margaret and');
  WRITELN;
  WRITELN('        Thomas Windeknecht.  It is written in UCSD Pascal version');
  WRITELN;
  WRITELN('        IV.1 for the Sage II computer and output on a standard');
  WRITELN;
  WRITELN('        printer or graphics output on the IDS-460 printer.');
  WRITELN;
  WRITELN('                  by GEORGE. H. DODGE    December 1983');
  WRITELN;
  WRITELN;
  WRITE('                        PRESS <RETURN> TO CONTINUE');
  CH := GETCHAR(OKSET);
  IF CH = CHR(13) THEN
  EXIT(TITLE);
END;

 

PROCEDURE CMENU;  {Color and weave menu}

VAR OKSET : SETOFCHAR;

BEGIN
  OKSET := ['A','a','B','b','C','c','D','d','P','p','Q','q'];
  REPEAT
    CLEARSCREEN;
    WRITE('> Draw4C:  A)Threading  B)Tieup  C)Treadling  ');
    WRITE('D)DrawnIn  P)rint  Q)uit---> ');
    CH := GETCHAR(OKSET);
    CASE CH OF
      'A','a' : THREADING;
      'B','b' : TYEUP;
      'C','c' : TREADLING;
      'D','d' : COPYTHRD;
      'P','p' : PRINT;
      'Q','q' : BEGIN
                  CLEARSCREEN;
                  MENU;
                END;
     END;
 UNTIL FALSE
 END;
 
 
PROCEDURE PMENU;  {Plain drawdown menu}

VAR OKSET : SETOFCHAR;

BEGIN
  OKSET := ['A','a','B','b','C','c','D','d','P','p','Q','q'];
  REPEAT
    CLEARSCREEN;
    WRITE('> Draw4:  A)Threading  B)Tieup  C)Treadling  ');
    WRITE('D)DrawnIn  P)rint  Q)uit---> ');
    CH := GETCHAR(OKSET);
    CASE CH OF
      'A','a' : PTHREADING;
      'B','b' : TYEUP;
      'C','c' : PTREADLING;
      'D','d' : COPYTHRD;
      'P','p' : PPRINT;
      'Q','q' : BEGIN
                  CLEARSCREEN;
                  MENU;
                END;
     END;
 UNTIL FALSE
 END;
 
PROCEDURE MENU;  {Main program menu}

VAR OKSET : SETOFCHAR;

BEGIN
  OKSET := ['P','p','C','c','Q','q'];
  REPEAT
    CLEARSCREEN;
    WRITE('> DrawDown 4 :    P)lain drawdown     C)olor & weave    Q)uit---> ');
    CH := GETCHAR(OKSET);
    CASE CH OF
       'P','p'  : PMENU;
       'C','c'  : CMENU;
       'Q','q'  : BEGIN
                    CLEARSCREEN;
                    EXIT(PROGRAM);
                  END;
 END;
 UNTIL FALSE
 END;



BEGIN   {Main program}
  TITLE;
  MENU;
END.



========================================================================================
DOCUMENT :usus Folder:VOL29:draw4a.text
========================================================================================



PROGRAM DRAW4;

uses screenops;

CONST SHOWARPD = '#';
      SHOWARPL = ' ';

TYPE SETOFCHAR = SET OF CHAR;


VAR  THREAD : ARRAY[1..80] OF INTEGER;  {For threading info}
     TREADL : ARRAY[1..80] OF INTEGER;  {For treadling info}
     TIE1, TIE2, TIE3 : ARRAY[1..10] OF INTEGER;  {For tieup info}
     COLOR1, COLOR2 : ARRAY[1..80] OF CHAR;  {For color info}
     I, J, K, MAXSIZE, HORIZLEN, VERTLEN, TABBYA, TABBYB  : INTEGER;
     REM : STRING[40];
     OKSET : SETOFCHAR;
     GOOD : BOOLEAN;
     CH, BS, CR, BELL : CHAR;
     FT : TEXT;
     
     
PROCEDURE MENU; FORWARD;

PROCEDURE CLEARSCREEN;
BEGIN
  sc_clr_screen;
END;

PROCEDURE DPIXEL;  {Dark pixel for IDS-460 graphics}
BEGIN
  WRITE(FT,CHR(85),CHR(42),CHR(85),CHR(42),CHR(85),CHR(42),CHR(85));
END;

PROCEDURE LPIXEL;  {Light pixel for IDS-460 graphics}
BEGIN
  WRITE(FT,CHR(0),CHR(0),CHR(0),CHR(0),CHR(0),CHR(0),CHR(0));
END;

FUNCTION GETCHAR(OKSET : SETOFCHAR) : CHAR;
VAR CH   : CHAR;
    GOOD : BOOLEAN;
    
BEGIN
  CR := CHR(13);
  BELL := CHR(7);
  REPEAT
    READ(KEYBOARD,CH);
    IF EOLN(KEYBOARD) THEN CH := CR;
    GOOD := CH IN OKSET;
    IF NOT GOOD THEN
    WRITE(BELL) ELSE
    IF CH IN [' '..CHR(125)] THEN
    WRITE(CH)
  UNTIL GOOD;
  GETCHAR := CH;
END;

  
  { Used by GETINTEGER for bomb proof numerical data entry }
  
FUNCTION GETNUM(MAXVAL,MINVAL : REAL; PTOK : BOOLEAN):REAL;

TYPE SETOFCHAR = SET OF CHAR;

VAR FIRSTCHAR, LASTCHAR    : BOOLEAN;
    NUMSET, GETSET, OKSET  : SETOFCHAR;
    NUMSTRTEMP             : STRING[10];
    S1                     : STRING[1];
    LEN, MAXLEN            : INTEGER;
    NUM                    : REAL;
    CR, BS, BELL           : CHAR;
    


FUNCTION FPNUM(FPSTR : STRING) : REAL;
VAR POWER, SIGN, I : INTEGER;
    NUM : REAL;
    
BEGIN
  IF FPSTR[1] = '-' THEN
  BEGIN
    SIGN := -1;
    DELETE(FPSTR,1,1);
  END ELSE
  SIGN := 1;
  
  POWER := POS('.',FPSTR);
  IF POWER <> 0 THEN
  BEGIN
    DELETE(FPSTR,POWER,1);
    POWER := LENGTH(FPSTR)- POWER +1;
  END;
  NUM := 0;
  FOR I := 1 TO LENGTH(FPSTR) DO
  NUM := 10 * NUM + (ORD(FPSTR[I]) - ORD('0'));
  FPNUM := SIGN * NUM/PWROFTEN(POWER);
END;

BEGIN
  CR := CHR(13); BS := CHR(8); BELL := CHR(7);
  NUMSET := ['0'..'9'];
  IF MINVAL < 0 THEN OKSET := NUMSET + ['-'] ELSE OKSET := NUMSET;
  IF PTOK THEN MAXLEN := 8 ELSE MAXLEN := 7;
  S1 := ' '; NUMSTRTEMP := '';
  
  REPEAT
    LEN := LENGTH(NUMSTRTEMP);
    FIRSTCHAR := (LEN=0);
    LASTCHAR := (LEN=MAXLEN);
    
    IF PTOK THEN OKSET := OKSET + ['.'] ELSE
    OKSET := OKSET - ['.'];
    
    IF FIRSTCHAR THEN GETSET := OKSET ELSE
    IF LASTCHAR THEN GETSET := [CR,BS] ELSE
    GETSET := OKSET + [CR,BS] - ['-'];
    
    S1[1] := GETCHAR(GETSET);
    IF S1 = '.' THEN PTOK := FALSE;
    
    IF S1[1] IN OKSET THEN
    BEGIN
      NUMSTRTEMP := CONCAT(NUMSTRTEMP,S1);
      IF S1[1] IN NUMSET THEN
      BEGIN
        NUM := FPNUM(NUMSTRTEMP);
        IF (NUM > MAXVAL) OR (NUM < MINVAL) THEN
        BEGIN
          WRITE(CHR(7));
          WRITE(BS,' ',BS);
          DELETE(NUMSTRTEMP,LEN+1,1);
        END;
      END;
    END ELSE
    IF S1[1] = BS THEN
    BEGIN
      IF POS('.',NUMSTRTEMP) = LEN THEN
      PTOK := TRUE;
      WRITE(BS,' ',BS);
      DELETE(NUMSTRTEMP,LEN,1);
    END;
    
  UNTIL S1[1] = CR; WRITELN;
  GETNUM := FPNUM(NUMSTRTEMP);
END;



FUNCTION GETINTEGER(PROMPT : STRING; MAXVAL, MINVAL : INTEGER) : INTEGER;
VAR POINTOK : BOOLEAN;  {For bomb proof entry of numerical data}
    EOL : STRING[2];
BEGIN
  WRITE(PROMPT,CHR(27),CHR(116));  {Erase to end of line for TV-925 Term.}
  POINTOK := FALSE;
  GETINTEGER := TRUNC(GETNUM(MAXVAL,MINVAL,FALSE));
END;






PROCEDURE THREADING;  {Color and weave threading entry routine}

VAR COUNT, RPTFAC, RPTSEQ, I, J, K : INTEGER;
    {RPTFAC = Repeat factor, RPTSEQ = Repeat sequence}
    TEMP : ARRAY [1..80] OF INTEGER; {Temp array for repeat sequence}
    TEMPC : ARRAY [1..80] OF CHAR;  {Temp array for color repeat sequence}
    OKSET : SETOFCHAR;
    

BEGIN
  CLEARSCREEN;
  REM := '';
  WRITELN;
  WRITELN('ENTER ANY COMMENTS YOU MAY WANT UP TO 40 CHARACTERS--IF YOU');
  WRITELN('DON''T WANT ANY COMMENTS ---- PRESS <RETURN>');
  WRITELN;
  WRITELN('                  >----------------------------------------<');
  WRITE('ENTER COMMENTS --> ');
  READLN(REM);
  WRITELN;
  WRITELN('ENTER THE MAXIMUM NUMBER OF THREADS YOU WANT IN YOUR DRAWDOWN');
  WRITELN('THE MINIMUM SHOULD BE ONE REPEAT LENGTH AND THE MAXIMUM IS 80');
  WRITELN;
  MAXSIZE := GETINTEGER('HOW MANY WARP THREADS ?---> ',80,1);
  WRITELN;
  RPTSEQ := GETINTEGER('HOW MANY THREADS IN A REPEAT ?--->',80,1);
  RPTFAC := MAXSIZE DIV RPTSEQ;
  HORIZLEN := RPTSEQ * RPTFAC;
  WRITELN;
  WRITELN;
  WRITELN;
  WRITELN('                       ENTER YOUR THREADING REPEAT SEQUENCE');
  WRITELN('                              FOR ',RPTSEQ:3,' THREADS AND');
  WRITELN('                                   4 HARNESSES');
  WRITELN;
  FOR I := 1 TO RPTSEQ DO
  BEGIN
    WRITE('NO. ',I:2,' THREAD ');
    TEMP[I] := GETINTEGER(' TO HARNESS NO.--->  ',4,1);
  END;
  J := 1;
  FOR I := 1 TO RPTFAC DO
    BEGIN
      FOR K := 1 TO RPTSEQ DO
      BEGIN
        THREAD[J] := TEMP[K];
        J := J + 1
      END;
    END;
  CLEARSCREEN;
  WRITELN;
  WRITELN('THREADING SEQUENCE IS----->');
  WRITELN;
  COUNT := 0;
  FOR I := 1 TO HORIZLEN DO
  BEGIN
    WRITE(THREAD[I]:3);
    COUNT := COUNT + 1;
    IF COUNT MOD 25 = 0 THEN
    WRITELN;
  END;
  WRITELN;
  WRITELN;
  OKSET := [CHR(13)];
  WRITE('                  PRESS <RETURN> TO CONTINUE');
  CH := GETCHAR(OKSET);
  IF CH = CHR(13) THEN
  CLEARSCREEN;
  WRITELN;
  WRITELN;
  WRITELN('ENTER YOUR WARP THREAD COLOR REPEAT SEQUENCE WITH EITHER ');
  WRITELN('"D" OR "L" FOR EACH THREAD FOR ',RPTSEQ,' THREADS');
  WRITELN;
  OKSET := ['D','d','L','l'];
  FOR I := 1 TO RPTSEQ DO
  BEGIN
    WRITE('NO. ',I:2,' THREAD COLOR --> ');
    TEMPC[I] := GETCHAR(OKSET);
    WRITELN;
  END;
  WRITELN;
  WRITELN;
  J := 1;
  FOR I := 1 TO RPTFAC DO
    BEGIN
      FOR K := 1 TO RPTSEQ DO
      BEGIN
        COLOR1[J] := TEMPC[K];
        J := J + 1
      END;
    END;
  CLEARSCREEN;
  WRITELN('WARP THREAD COLOR SEQUENCE IS --->');
  WRITELN;
  COUNT := 0;
  FOR I := 1 TO HORIZLEN DO
  BEGIN
    WRITE(COLOR1[I]:3);
    COUNT := COUNT + 1;
    IF COUNT MOD 25 = 0 THEN
    WRITELN;
  END;
  WRITELN;
  WRITELN;
  WRITELN;
  WRITELN;
  OKSET := [CHR(13)];
  WRITE('                  PRESS <RETURN> TO CONTINUE');
  CH := GETCHAR(OKSET);
  IF CH = CHR(13) THEN
  EXIT(THREADING);
END;


PROCEDURE PTHREADING;  {Plain drawdown threading entry routine}
VAR COUNT, RPTFAC, RPTSEQ, I, J, K : INTEGER;
    TEMP : ARRAY[1..80] OF INTEGER;
    TEMPC : ARRAY[1..80] OF CHAR;
    OKSET : SETOFCHAR;
  
  BEGIN
  CLEARSCREEN;
  REM := '';
  WRITELN('ENTER ANY COMMENTS YOU MAY HAVE UP TO 40 CHARACTERS--IF YOU');
  WRITELN('DON''T WANT ANY COMMENTS -------- PRESS <RETURN>');
  WRITELN;
  WRITELN('                  >---------------------------------------<');
  WRITE('ENTER COMMENTS --> ');
  READLN(REM);
  WRITELN;
  WRITELN('ENTER THE MAXIMUM NUMBER OF THREADS YOU WANT IN YOUR DRAWDOWN');
  WRITELN('THE MINIMUM SHOULD BE ONE REPEAT LENGTH AND THE MAXIMUM IS 80');
  WRITELN;
  MAXSIZE := GETINTEGER('HOW MANY WARP THREADS DO YOU WANT ??---> ',80,1);
  WRITELN;
  RPTSEQ := GETINTEGER('HOW MANY THREADS IN A REPEAT ?--->',80,1);
  RPTFAC := MAXSIZE DIV RPTSEQ;
  HORIZLEN := RPTSEQ * RPTFAC;
  WRITELN;
  WRITELN;
  WRITELN;
  WRITELN('                       ENTER YOUR THREADING REPEAT SEQUENCE');
  WRITELN('                              FOR ',RPTSEQ:3,' THREADS AND');
  WRITELN('                                   4 HARNESSES');
  WRITELN;
  FOR I := 1 TO RPTSEQ DO
  BEGIN
    WRITE('NO. ',I:2,' THREAD ');
    TEMP[I] := GETINTEGER(' TO HARNESS NO.--->  ',4,1);
  END;
  J := 1;
  FOR I := 1 TO RPTFAC DO
    BEGIN
      FOR K := 1 TO RPTSEQ DO
      BEGIN
        THREAD[J] := TEMP[K];
        J := J + 1
      END;
    END;
  WRITELN;
  WRITELN('THREADING SEQUENCE IS----->');
  WRITELN;
  COUNT := 0;
  FOR I := 1 TO HORIZLEN DO
  BEGIN
    WRITE(THREAD[I]:3);
    COUNT := COUNT + 1;
    IF COUNT MOD 25 = 0 THEN
    WRITELN;
  END;
WRITELN;
WRITELN;
WRITELN;
OKSET := [CHR(13)];
WRITE('                  PRESS <RETURN> TO CONTINUE');
CH := GETCHAR(OKSET);
IF CH = CHR(13) THEN
EXIT(PTHREADING);
END;


PROCEDURE TYEUP;  {Treadle tieup entry routine}
BEGIN
  CLEARSCREEN;
  WRITE('WHAT TREADLE DO YOU WANT');
  TABBYA := GETINTEGER(' FOR TABBY "A" ? --> ',6,1);
  WRITELN;
  WRITE('WHAT TREADLE DO YOU WANT');
  TABBYB := GETINTEGER(' FOR TABBY "B" ? --> ',6,1);
  WRITELN;
  WRITELN('          --> ENTER THE TREADLE TIEUP TO THE HARNESSES <--');
  WRITELN;
  WRITELN('           IF YOU WANT A TREADLE TIED TO ONLY ONE HARNESS');
  WRITELN('           THEN ENTER THE SAME HARNESS NO. THREE TIMES OR');
  WRITELN('           IF YOU WANT A TREADLE TIED TO TWO HARNESSES THEN');
  WRITELN('           REPEAT EITHER OF THE HARNESSES ONCE OR IF YOU WANT');
  WRITELN('           A TREADLE TIED TO THREE DIFFERENT HARNESSES THEN');
  WRITELN('           ENTER THE HARNESS NUMBERS....');
  WRITELN;
  FOR I := 1 TO 6 DO
  BEGIN
    WRITE('TREADLE ',I:2);
    TIE1[I] := GETINTEGER(' TO ---> ',4,1);
    TIE2[I] := GETINTEGER('          AND ---> ',4,1);
    TIE3[I] := GETINTEGER('          AND ---> ',4,1);
    WRITELN;
  END;
WRITELN;
WRITELN('YOUR "A" TABBY IS TREADLE  ',TABBYA);
WRITELN('YOUR "B" TABBY IS TREADLE  ',TABBYB);
WRITELN;
WRITELN('YOUR TIEUP IS -------->');
WRITELN;
FOR I := 1 TO 6 DO
BEGIN
  WRITE('TREADLE',I:2, ' TO HARNESS NUMBERS',TIE1[I]:2,' -',TIE2[I]:2);
  WRITELN(' -',TIE3[I]:2);
END;
WRITELN;
WRITELN;
OKSET := [CHR(13)];
WRITE('                   PRESS <RETURN> TO CONTINUE');
CH := GETCHAR(OKSET);
IF CH = CHR(13) THEN
EXIT(TYEUP);
END;




PROCEDURE TREADLING;  {Color and weave treadling sequence entry routine}
VAR COUNT, RPTSEQ, RPTFAC, I, J, K : INTEGER;
    TEMP : ARRAY[1..80] OF INTEGER;
    TEMPC : ARRAY[1..80] OF CHAR;
    OKSET : SETOFCHAR;
    
BEGIN
  CLEARSCREEN;
  RPTSEQ := GETINTEGER('HOW MANY TREADLINGS IN A REPEAT ?--->',80,1);
  RPTFAC := MAXSIZE DIV RPTSEQ;
  VERTLEN := RPTSEQ * RPTFAC;
  WRITELN;
  WRITELN;
  WRITELN;
  WRITELN('                       ENTER YOUR TREADLEING REPEAT SEQUENCE');
  WRITELN('                              FOR ',RPTSEQ:3,' TREADLINGS AND');
  WRITELN('                                   4 HARNESSES');
  WRITELN;
  FOR I := 1 TO RPTSEQ DO
  BEGIN
    WRITE('FOR WARP THREAD ',I:2);
    TEMP[I] := GETINTEGER(' TREADLE NO.--->  ',6,1);
  END;
  J := 1;
  FOR I := 1 TO RPTFAC DO
    BEGIN
      FOR K := 1 TO RPTSEQ DO
      BEGIN
        TREADL[J] := TEMP[K];
        J := J + 1
      END;
    END;
  
  WRITELN('TREDLING SEQUENCE IS------>');
  WRITELN;
  COUNT := 0;
  FOR I := 1 TO VERTLEN DO
  BEGIN
    WRITE(TREADL[I]:3);
    COUNT := COUNT + 1;
    IF COUNT MOD 25 = 0 THEN
    WRITELN;
  END;
  WRITELN;
  WRITELN;
  WRITELN;
  WRITELN;
  OKSET := [CHR(13)];
  WRITE('                 PRESS <RETURN> TO CONTINUE');
  CH := GETCHAR(OKSET);
  IF CH = CHR(13) THEN
  CLEARSCREEN;
  OKSET := ['D','d','L','l'];
  WRITELN;
  WRITELN;
  WRITELN('ENTER YOUR WEFT COLOR SEQUENCE EITHER "D" OR "L"');
  WRITELN('FOR EACH PICK FOR ',RPTSEQ:3,' PICKS');
  WRITELN;
  FOR I := 1 TO RPTSEQ DO
  BEGIN
    WRITE('NO. ',I:2,' THREAD COLOR --> ');
    TEMPC[I] := GETCHAR(OKSET);
    WRITELN;
  END;
  WRITELN;
  WRITELN;
  J := 1;
  FOR I := 1 TO RPTFAC DO
    BEGIN
      FOR K := 1 TO RPTSEQ DO
      BEGIN
        COLOR2[J] := TEMPC[K];
        J := J + 1
      END;
  END;
  WRITELN;
  WRITELN;
  WRITELN('PICK COLOR SEQUENCE IS --->');
  WRITELN;
  COUNT := 0;
  FOR I := 1 TO VERTLEN DO
  BEGIN
    WRITE(COLOR2[I]:3);
    COUNT := COUNT + 1;
    IF COUNT MOD 25 = 0 THEN
    WRITELN;
  END;
  WRITELN;
  WRITELN;
  WRITELN;
  OKSET := [CHR(13)];
  WRITE('                  PRESS <RETURN> TO CONTINUE');
  CH := GETCHAR(OKSET);
  IF CH = CHR(13) THEN
  EXIT(TREADLING);
END;
      
      



PROCEDURE PTREADLING;  {Plain drawdown treadling sequence entry routine}
VAR COUNT, RPTFAC, RPTSEQ, I, J, K : INTEGER;
    TEMP : ARRAY[1..80] OF INTEGER;
    OKSET : SETOFCHAR;
BEGIN
  CLEARSCREEN;
  RPTSEQ := GETINTEGER('HOW MANY TREADLINGS IN A REPEAT ?--->',80,1);
  RPTFAC := MAXSIZE DIV RPTSEQ;
  VERTLEN := RPTFAC * RPTSEQ;
  WRITELN;
  WRITELN;
  WRITELN;
  WRITELN('                       ENTER YOUR TREADLEING REPEAT SEQUENCE');
  WRITELN('                              FOR ',RPTSEQ:3,' TREADLINGS AND');
  WRITELN('                                   4 HARNESSES');
  WRITELN;
  FOR I := 1 TO RPTSEQ DO
  BEGIN
    WRITE('FOR WARP THREAD ',I:2);
    TEMP[I] := GETINTEGER(' TREADLE NO.--->  ',6,1);
  END;
  J := 1;
  FOR I := 1 TO RPTFAC DO
    BEGIN
      FOR K := 1 TO RPTSEQ DO
      BEGIN
        TREADL[J] := TEMP[K];
        J := J + 1
      END;
    END;
  WRITELN;
  WRITELN;
  WRITELN('TREDLING SEQUENCE IS------>');
  WRITELN;
  COUNT := 0;
  FOR I := 1 TO VERTLEN DO
  BEGIN
    WRITE(TREADL[I]:3);
    COUNT := COUNT + 1;
    IF COUNT MOD 25 = 0 THEN
    WRITELN;
  END;
  WRITELN;
  WRITELN;
  WRITELN;
  OKSET := [CHR(13)];
  WRITE('            PRESS <RETURN> TO CONTINUE');
  CH := GETCHAR(OKSET);
  IF CH = CHR(13) THEN
  EXIT(PTREADLING);
END;
      
PROCEDURE COPYTHRD;
VAR COUNT, I : INTEGER;

BEGIN
  CLEARSCREEN;
  WRITELN('                     **** AS DRAWN IN ****');
  WRITELN;
  WRITELN('    THIS PROCEDURE WILL MAKE YOUR TREADLING SEQUENCE THE SAME AS');
  WRITELN('    YOUR THREADING SEQUENCE---IF YOUR TABBY TIEUP IS TO 5 OR 6');
  WRITELN('    AND YOU USE ANY TABBY TREADLING THIS PROCEDURE WILL NOT WORK');
  WRITELN;
  WRITE('      DO YOU WANT TO PROCEED ?  Y OR N :--> ');
  READ(KEYBOARD,CH);
  IF CH IN ['Y','y'] THEN
  BEGIN
    VERTLEN := HORIZLEN;
    WRITELN;
    WRITELN;
    WRITELN('    COPYING THREADING SEQUENCE TO TREADLING SEQUENCE --->');
    FOR I := 1 TO HORIZLEN DO
    BEGIN
      TREADL[I] := THREAD[I];
      WRITE('.');
    END;
    WRITELN;
    WRITELN;
    WRITELN;
    WRITELN('YOUR TREADLING SEQUENCE IS ---> ');
    WRITELN;
    COUNT := 0;
    FOR I := 1 TO HORIZLEN DO
    BEGIN
      WRITE(TREADL[I]:3);
      COUNT := COUNT + 1;
      IF COUNT MOD 25 = 0 THEN
      WRITELN;
    END;
    WRITELN;
    WRITELN;
    OKSET := [CHR(13)];
    WRITELN('                   PRESS <RETURN> TO CONTINUE');
    CH := GETCHAR(OKSET);
    IF CH = CHR(13) THEN
    EXIT(COPYTHRD);
  END ELSE
  EXIT(COPYTHRD);
END;


(*$I DRAW4A.1.TEXT *)


========================================================================================
DOCUMENT :usus Folder:VOL29:draw8a.1.text
========================================================================================

{INCLUDE FILE FOR WEAVE:DRAW8A.TEXT}



PROCEDURE SETUP;     {Reads all color and weave}
VAR COUNT : INTEGER; {setup parameters and sends to screen}
BEGIN
  CLEARSCREEN;
  WRITELN;
  WRITELN('             ----- DRAWDOWN FOR 8 HARNESS LOOMS -----');
  WRITELN('              ',REM);
  WRITELN('             SETUP IS FOR ',HORIZLEN,' WARP THREADS');
  WRITELN;
  WRITELN('             "A" TABBY IS TREADLE  ',TABBYA);
  WRITELN('             "B" TABBY IS TREADLE  ',TABBYB);
  WRITELN;
  COUNT := 0;
  WRITELN('             THREADING SEQUENCE IS --->');
  WRITELN;
  FOR I := 1 TO HORIZLEN DO
  BEGIN
    WRITE (THREAD[I]:2);
    COUNT := COUNT + 1;
    IF COUNT MOD 40 = 0 THEN
    WRITELN;
  END;
  WRITELN;
  WRITELN('             WARP COLOR SEQUENCE IS --->');
  WRITELN;
  COUNT := 0;
  FOR I := 1 TO HORIZLEN DO
  BEGIN
    WRITE(COLOR1[I]:2);
    COUNT := COUNT + 1;
    IF COUNT MOD 40 = 0 THEN
    WRITELN;
  END;
  WRITELN;
  WRITELN;
  OKSET := [CHR(13)];
  WRITE('               PRESS <RETURN> TO CONTINUE');
  CH := GETCHAR(OKSET);
  IF CH = CHR(13) THEN
  CLEARSCREEN;
  WRITELN;
  WRITELN('             YOUR TREADLE TIEUP IS--->');
  WRITELN;
  FOR I := 1 TO 10 DO
  BEGIN
    WRITE('TREADLE ',I:2,' TO HARNESS NUMBERS',TIE1[I]:2,' -',TIE2[I]:2);
    WRITE(' -',TIE3[I]:2,' -',TIE4[I]:2,' -',TIE5[I]:2,' -');
    WRITELN(TIE6[I]:2);
  END;
  WRITELN;
  COUNT := 0;
  WRITELN('            TREADLING SEQUENCE IS---> ');
  WRITELN;
  FOR I := 1 TO VERTLEN DO
  BEGIN
    WRITE(TREADL[I]:2);
    COUNT := COUNT + 1;
    IF COUNT MOD 40 = 0 THEN
    WRITELN;
  END;
  WRITELN;
  WRITELN;
  WRITELN('              WEFT COLOR SEQUENCE IS --->');
  WRITELN;
  COUNT := 0;
  FOR I := 1 TO VERTLEN DO
  BEGIN
    WRITE(COLOR2[I]:2);
    COUNT := COUNT + 1;
    IF COUNT MOD 40 = 0 THEN
    WRITELN;
  END;
  WRITELN;
  WRITELN;
  WRITELN;
  OKSET := [CHR(13)];
  WRITE('            PRESS <RETURN> TO CONTINUE');
  CH := GETCHAR(OKSET);
  IF CH = CHR(13) THEN
  EXIT(SETUP)
END;

PROCEDURE PSETUP;     {Reads all plain drawdown setup}
VAR COUNT : INTEGER;  {parameters and sends to screen}
BEGIN
  CLEARSCREEN;
  WRITELN;
  WRITELN('             ----- DRAWDOWN FOR 8 HARNESS LOOMS -----');
  WRITELN('              ',REM);
  WRITELN('             SETUP IS FOR ',HORIZLEN,' WARP THREADS');
  WRITELN;
  WRITELN('             "A" TABBY IS TREADEL  ',TABBYA);
  WRITELN('             "B" TABBY IS TREADEL  ',TABBYB);
  WRITELN;
  COUNT := 0;
  WRITELN('             THREADING SEQUENCE IS --->');
  FOR I := 1 TO HORIZLEN DO
  BEGIN
    WRITE (THREAD[I]:2);
    COUNT := COUNT + 1;
    IF COUNT MOD 40 = 0 THEN
    WRITELN;
  END;
  WRITELN;
  WRITELN;
  WRITELN('             TREADLE TIEUP IS--->');
  FOR I := 1 TO 10 DO
  BEGIN
    WRITE('TREADLE ',I:2,' TO HARNESS NUMBERS',TIE1[I]:2,' -',TIE2[I]:2);
    WRITE(' -',TIE3[I]:2,' -',TIE4[I]:2,' -',TIE5[I]:2,' -');
    WRITELN(TIE6[I]:2);
  END;
  WRITELN;
  COUNT := 0;
  WRITELN('            TREADLING SEQUENCE IS---> ');
  FOR I := 1 TO VERTLEN DO
  BEGIN
    WRITE(TREADL[I]:2);
    COUNT := COUNT + 1;
    IF COUNT MOD 40 = 0 THEN
    WRITELN;
  END;
  WRITELN;
  WRITELN;
  OKSET := [CHR(13)];
  WRITE('            PRESS <RETURN> TO CONTINUE');
  CH := GETCHAR(OKSET);
  IF CH = CHR(13) THEN
  EXIT(PSETUP)
END;

PROCEDURE SETUP1;     {Reads all color and weave setup}
VAR COUNT : INTEGER;  {parameters and outputs to printer}
BEGIN
  COUNT := 0;
  WRITELN(FT,'DRAWDOWN FOR 8 HARNESS LOOMS (color and weave)');
  WRITELN(FT,REM);
  WRITELN(FT,'SETUP IS FOR ',HORIZLEN,' THREADS.');
  WRITELN(FT);
  WRITELN(FT,'THREADING SEQUENCE IS --->');
  FOR I := 1 TO HORIZLEN DO
  BEGIN
    WRITE (FT,THREAD[I]:2);
    COUNT := COUNT + 1;
    IF COUNT MOD 30 = 0 THEN
    WRITELN(FT);
  END;
  WRITELN(FT);
  WRITELN(FT);
  WRITELN(FT,'WARP COLOR SEQUENCE IS --->');
  COUNT := 0;
  FOR I := 1 TO HORIZLEN DO
  BEGIN
    WRITE(FT,COLOR1[I]:2);
    COUNT := COUNT + 1;
    IF COUNT MOD 30 = 0 THEN
    WRITELN(FT);
  END;
  WRITELN(FT);
  WRITELN(FT);
  WRITELN(FT,'"A" TABBY IS TREADLE ',TABBYA:2);
  WRITELN(FT,'"B" TABBY IS TREADLE ',TABBYB:2);
  WRITELN(FT);
  WRITELN(FT,'TREADLE TIEUP IS--->');
  FOR I := 1 TO 10 DO
  BEGIN
    WRITE(FT,'TREADLE',I:2,' TO HARNESS NUMBERS',TIE1[I]:2,' -',TIE2[I]:2);
    WRITE(FT,' -',TIE3[I]:2,' -',TIE4[I]:2,' -',TIE5[I]:2,' -');
    WRITELN(FT,TIE6[I]:2);
  END;
  WRITELN(FT);
  COUNT := 0;
  WRITELN(FT,'TREADLING SEQUENCE IS --->');
  FOR I := 1 TO VERTLEN DO
  BEGIN
    WRITE(FT,TREADL[I]:2);
    COUNT := COUNT + 1;
    IF COUNT MOD 30 = 0 THEN
    WRITELN(FT);
  END;
  WRITELN(FT);
  WRITELN(FT);
  WRITELN(FT,'WEFT COLOR SEQUENCE IS --->');
  COUNT := 0;
  FOR I := 1 TO VERTLEN DO
  BEGIN
    WRITE(FT,COLOR2[I]:2);
    COUNT := COUNT + 1;
    IF COUNT MOD 30 = 0 THEN
    WRITELN(FT);
  END;
  WRITELN(FT);
  WRITELN(FT);
END;


PROCEDURE PSETUP1;   {Reads all plain drawdown setup}
VAR COUNT : INTEGER; {parameters and outputs to printer}
BEGIN
  COUNT := 0;
  WRITELN(FT);
  WRITELN(FT,'DRAWDOWN FOR 8 HARNESS LOOMS');
  WRITELN(FT,REM);
  WRITELN(FT,'SETUP IS FOR ',HORIZLEN,' THREADS.');
  WRITELN(FT);
  WRITELN(FT,'THREADING SEQUENCE IS --->');
  FOR I := 1 TO HORIZLEN DO
  BEGIN
    WRITE (FT,THREAD[I]:2);
    COUNT := COUNT + 1;
    IF COUNT MOD 30 = 0 THEN
    WRITELN(FT);
  END;
  WRITELN(FT);
  WRITELN(FT);
  WRITELN(FT,'"A" TABBY IS TREADLE ',TABBYA:2);
  WRITELN(FT,'"B" TABBY IS TREADLE ',TABBYB:2);
  WRITELN(FT);
  WRITELN(FT,'TREADLE TIEUP IS--->');
  FOR I := 1 TO 10 DO
  BEGIN
    WRITE(FT,'TREADLE',I:2,' TO HARNESS NUMBERS',TIE1[I]:2,' -',TIE2[I]:2);
    WRITE(FT,' -',TIE3[I]:2,' -',TIE4[I]:2,' -',TIE5[I]:2,' -');
    WRITELN(FT,TIE6[I]:2);
  END;
  WRITELN(FT);
  COUNT := 0;
  WRITELN(FT,'TREADLING SEQUENCE IS --->');
  FOR I := 1 TO VERTLEN DO
  BEGIN
    WRITE(FT,TREADL[I]:2);
    COUNT := COUNT + 1;
    IF COUNT MOD 30 = 0 THEN
    WRITELN(FT);
  END;
  WRITELN(FT);
  WRITELN(FT);
END;


PROCEDURE CRTOUT;  {Outputs color and weave pattern to screen}
BEGIN
  CLEARSCREEN;
  SETUP;
  WRITELN;
  WRITELN;
  WRITELN;
  BEGIN
    FOR I := 1 TO VERTLEN DO
    BEGIN
      FOR J := 1 TO HORIZLEN DO
      BEGIN
        K := TREADL[I];
        IF ((THREAD[J] = TIE1[K]) OR (THREAD[J] = TIE2[K]) OR 
           (THREAD[J] = TIE3[K]) OR (THREAD[J] = TIE4[K]) OR
           (THREAD[J] = TIE5[K]) OR (THREAD[J] = TIE6[K]))
            AND (COLOR1[J] IN ['D','d'])
           THEN WRITE(SHOWARPD)
        ELSE IF ((THREAD[J] = TIE1[K]) OR (THREAD[J] = TIE2[K]) OR
                 (THREAD[J] = TIE3[K]) OR (THREAD[J] = TIE4[K]) OR
                 (THREAD[J] = TIE5[K]) OR (THREAD[J] = TIE6[K])) 
                AND (COLOR1[J] IN ['L','l'])
           THEN WRITE(SHOWARPL)
        ELSE IF ((THREAD[J] <> TIE1[K]) OR (THREAD[J] <> TIE2[K]) OR
                 (THREAD[J] <> TIE3[K]) OR (THREAD[J] <> TIE4[K]) OR
                 (THREAD[J] <> TIE5[K]) OR (THREAD[J] <> TIE6[K])) 
                 AND (COLOR2[I] IN ['D','d'])
           THEN WRITE(SHOWARPD)
        ELSE IF ((THREAD[J] <> TIE1[K]) OR (THREAD[J] <> TIE2[K]) OR
                 (THREAD[J] <> TIE3[K]) OR (THREAD[J] <> TIE4[K]) OR
                 (THREAD[J] <> TIE5[K]) OR (THREAD[J] <> TIE6[K])) 
                 AND (COLOR2[I] IN ['L','l'])
           THEN WRITE(SHOWARPL)
      END;
    WRITELN;
    END;
  END;
  WRITELN;
  WRITELN;
  OKSET := [CHR(13)];
  WRITE('              PRESS <RETURN> TO CONTINUE');
  CH := GETCHAR(OKSET);
  IF CH = CHR(13) THEN
  EXIT(CRTOUT)
END;
  
  
PROCEDURE PCRTOUT;  {Outputs plain drawdown pattern to screen}
BEGIN
  CLEARSCREEN;
  PSETUP;
  WRITELN;
  WRITELN;
  BEGIN
    BEGIN
      FOR I := 1 TO VERTLEN DO
      BEGIN
        FOR J := 1 TO HORIZLEN DO
        BEGIN
          K := TREADL[I];
          IF (THREAD[J] = TIE1[K]) OR (THREAD[J] = TIE2[K]) OR
             (THREAD[J] = TIE3[K]) OR (THREAD[J] = TIE4[K]) OR
             (THREAD[J] = TIE5[K]) OR (THREAD[J] = TIE6[K]) THEN
          WRITE(SHOWARPD) ELSE
          WRITE(SHOWARPL);
        END;
      WRITELN;
      END;
    END;
    WRITELN;
    WRITELN;
    OKSET := [CHR(13)];
    WRITE('              PRESS <RETURN> TO CONTINUE');
    CH := GETCHAR(OKSET);
    IF CH = CHR(13) THEN
    EXIT(PCRTOUT)
  END;
END;


PROCEDURE HARDCOPY;  {Outputs color and weave pattern to printer}

BEGIN
  CLEARSCREEN;
  WRITELN;
  WRITELN;
  WRITELN;
  WRITELN;
  WRITELN('                    SETUP FOR  PRINTER-->');
  WRITELN('                    10 Characters per INCH');
  WRITELN('                     8 Lines per INCH');
  WRITELN;
  WRITELN('        ***  NOTE---USE ASCII 96 PRINT WHEEL ON QUME ***');
  WRITELN;
  WRITELN;
  OKSET := [CHR(13)];
  WRITELN('                   PRESS <RETURN> TO CONTINUE');
  CH := GETCHAR(OKSET);
  IF CH = CHR(13) THEN
  BEGIN
    REWRITE(FT,'PRINTER:');
    SETUP1;
    WRITELN(FT);
    BEGIN
      FOR I := 1 TO VERTLEN DO
      BEGIN
        FOR J := 1 TO HORIZLEN DO
        BEGIN
          K := TREADL[I];
          IF ((THREAD[J] = TIE1[K]) OR (THREAD[J] = TIE2[K]) OR 
              (THREAD[J] = TIE3[K]) OR (THREAD[J] = TIE4[K]) OR
              (THREAD[J] = TIE5[K]) OR (THREAD[J] = TIE6[K]))
              AND (COLOR1[J] IN ['D','d'])
             THEN WRITE(FT,SHOWARPD)
          ELSE IF ((THREAD[J] = TIE1[K]) OR (THREAD[J] = TIE2[K]) OR
                   (THREAD[J] = TIE3[K]) OR (THREAD[J] = TIE4[K]) OR
                   (THREAD[J] = TIE5[K]) OR (THREAD[J] = TIE6[K])) 
                   AND (COLOR1[J] IN ['L','l'])
             THEN WRITE(FT,SHOWARPL)
          ELSE IF ((THREAD[J] <> TIE1[K]) OR (THREAD[J] <> TIE2[K]) OR
                   (THREAD[J] <> TIE3[K]) OR (THREAD[J] <> TIE4[K]) OR
                   (THREAD[J] <> TIE5[K]) OR (THREAD[J] <> TIE6[K])) 
                   AND (COLOR2[I] IN ['D','d'])
             THEN WRITE(FT,SHOWARPD)
          ELSE IF ((THREAD[J] <> TIE1[K]) OR (THREAD[J] <> TIE2[K]) OR
                   (THREAD[J] <> TIE3[K]) OR (THREAD[J] <> TIE4[K]) OR
                   (THREAD[J] <> TIE5[K]) OR (THREAD[J] <> TIE6[K])) 
                   AND (COLOR2[I] IN ['L','l'])
             THEN WRITE(FT,SHOWARPL)
        END;
      WRITELN(FT);
      END;
    END;
  END;
  WRITELN(FT,CHR(12));
  CLOSE(FT);
END;


PROCEDURE PHARDCOPY;  {Outputs plain drawdown pattern to printer}

BEGIN
  CLEARSCREEN;
  WRITELN;
  WRITELN;
  WRITELN;
  WRITELN;
  WRITELN('                    SETUP FOR  PRINTER-->');
  WRITELN('                    10 Characters per INCH');
  WRITELN('                     8 Lines per INCH');
  WRITELN;
  WRITELN('        ***  NOTE---USE ASCII 96 PRINT WHEEL ON QUME ***');
  WRITELN;
  WRITELN;
  OKSET := [CHR(13)];
  WRITELN('                   PRESS <RETURN> TO CONTINUE');
  CH := GETCHAR(OKSET);
  IF CH = CHR(13) THEN
  BEGIN
    REWRITE(FT,'PRINTER:');
    WRITELN(FT);
    WRITELN(FT);
    PSETUP1;
    WRITELN(FT);
    WRITELN(FT);
    BEGIN
      FOR I := 1 TO VERTLEN DO
      BEGIN
        FOR J := 1 TO HORIZLEN DO
        BEGIN
          K := TREADL[I];
          IF (THREAD[J] = TIE1[K]) OR (THREAD[J] = TIE2[K]) OR
             (THREAD[J] = TIE3[K]) OR (THREAD[J] = TIE4[K]) OR
             (THREAD[J] = TIE5[K]) OR (THREAD[J] = TIE6[K]) THEN
          WRITE(FT,SHOWARPD)
          ELSE WRITE(FT,SHOWARPL);
        END;
        WRITELN(FT);
      END;
    END;
  END;
  WRITELN(FT,CHR(12));
  CLOSE(FT);
END;


PROCEDURE GRAFOUT;  {Outputs color and weave pattern}
                    {to IDS-460 graphics printer}
BEGIN
  CLEARSCREEN;
  WRITELN;
  WRITELN;
  WRITELN;
  WRITELN('                    SETUP FOR IDS-460 PRINTER-->');
  WRITELN('                    10 Characters per INCH');
  WRITELN('                     8 Lines per INCH');
  WRITELN('             ENABLE EXPANDED FUNCTION-- SWITCH NO. 7  ON ..');
  WRITELN;
  WRITELN;
  OKSET := [CHR(13)];
  WRITELN('                     PRESS <RETURN> TO CONTINUE');
  CH := GETCHAR(OKSET);
  IF CH = CHR(13) THEN
  BEGIN
    REWRITE(FT,'PRINTER:');
    SETUP1;
    WRITELN(FT);
    WRITELN(FT);
    WRITE(FT,CHR(3)); {Puts printer in graphics mode}
    BEGIN
      FOR I := 1 TO VERTLEN DO
      BEGIN
        FOR J := 1 TO HORIZLEN DO
        BEGIN
          K := TREADL[I];
          IF ((THREAD[J] = TIE1[K]) OR (THREAD[J] = TIE2[K]) OR 
              (THREAD[J] = TIE3[K]) OR (THREAD[J] = TIE4[K]) OR
              (THREAD[J] = TIE5[K]) OR (THREAD[J] = TIE6[K]))
              AND (COLOR1[J] IN ['D','d'])
              THEN DPIXEL
          ELSE IF ((THREAD[J] = TIE1[K]) OR (THREAD[J] = TIE2[K]) OR
                   (THREAD[J] = TIE3[K]) OR (THREAD[J] = TIE4[K]) OR
                   (THREAD[J] = TIE5[K]) OR (THREAD[J] = TIE6[K])) 
                   AND (COLOR1[J] IN ['L','l'])
                   THEN LPIXEL
          ELSE IF ((THREAD[J] <> TIE1[K]) OR (THREAD[J] <> TIE2[K]) OR
                   (THREAD[J] <> TIE3[K]) OR (THREAD[J] <> TIE4[K]) OR
                   (THREAD[J] <> TIE5[K]) OR (THREAD[J] <> TIE6[K])) 
                   AND (COLOR2[I] IN ['D','d'])
                   THEN DPIXEL
          ELSE IF ((THREAD[J] <> TIE1[K]) OR (THREAD[J] <> TIE2[K]) OR
                   (THREAD[J] <> TIE3[K]) OR (THREAD[J] <> TIE4[K]) OR
                   (THREAD[J] <> TIE5[K]) OR (THREAD[J] <> TIE6[K])) 
                   AND (COLOR2[I] IN ['L','l'])
                   THEN LPIXEL
        END;
      WRITE(FT,CHR(3),CHR(14)); {Graphics CR & LF}
      END;
    END;
  END;
  WRITELN(FT,CHR(3),CHR(2)); {Leave graphics mode}
  WRITELN(FT,CHR(12)); {FF}
  CLOSE(FT);
END;


PROCEDURE PGRAFOUT;  {Outputs plain drawdown pattern}
                     {to IDS-460 graphics printer}
BEGIN
  CLEARSCREEN;
  WRITELN;
  WRITELN;
  WRITELN;
  WRITELN('                    SETUP FOR IDS-460 PRINTER-->');
  WRITELN('                    10 Characters per INCH');
  WRITELN('                     8 Lines per INCH');
  WRITELN('             ENABLE EXPANDED FUNCTION-- SWITCH NO. 7  ON ..');
  WRITELN;
  WRITELN;
  OKSET := [CHR(13)];
  WRITELN('                     PRESS <RETURN> TO CONTINUE');
  CH := GETCHAR(OKSET);
  IF CH = CHR(13) THEN
  BEGIN
    REWRITE(FT,'PRINTER:');
    WRITELN(FT);
    WRITELN(FT);
    PSETUP1;
    WRITELN(FT);
    WRITELN(FT);
    WRITE(FT,CHR(3)); {Puts printer into graphics mode}
    BEGIN
      FOR I := 1 TO VERTLEN DO
      BEGIN
        FOR J := 1 TO HORIZLEN DO
        BEGIN
          K := TREADL[I];
          IF (THREAD[J] = TIE1[K]) OR (THREAD[J] = TIE2[K]) OR
             (THREAD[J] = TIE3[K]) OR (THREAD[J] = TIE4[K]) OR
             (THREAD[J] = TIE5[K]) OR (THREAD[J] = TIE6[K])
             THEN DPIXEL
          ELSE
          LPIXEL
        END;
        WRITE(FT,CHR(3),CHR(14));  {Graphics CR & LF}
      END;
    END;
  END;
  WRITE(FT,CHR(3),CHR(2)); {Leave graphics mode}
  WRITELN(FT,CHR(12)); {FF}
  CLOSE(FT);
END;


PROCEDURE PRINT;  {Secondary menu for color and weave output selection}
VAR CH : CHAR;
    OKSET : SETOFCHAR;
BEGIN
  OKSET := ['S','s','P','p','G','g','Q','q'];
  CLEARSCREEN;
  WRITELN('                 Do you want output to go to the------>');
  WRITELN;
  WRITELN;
  WRITE('    --->  S)creen,  P)rinter normal,  G)raphics IDS-460,  Q)UIT ? ');
  CH := GETCHAR(OKSET);
  CASE CH OF
    'S','s'  : CRTOUT;
    'P','p'  : HARDCOPY;
    'G','g'  : GRAFOUT;
    'Q','q'  : BEGIN
                 CLEARSCREEN;
                 EXIT(PRINT);
               END;
  END;
END;


PROCEDURE PPRINT;  {Secondary menu for normal drawdown output selection}
VAR CH : CHAR;
    OKSET : SETOFCHAR;
BEGIN
  OKSET := ['S','s','P','p','G','g','Q','q'];
  CLEARSCREEN;
  WRITELN('                 Do you want output to go to the------>');
  WRITELN;
  WRITELN;
  WRITE('    --->  S)creen,  P)rinter normal,  G)raphics IDS-460,  Q)UIT ? ');
  CH := GETCHAR(OKSET);
  CASE CH OF
    'S','s'  : PCRTOUT;
    'P','p'  : PHARDCOPY;
    'G','g'  : PGRAFOUT;
    'Q','q'  : BEGIN
                 CLEARSCREEN;
                 EXIT(PPRINT);
               END;
  END;
END;




PROCEDURE TITLE;  {Title block for program}
BEGIN
  OKSET := [CHR(13)];
  CLEARSCREEN;
  GOTOXY(0,2);
  WRITELN('                      ***** PROGRAM DRAW8C *****');
  GOTOXY(0,6);
  WRITELN('        This program is for eight harness looms and the output');
  WRITELN;
  WRITELN('        is a Drawdown to a printer or the terminal.  The program');
  WRITELN;
  WRITELN('        was inspired by the book "COLOR AND WEAVE" by Margaret and');
  WRITELN;
  WRITELN('        Thomas Windeknecht.  It is written in UCSD Pascal version');
  WRITELN;
  WRITELN('        IV.1 for the Sage II computer and output on a standard');
  WRITELN;
  WRITELN('        printer or graphics output on the IDS-460 printer.');
  WRITELN;
  WRITELN('                  by GEORGE. H. DODGE    December 1983');
  WRITELN;
  WRITELN;
  WRITE('                        PRESS <RETURN> TO CONTINUE');
  CH := GETCHAR(OKSET);
  IF CH = CHR(13) THEN
  EXIT(TITLE);
END;

 
 
 

PROCEDURE CMENU;  {Color and weave menu}

VAR OKSET : SETOFCHAR;

BEGIN
  OKSET := ['A','a','B','b','C','c','D','d','P','p','Q','q'];
  REPEAT
    CLEARSCREEN;
    WRITE('> Draw 8-c: A)Threading  B)Tieup  C)Treadling  ');
    WRITE('D)DrawnIn  P)rint  Q)uit--> ');
    CH := GETCHAR(OKSET);
    CASE CH OF
      'A','a' : THREADING;
      'B','b' : TYEUP;
      'C','c' : TREADLING;
      'D','d' : COPYTHRD;
      'P','p' : PRINT;
      'Q','q' : BEGIN
                  CLEARSCREEN;
                  MENU;
                END;
    END;
  UNTIL FALSE
 END;
 
 
PROCEDURE PMENU;  {Plain drawdown menu}

VAR OKSET : SETOFCHAR;

BEGIN
  OKSET := ['A','a','B','b','C','c','D','d','P','p','Q','q'];
  REPEAT
    CLEARSCREEN;
    WRITE('> Draw 8: A)Threading  B)Tieup  C)Treadling  ');
    WRITE('D)DrawnIn  P)rint  Q)uit --> ');
    CH := GETCHAR(OKSET);
    CASE CH OF
      'A','a' : PTHREADING;
      'B','b' : TYEUP;
      'C','c' : PTREADLING;
      'D','d' : COPYTHRD;
      'P','p' : PPRINT;
      'Q','q' : BEGIN
                  CLEARSCREEN;
                  MENU;
                END;
    END;
  UNTIL FALSE
 END;
 
 
PROCEDURE MENU;  {Main program menu}

VAR OKSET : SETOFCHAR;

BEGIN
  OKSET := ['C','c','P','p','Q','q'];
  REPEAT
    CLEARSCREEN;
    WRITE('> DrawDown 8 :    P)lain drawdown     C)olor & weave    Q)uit---> ');
    CH := GETCHAR(OKSET);
    CASE CH OF
      'P','p' : PMENU;
      'C','c' : CMENU;
      'Q','q' : BEGIN
                  CLEARSCREEN;
                  EXIT(PROGRAM);
                END;
    END;
  UNTIL FALSE
END;



BEGIN   {Main program}
  TITLE;
  MENU;
END.




========================================================================================
DOCUMENT :usus Folder:VOL29:draw8a.text
========================================================================================



PROGRAM DRAW8;

uses screenops;

CONST SHOWARPD = '#';
      SHOWARPL = ' ';

TYPE SETOFCHAR = SET OF CHAR;


VAR  THREAD : ARRAY[1..80] OF INTEGER;  {For threading info}
     TREADL : ARRAY[1..80] OF INTEGER;  {For treadling info}
     TIE1, TIE2, TIE3,
     TIE4, TIE5, TIE6 : ARRAY[1..10] OF INTEGER;  {For tieup info}
     COLOR1, COLOR2 : ARRAY[1..80] OF CHAR;  {For color info}
     I, J, K, MAXSIZE, HORIZLEN, VERTLEN, TABBYA, TABBYB  : INTEGER;
     OKSET : SETOFCHAR;
     GOOD : BOOLEAN;
     REM : STRING[40];
     CH, BS, CR, BELL : CHAR;
     FT : TEXT;
     
     
PROCEDURE MENU; FORWARD;

PROCEDURE CLEARSCREEN;
BEGIN
  sc_clr_screen;
END;

PROCEDURE DPIXEL;  {Dark pixel for IDS-460 graphics}
BEGIN
  WRITE(FT,CHR(85),CHR(42),CHR(85),CHR(42),CHR(85),CHR(42),CHR(85));
END;

PROCEDURE LPIXEL;  {Light pixel for IDS-460 graphics}
BEGIN
  WRITE(FT,CHR(0),CHR(0),CHR(0),CHR(0),CHR(0),CHR(0),CHR(0));
END;

FUNCTION GETCHAR(OKSET : SETOFCHAR) : CHAR;
VAR CH   : CHAR;
    GOOD : BOOLEAN;
    
BEGIN
  CR := CHR(13);
  BELL := CHR(7);
  REPEAT
    READ(KEYBOARD,CH);
    IF EOLN(KEYBOARD) THEN CH := CR;
    GOOD := CH IN OKSET;
    IF NOT GOOD THEN
    WRITE(BELL) ELSE
    IF CH IN [' '..CHR(125)] THEN
    WRITE(CH)
  UNTIL GOOD;
  GETCHAR := CH;
END;

  
  { Used by GETINTEGER for bomb proof numerical data entry }
  
FUNCTION GETNUM(MAXVAL,MINVAL : REAL; PTOK : BOOLEAN):REAL;

TYPE SETOFCHAR = SET OF CHAR;

VAR FIRSTCHAR, LASTCHAR    : BOOLEAN;
    NUMSET, GETSET, OKSET  : SETOFCHAR;
    NUMSTRTEMP             : STRING[10];
    S1                     : STRING[1];
    LEN, MAXLEN            : INTEGER;
    NUM                    : REAL;
    CR, BS, BELL           : CHAR;
    


FUNCTION FPNUM(FPSTR : STRING) : REAL;
VAR POWER, SIGN, I : INTEGER;
    NUM : REAL;
    
BEGIN
  IF FPSTR[1] = '-' THEN
  BEGIN
    SIGN := -1;
    DELETE(FPSTR,1,1);
  END ELSE
  SIGN := 1;
  
  POWER := POS('.',FPSTR);
  IF POWER <> 0 THEN
  BEGIN
    DELETE(FPSTR,POWER,1);
    POWER := LENGTH(FPSTR)- POWER +1;
  END;
  NUM := 0;
  FOR I := 1 TO LENGTH(FPSTR) DO
  NUM := 10 * NUM + (ORD(FPSTR[I]) - ORD('0'));
  FPNUM := SIGN * NUM/PWROFTEN(POWER);
END;

BEGIN
  CR := CHR(13); BS := CHR(8); BELL := CHR(7);
  NUMSET := ['0'..'9'];
  IF MINVAL < 0 THEN OKSET := NUMSET + ['-'] ELSE OKSET := NUMSET;
  IF PTOK THEN MAXLEN := 8 ELSE MAXLEN := 7;
  S1 := ' '; NUMSTRTEMP := '';
  
  REPEAT
    LEN := LENGTH(NUMSTRTEMP);
    FIRSTCHAR := (LEN=0);
    LASTCHAR := (LEN=MAXLEN);
    
    IF PTOK THEN OKSET := OKSET + ['.'] ELSE
    OKSET := OKSET - ['.'];
    
    IF FIRSTCHAR THEN GETSET := OKSET ELSE
    IF LASTCHAR THEN GETSET := [CR,BS] ELSE
    GETSET := OKSET + [CR,BS] - ['-'];
    
    S1[1] := GETCHAR(GETSET);
    IF S1 = '.' THEN PTOK := FALSE;
    
    IF S1[1] IN OKSET THEN
    BEGIN
      NUMSTRTEMP := CONCAT(NUMSTRTEMP,S1);
      IF S1[1] IN NUMSET THEN
      BEGIN
        NUM := FPNUM(NUMSTRTEMP);
        IF (NUM > MAXVAL) OR (NUM < MINVAL) THEN
        BEGIN
          WRITE(BELL);
          WRITE(BS,' ',BS);
          DELETE(NUMSTRTEMP,LEN+1,1);
        END;
      END;
    END ELSE
    IF S1[1] = BS THEN
    BEGIN
      IF POS('.',NUMSTRTEMP) = LEN THEN
      PTOK := TRUE;
      WRITE(BS,' ',BS);
      DELETE(NUMSTRTEMP,LEN,1);
    END;
    
  UNTIL S1[1] = CR; WRITELN;
  GETNUM := FPNUM(NUMSTRTEMP);
END;



FUNCTION GETINTEGER(PROMPT : STRING; MAXVAL, MINVAL : INTEGER) : INTEGER;
VAR POINTOK : BOOLEAN;  {For bomb proof entry of numerical data}
    EOL : STRING[2];
BEGIN
  WRITE(PROMPT,CHR(27),CHR(116));  {Erase to end of line for TV-925 Term.}
  POINTOK := FALSE;
  GETINTEGER := TRUNC(GETNUM(MAXVAL,MINVAL,FALSE));
END;





PROCEDURE THREADING;  {Color and weave threading entry routine}

VAR COUNT, RPTFAC, RPTSEQ, I, J, K : INTEGER;
    TEMP : ARRAY [1..80] OF INTEGER;
    TEMPC : ARRAY [1..80] OF CHAR;
    OKSET : SETOFCHAR;

BEGIN
  CLEARSCREEN;
  REM := '';
  WRITELN;
  WRITELN('ENTER ANY COMMENTS YOU MAY HAVE UP TO 40 CHARACTERS.  IF YOU');
  WRITELN('DONT''T WANT ANY COMMENTS PRESS <RETURN>');
  WRITELN('                  >---------------------------------------<');
  WRITE('ENTER COMMENTS --> ');
  READLN(REM);
  WRITELN;
  WRITELN('ENTER THE MAXIMUM NUMBER OF WARP THREADS YOU WANT IN YOUR DRAWDOWN');
  WRITELN('THE MINIMUM SHOULD BE ONE REPEAT LENGTH AND THE MAXIMUM IS 80');
  WRITELN;
  MAXSIZE := GETINTEGER('HOW MANY WARP THREADS ?---> ',80,1);
  WRITELN;
  RPTSEQ := GETINTEGER('HOW MANY THREADS IN A REPEAT ?--->',80,1);
  RPTFAC := MAXSIZE DIV RPTSEQ;
  HORIZLEN := RPTSEQ * RPTFAC;
  WRITELN;
  WRITELN;
  WRITELN;
  WRITELN('                       ENTER YOUR THREADING REPEAT SEQUENCE');
  WRITELN('                              FOR',RPTSEQ:2,' THREADS AND');
  WRITELN('                                   8 HARNESSES');
  WRITELN;
  FOR I := 1 TO RPTSEQ DO
  BEGIN
    WRITE('NO.',I:2,' THREAD ');
    TEMP[I] := GETINTEGER('TO HARNESS NO.--->  ',8,1);
  END;
  J := 1;
  FOR I := 1 TO RPTFAC DO
  BEGIN
    FOR K := 1 TO RPTSEQ DO
    BEGIN
      THREAD[J] := TEMP[K];
      J := J + 1
    END;
  END;
  CLEARSCREEN;
  WRITELN;
  WRITELN('THREADING SEQUENCE IS----->');
  WRITELN;
  COUNT := 0;
  FOR I := 1 TO HORIZLEN DO
  BEGIN
    WRITE(THREAD[I]:2);
    COUNT := COUNT + 1;
    IF COUNT MOD 40 = 0 THEN
    WRITELN;
  END;
  WRITELN;
  WRITELN;
  OKSET := [CHR(13)];
  WRITE('                  PRESS <RETURN> TO CONTINUE');
  CH := GETCHAR(OKSET);
  IF CH = CHR(13) THEN
  CLEARSCREEN;
  WRITELN;
  WRITELN;
  WRITELN('ENTER YOUR WARP THREAD COLOR REPEAT SEQUENCE WITH EITHER ');
  WRITELN('"D" OR "L" FOR EACH THREAD FOR ',RPTSEQ,' THREADS');
  WRITELN;
  OKSET := ['D','d','L','l'];
  FOR I := 1 TO RPTSEQ DO
  BEGIN
    WRITE('NO. ',I:2,' THREAD COLOR --> ');
    TEMPC[I] := GETCHAR(OKSET);
    WRITELN;
  END;
  WRITELN;
  WRITELN;
  J := 1;
  FOR I := 1 TO RPTFAC DO
  BEGIN
    FOR K := 1 TO RPTSEQ DO
    BEGIN
      COLOR1[J] := TEMPC[K];
      J := J + 1
    END;
  END;
  CLEARSCREEN;
  WRITELN('THREAD COLOR SEQUENCE IS --->');
  WRITELN;
  COUNT := 0;
  FOR I := 1 TO HORIZLEN DO
  BEGIN
    WRITE(COLOR1[I]:2);
    COUNT := COUNT + 1;
    IF COUNT MOD 40 = 0 THEN
    WRITELN;
  END;
  WRITELN;
  WRITELN;
  WRITELN;
  WRITELN;
  OKSET := [CHR(13)];
  WRITE('                  PRESS <RETURN> TO CONTINUE');
  CH := GETCHAR(OKSET);
  IF CH = CHR(13) THEN
  EXIT(THREADING);
END;






PROCEDURE PTHREADING;  {Plain drawdown threading entry routine}
VAR COUNT, RPTSEQ, RPTFAC : INTEGER;
    TEMP : ARRAY[1..80] OF INTEGER;
    OKSET : SETOFCHAR;
    
BEGIN
  CLEARSCREEN;
  REM := '';
  WRITELN('ENTER ANY COMMENTS YOU MAY HAVE UP TO 40 CHARACTERS.  IF YOU');
  WRITELN('DON''T WANT ANY COMMENTS PRESS <RETURN>');
  WRITELN;
  WRITELN('                  >---------------------------------------<');
  WRITE('ENTER COMMENTS --> ');
  READLN(REM);
  WRITELN;
  WRITELN('ENTER THE MAXIMUM NUMBER OF THREADS YOU WANT IN YOUR DRAWDOWN');
  WRITELN('THE MINIMUM SHOULD BE ONE REPEAT LENGTH AND THE MAXIMUM IS 80');
  WRITELN;
  MAXSIZE := GETINTEGER('HOW MANY WARP THREADS ?--> ',80,1);
  WRITELN;
  RPTSEQ := GETINTEGER('HOW MANY THREADS IN A REPEAT ?--->',80,1);
  RPTFAC := MAXSIZE DIV RPTSEQ;
  HORIZLEN := RPTSEQ * RPTFAC;
  WRITELN;
  WRITELN;
  WRITELN;
  WRITELN('                       ENTER YOUR THREADING REPEAT SEQUENCE');
  WRITELN('                              FOR ',RPTSEQ:3,' THREADS AND');
  WRITELN('                                   8 HARNESSES');
  WRITELN;
  FOR I := 1 TO RPTSEQ DO
  BEGIN
    WRITE('NO. ',I:2,' THREAD ');
    TEMP[I] := GETINTEGER(' TO HARNESS NO.--->  ',8,1);
  END;
  J := 1;
  FOR I := 1 TO RPTFAC DO
  BEGIN
    FOR K := 1 TO RPTSEQ DO
    BEGIN
      THREAD[J] := TEMP[K];
      J := J + 1
    END;
  END;
  CLEARSCREEN;
  WRITELN;
  WRITELN('THREADING SEQUENCE IS----->');
  WRITELN;
  COUNT := 0;
  FOR I := 1 TO HORIZLEN DO
  BEGIN
    WRITE(THREAD[I]:2);
    COUNT := COUNT + 1;
    IF COUNT MOD 40 = 0 THEN
    WRITELN;
  END;
  WRITELN;
  WRITELN;
  OKSET := [CHR(13)];
  WRITE('                  PRESS <RETURN> TO CONTINUE');
  CH := GETCHAR(OKSET);
  IF CH = CHR(13) THEN
  EXIT(PTHREADING);
END;


PROCEDURE TYEUP;  {Treadle tieup entry routine}
BEGIN
  CLEARSCREEN;
  WRITE('WHAT TREADLE DO YOU WANT');
  TABBYA := GETINTEGER(' FOR TABBY "A" ? --> ',10,1);
  WRITELN;
  WRITE('WHAT TREADLE DO YOU WANT');
  TABBYB := GETINTEGER(' FOR TABBY "B" ? --> ',10,1);
  WRITELN;
  WRITELN('          --> ENTER THE TREADLE TIEUP TO THE HARNESSES <--');
  WRITELN;
  WRITELN('           IF YOU WANT A TREADLE TIED TO ONLY ONE HARNESS');
  WRITELN('           THEN ENTER THE SAME HARNESS NO. SIX TIMES OR');
  WRITELN('           IF YOU WANT A TREADLE TIED TO TWO HARNESSES THEN');
  WRITELN('           REPEAT EITHER OF THE HARNESSES OR IF YOU WANT');
  WRITELN('           A TREADLE TIED TO THREE DIFFERENT HARNESSES THEN');
  WRITELN('           ENTER THE HARNESS NUMBERS....etc.');
  WRITELN;
  FOR I := 1 TO 10 DO
  BEGIN
    WRITE('TREADLE ',I:2);
    TIE1[I] := GETINTEGER(' TO ---> ',8,1);
    TIE2[I] := GETINTEGER('          AND ---> ',8,1);
    TIE3[I] := GETINTEGER('          AND ---> ',8,1);
    TIE4[I] := GETINTEGER('          AND ---> ',8,1);
    TIE5[I] := GETINTEGER('          AND ---> ',8,1);
    TIE6[I] := GETINTEGER('          AND ---> ',8,1);
    WRITELN;
  END;
WRITELN;
WRITELN('"A" TABBY IS TREADLE  ',TABBYA);
WRITELN('"B" TABBY IS TREADLE  ',TABBYB);
WRITELN;
WRITELN('TIEUP IS -------->');
WRITELN;
FOR I := 1 TO 10 DO
BEGIN
  WRITE('TREADLE',I:2,' TO HARNESS NUMBERS',TIE1[I]:2,' -',TIE2[I]:2);
  WRITE(' -',TIE3[I]:2,' -',TIE4[I]:2,' -',TIE5[I]:2,' -');
  WRITELN(TIE6[I]:2);
END;
WRITELN;
WRITELN;
OKSET := [CHR(13)];
WRITE('                   PRESS <RETURN> TO CONTINUE');
CH := GETCHAR(OKSET);
IF CH = CHR(13) THEN
EXIT(TYEUP);
END;



PROCEDURE TREADLING;  {Color and weave treadling sequence entry routine}
VAR COUNT, RPTFAC, RPTSEQ, I, J, K : INTEGER;
    {RPTFAC = Repeat factor, RPTSEQ = Repeat sequence}
    TEMP : ARRAY[1..80] OF INTEGER; {Temp array to hold repeat sequence}
    TEMPC : ARRAY[1..80] OF CHAR; {Temp array to hold color repeat sequence}
    OKSET : SETOFCHAR;
    
BEGIN
  CLEARSCREEN;
  RPTSEQ := GETINTEGER('HOW MANY TREADLINGS IN A REPEAT ?--->',80,1);
  RPTFAC := MAXSIZE DIV RPTSEQ;
  VERTLEN := RPTSEQ * RPTFAC;
  WRITELN;
  WRITELN;
  WRITELN;
  WRITELN('                       ENTER YOUR TREADLEING REPEAT SEQUENCE');
  WRITELN('                              FOR ',RPTSEQ:3,' TREADLINGS AND');
  WRITELN('                                   8 HARNESSES');
  WRITELN;
  FOR I := 1 TO RPTSEQ DO
  BEGIN
    WRITE('FOR WARP THREAD ',I:2);
    TEMP[I] := GETINTEGER(' TREADLE NO.--->  ',10,1);
  END;
  J := 1;
  FOR I := 1 TO RPTFAC DO
  BEGIN
    FOR K := 1 TO RPTSEQ DO
    BEGIN
      TREADL[J] := TEMP[K];
      J := J + 1
    END;
  END;
  WRITELN('TREDLING SEQUENCE IS------>');
  WRITELN;
  COUNT := 0;
  FOR I := 1 TO VERTLEN DO
  BEGIN
    WRITE(TREADL[I]:2);
    COUNT := COUNT + 1;
    IF COUNT MOD 40 = 0 THEN
    WRITELN;
  END;
  WRITELN;
  WRITELN;
  WRITELN;
  WRITELN;
  OKSET := [CHR(13)];
  WRITE('                 PRESS <RETURN> TO CONTINUE');
  CH := GETCHAR(OKSET);
  IF CH = CHR(13) THEN
  CLEARSCREEN;
  OKSET := ['D','d','L','l'];
  WRITELN;
  WRITELN;
  WRITELN('ENTER YOUR WEFT COLOR SEQUENCE EITHER "D" OR "L"');
  WRITELN('FOR EACH PICK FOR ',RPTSEQ:3,' PICKS');
  WRITELN;
  FOR I := 1 TO RPTSEQ DO
  BEGIN
    WRITE('NO. ',I:2,' THREAD COLOR --> ');
    TEMPC[I] := GETCHAR(OKSET);
    WRITELN;
  END;
  WRITELN;
  WRITELN;
  J := 1;
  FOR I := 1 TO RPTFAC DO
  BEGIN
    FOR K := 1 TO RPTSEQ DO
    BEGIN
      COLOR2[J] := TEMPC[K];
      J := J + 1
    END;
  END;
  WRITELN;
  WRITELN;
  WRITELN('PICK COLOR SEQUENCE IS --->');
  WRITELN;
  COUNT := 0;
  FOR I := 1 TO VERTLEN DO
  BEGIN
    WRITE(COLOR2[I]:2);
    COUNT := COUNT + 1;
    IF COUNT MOD 40 = 0 THEN
    WRITELN;
  END;
  WRITELN;
  WRITELN;
  WRITELN;
  OKSET := [CHR(13)];
  WRITE('                  PRESS <RETURN> TO CONTINUE');
  CH := GETCHAR(OKSET);
  IF CH = CHR(13) THEN
  EXIT(TREADLING);
END;
      
      
PROCEDURE PTREADLING;  {Plain weave treadling sequence entry routine}
VAR COUNT, RPTFAC, RPTSEQ, I, J, K : INTEGER;
    TEMP : ARRAY[1..80] OF INTEGER;
    OKSET : SETOFCHAR;
    
BEGIN
  CLEARSCREEN;
  RPTSEQ := GETINTEGER('HOW MANY TREADLINGS IN A REPEAT ?--->',80,1);
  RPTFAC := MAXSIZE DIV RPTSEQ;
  VERTLEN := RPTSEQ * RPTFAC;
  WRITELN;
  WRITELN;
  WRITELN;
  WRITELN('                       ENTER YOUR TREADLEING REPEAT SEQUENCE');
  WRITELN('                              FOR ',RPTSEQ:3,' TREADLINGS AND');
  WRITELN('                                   8 HARNESSES');
  WRITELN;
  FOR I := 1 TO RPTSEQ DO
  BEGIN
    WRITE('FOR WARP THREAD ',I:2);
    TEMP[I] := GETINTEGER(' TREADLE NO.--->  ',10,1);
  END;
  J := 1;
  FOR I := 1 TO RPTFAC DO
  BEGIN
    FOR K := 1 TO RPTSEQ DO
    BEGIN
      TREADL[J] := TEMP[K];
      J := J + 1
    END;
  END;
  WRITELN('TREDLING SEQUENCE IS------>');
  WRITELN;
  COUNT := 0;
  FOR I := 1 TO VERTLEN DO
  BEGIN
    WRITE(TREADL[I]:2);
    COUNT := COUNT + 1;
    IF COUNT MOD 40 = 0 THEN
    WRITELN;
  END;
  WRITELN;
  WRITELN;
  WRITELN;
  WRITELN;
  OKSET := [CHR(13)];
  WRITE('                 PRESS <RETURN> TO CONTINUE');
  CH := GETCHAR(OKSET);
  IF CH = CHR(13) THEN
  EXIT(PTREADLING);
END;
      
PROCEDURE COPYTHRD;
VAR COUNT, I : INTEGER;

BEGIN
  CLEARSCREEN;
  WRITELN('                   **** AS DRAWN IN ****');
  WRITELN;
  WRITELN('    THIS PROCEDURE WILL MAKE YOUR TREADLING SEQUENCE THE SAME AS');
  WRITELN('    YOUR THREADING SEQUENCE---IF YOUR TABBY''S ARE ON 9 AND 10');
  WRITELN('    AND YOU USE ANY TABBY TREADLING THIS PROCEDURE WILL NOT WORK');
  WRITELN;
  WRITE('      DO YOU WANT TO PROCEED ?  Y OR N :--> ');
  READ(KEYBOARD,CH);
  IF CH IN ['Y','y'] THEN
  BEGIN
    VERTLEN := HORIZLEN;
    WRITELN;
    WRITELN;
    WRITELN('    COPYING THREADING SEQUENCE TO TREADLING SEQUENCE --->');
    FOR I := 1 TO VERTLEN DO
    BEGIN
      TREADL[I] := THREAD[I];
      WRITE('.');
    END;
    WRITELN;
    WRITELN;
    WRITELN;
    WRITELN('TREADLING SEQUENCE IS ---> ');
    WRITELN;
    COUNT := 0;
    FOR I := 1 TO VERTLEN DO
    BEGIN
      WRITE(TREADL[I]:2);
      COUNT := COUNT + 1;
      IF COUNT MOD 40 = 0 THEN
      WRITELN;
    END;
    WRITELN;
    WRITELN;
    OKSET := [CHR(13)];
    WRITELN('                   PRESS <RETURN> TO CONTINUE');
    CH := GETCHAR(OKSET);
    IF CH = CHR(13) THEN
    EXIT(COPYTHRD);
  END ELSE
  EXIT(COPYTHRD);
END;

{$I DRAW8A.1.TEXT}


========================================================================================
DOCUMENT :usus Folder:VOL29:drawdn.doc.text
========================================================================================



                       DOCUMENTATION FOR DRAWDOWN USERS


         A computer using the UCSD p-System IV.1 is required and a
         printer with a graphics capability will make a draw-down
         almost identical with one done by hand on graph paper.  A
         draw-down using a regular printer gives a fairly good draw-
         down, however it is an elongated version and presents a
         distorted idea in comparison with a hand draw-down.

         The time saved in this process can be understood when using
         a straight draw twill threading with a standard tie-up by
         the timing of the running of the program.  To key in all
         the original information (including the color and weave
         sequences) took a total time of 3 minutes. Using the option
         to change the treadlings and color and weave sequences
         only, took 1-1/2 minutes.  By using the "menu-driven"
         commands and following the directions on the screen, even a
         person with no computer experience can get draw-downs once
         the equipment is running (computer on - screen ready -
         program in place - and printer on and ready to print.


         The screen will display:

      >DrawDown 4:  P)lain drawdown     C)olor & Weave        Q)uit

         There are 3 decisions to make: "P" to proceed with an
         ordinary drawdown, "C" to select a color and weave option,
         or "Q" to quit.  In order to do this one merely preses one
         key, either P or C or Q.  >DrawDown 4:  Lets you know that 
         you are in a 4 harness drawdown program.
         

      >Draw 4: A)Threading B)Tie-up C)Treadling D)Drawn-In P)Print Q)uit
         

         >Draw 4: Indicates that the plain portion of the program is
         running.  >Draw 4C: Indicates that the color & weave
         portion of the program is running.
         

         A)Threading - refers to the original draft for threading a
         warp - One should be aware of the number of repeats of the
         pattern and when the the question comes up for how many
         warp threads, be prepared to answer how many (straight
         twill 1-2-3-4- x 10 repeats = 40) - in this case 40. The
         smallest number for one repeat is 2, the largest is 80. 
         Eighty is chosen as the maximum number because of screen
         and printer limitations. Complex patterns must be built up
         - block by block.  Once the number of threads are selected,
         the computer will adjust the maximum that is entered so
         that an even number of repeats will be shown.  

         B)Tieup refers to any ordinary loom tie-up or in the case
         of table looms, the harness combinations.  Special or trial
         tie-ups may be entered or changed without affecting either
         the threading or the treadling.  How to do this will be
         explained later.  Tabby sequences are possible by
         designating certain harnesses as such.

         C)Treadling refers to the treadling sequence in one
         repeat.  The computer fills in any additional repeats as
         called for.  Each treadling may be viewed or printed, and
         then if different one is desired it is possible.

         D)DrawnIn - will automatically enter a treadling sequence
         identical to the threading, commonly known as "TROMP-AS-
         WRIT" or "AS DRAWN IN".

         P)Print: This command also gives choices, such as for
         display on the screen only, to go to an ordinary printer
         or to go to the graphics printeri.

         Q)Quit is the command that stops the program.  There is no
         capacity to save individual draw-downs at present, however
         it is possible if the need is greater than the need for
         storage disks.  Considering the time involved in doing a
         draw-down it seems wiser at present to have all the
         information on a hard (paper) copy rather than fill disk
         after disk with drafts.  As many copies as needed of a
         particular draft may be made before the "Q" command is
         called.  In view of this, it seema that hard-copy files of
         all draw-downs be kept for future reference.
 
         The program was written for a rising shed loom.
         
         THE ABOVE IS A BRIEF EXPLANATION OF WHAT THE PROGRAM DOES,
         FROM THE HANDWEAVERS POINT OF VIEW.
 
 
         FOLLOWING IS THE HANDS ON PRESENTATION OR WHAT HAPPENS WHEN
         A WEAVER IS USING THE PROGRAM FOR THE FIRST TIME:


         USING THE SYSTEM DISK, (IN DISK DRIVE 4) BOOT UP THE
         SYSTEM, THEN WITH THE DISK "WEAVE" (IN DISK DRIVE 5) SELECT
         THE PROPER OPTION TO GET INTO THE PROGRAM. (WHAT APPEARS
         ACROSS THE TOP OF THE SCREEN IS THE MENU - WHAT FOLLOWS IT
         ARE THE OPTIONS OR ACTIVITIES AVAILABLE FOR CHOICE - ONLY
         ONE OPTION AT A TIME MAY BE SELECTED.) THE ")" CHARACTER
         INDICATES THAT ONLY THE FIRST LETTER NEED BE TYPED IN.

         Key --X-- when asked - Execute what file? - type in
         WEAVE:DRAW4 (or DRAW8) and the program will come up
         running.
     
         An explanation (Title block) of the program appears.  Read
         and follow directions.
     
         The Menu shows three choices: DRAWDOWN 4 (or 8)(This tells
         which program was selected.) P)LAIN DRAWDOWN, C)OLOR AND
         WEAVE, Q)UIT.
  
          Keying  P  means that a plain drawdown was selected.
          Keying  C  means a Color and WEave drawdown was selected.
          Keying  Q  will terminate the program.

         note: A "C" option will be selected because it shows more
         options.  Everything that appears in the Plain option also
         appears in the Color and Weave.


      Menu:
      DRAW 4C A)Threading B)Tieup C)Treadling D)DrawnIn P)rint Q)uit


         A)Threading
         
         NOTE: Always start with the "A" option as this option
         defines how large the drawdown pattern will be and it
         establishes this size for the other options to use.
         
         By keying the A the 1st thing to appear is COMMENT.  Enter
         any comments you may want to make.  This permits anything
         to be entered - perhaps an identifying name or number or
         source, but room has been reserved for only 40 spaces.  If
         no such comment is desired, press [Return].
     
         ENTER THE MAXIMUM NUMBER OF THREADS YOU WANT IN YOUR
         DRAWDOWN.  THE MINIMUM NUMBER SHOULD BE ONE REPEAT AND THE
         MAXIMUM IS 80.
          
         HOW MANY WARP THREADS?  Enter the number (for example) 10.
         HOW MANY THREADS IN A REPEAT?  Enter the number (for example) 2.
         ENTER YOUR THREADING REPEAT SEQUENCE FOR  (number)  THREADS 
         AND ( 4 ) HARNESSES.
         
         NO. 1 THREAD TO HARNESS NO.  (number).
         NO. 2 THREAD TO HARNESS NO.  (number).
         NO. 3 THREAD TO HARNESS NO.  (number).
         NO. 4 THREAD TO HARNESS NO.  (number).
         etc:
         
         A horizontal presentation of the sequence appears on the
         screen, follow directions, press [Return].
           
         ENTER YOUR WARP THREAD COLOR REPEAT SEQUENCE WITH EITHER
         "D" OR "L" FOR EACH 2 THREADS.  (More than 2 colors are not
         possible with the present programs).
           
         NO. 1 THREAD COLOR (when cursor remains in one place - key 
         either) D or L.
         
         At the top of the screen WARP THREAD COLOR SEQUENCE IS __
         (color sequence appears horizontally).  Press [Return] to 
         continue. 
         
         The previous menu appears, this time press the  B  key 
         which relates to the tie up.
         
         B)Tie up
         
         WHAT TREADLE DO YOU WANT FOR TABBY A? (Usually refers to a 
         number other than any of the numbered harnesses for example 
         answer) 5.  [Return]
         WHAT TREADLE DO YOU WANT FOR TABBY  B?  (ans.)  6.  [Return].i
         
         ENTER THE TREADLE TIE UP TO THE HARNESSES.  If a treadle is 
         tied to only one harness - then - enter that same harness 
         number 3 times or if a treadle is tied to 2 harnesses - 
         then - repeat either of the harnesses once or if a treadle 
         is tied to 3 different harnesses - then - enter all three 
         numbers.  Draw 4 has reserved space for 3 different 
         harnesses on each treadle, Draw 8 has reserved space for 6 
         different harnesses per treadle.....Each space must be 
         filled (for the computer), but remember that you can in 
         reality only tie harness 2 to treadle 1 one time, no matter
         how many times it is repeated for the computer.  Repetition
         of the numbers of harnesses permit greater flexibility in 
         tie ups.
         
         TREADLE 1 TO (Enter the harness to which treadle is tied)
         for example...) 1 and 2 and 2.  Key [Return] after each entry.
         
         TREADLE 2 TO (Enter...) 2 and 3 and 3.
         TREADLE 3 TO (Enter...) 3 and 4 and 4.
         TREADLE 4 TO (Enter...) 4 and 1 and 1
         etc:
         
         A summary of the tie up appears for double checking [Return].
         
         Note:  Space is left on the hard-copy print to paste on a
         graph paper copy of the draft and tie up to the left of the 
         printer-copy.
         
         C)treadling
         
         HOW MANY TREADLINGS IN A REPEAT (for example) 4.
         ENTER YOUR TREADLING REPEAT SEQUENCE FOR 4 TREADLINGS AND 4 
         HARNESSES.
         
         FOR WARP THREAD 1 - TREADLE NO _____ (complete).  [Return] after 
         each entry.
         FOR WARP THREAD 2 - TREADLE NO _____   [Return].
         FOR WARP THREAD 3 - TREADLE NO _____   [Return].
         FOR WARP THREAD 4 - TREADLE NO _____   [Return].
         etc:
         
         ENTER YOUR WEFT COLOR SEQUENCE  (either D or L for each 
         pick of the repeat).
         NO 1 THREAD COLOR ____ (no return is needed here)
         NO 2 THREAD COLOR ____
         NO 3 THREAD COLOR ____ 
         NO 4 THREAD COLOR ____
         etc:
         
         Again there will be a horizontal sequence of colors displayed.

         The draft has been entered, now the computer really goes to 
         work.
         
         
         P)rint
         
         By keying  P  for print, another set of choices appears on
         the screen.  
         
         S)creen   P)rinter   G)raphics   Q)uit
         
         S.  shows a screen draw down which gives a fair
         representation of graph paper version.
         
         P.  gives the typewriter or printer version of what
         appeared on the screen.  It is a distorted and much
         elongated representation of the draw down.
         
         G.  produces the same draw down, but it most nearly
         approximates the graph paper version because the design is
         made up of adjoining squares.
         
         Before each step of the print out continues the program is
         stopped to let you check the printer settings. Remember
         each time you change settings on a printer, turn the
         printer off to be sure it has your new instructions in the
         memory.
         
         There is only one more item on the menu -- that is Q)UIT.
         
         Q.  will bring up the previous menu....If you want to
         experiment with other tie-ups the "A" or "B" or "C" keys
         may be changed - one at a time.  In other words, by
         changing the "C" or treadling, an entire new treadling
         sequence may be tried without changing either the threading
         or the tie up, or another tie up may be chosen without
         changing the threading or the treadling.  When making these
         choices, the original threading sequence and the repeats
         should either be put in first and remain, or if it is
         changed, treadling should be re entered.  Use of a color
         printer is possible, howeve, the program would have to be
         adjusted and we preferred to work only in black and white.
         
         If you make a mistake in one of your entries, continue to 
         enter any data untill that option is completed then when 
         the menu appears again, select the same option and re-enter 
         that option and the mistake will be corrected.
         
         
         You are finished and want to stop entirely.  Key "Q" and
         the original menu appears. There is still the choice to go
         to either a simpler or more complex version.  You may elect
         to do the draw-down as a plain version or in color and
         weave, if really quitting is desired, keying the "Q" again
         terminates the program.  If you want to do an 8 harness you
         will have to eX)ecute the DRAW8 program as at the start.
         
         
         
         
         

========================================================================================
DOCUMENT :usus Folder:VOL29:install.text
========================================================================================

1


                       Program CONVERS - Installation Notes

                                   John Dykstra

                                  April 14, 1984





           This document is an attempt to describe everything needed to
           install CONVERS on a personal computer running the p-System.
           Most of  the  material  concerns  the  external  compilation
           UNIT's  that  are  used to interface CONVERS to the hardware
           and software of the system.  There is also  some  discussion
           of  the  system  features  useful  or necessary when running
           CONVERS, and some miscellaneous notes.

           The final section describes TERMINAL, which  provides  "dumb
           terminal"  emulation,  with  the  added capability of easily
           calling CONVERS.






                               John Dykstra
                               4788 Anderson Lane
                               Shoreview, MN  55112
                               (612) 483-4286
                               (612) 482-3874

























1                                                                   1-1
                                                               84/04/16
        ---------------------------------------------------------------
        1.0 SEPARATE COMPILATION UNITS

        ---------------------------------------------------------------

           1.0 SEPARATE COMPILATION UNITS
+              __________________________


           CONVERS uses separate compilation units  to  handle  machine
           and implementation dependent matters.

           1.1 SCREENOPS
+              _________

           Softech provides SCREENOPS as a standard part of the Version
           IV p-System.

           II.0 systems can use the SCREENOPS  provided  with  CONVERS.
           Since  this  UNIT  obtains  character  definitions  from the
           p-system, this code should work for all II.0 systems.   II.1
           users  may  have  to  modify it to get it to work with their
           systems.

           To compile SCREENOPS on either II.0 or II.1, you will need a
           copy  of  the  GLOBALS  definitions  for your system.  These
           files have been distributed through USUS.

           1.2 REMUNIT
+              _______

           CONVERS uses  the  USUS  standard  remote  compilation  unit
           REMUNIT to interface to the link.  See USUS Newsletter 4 for
           a description of this UNIT.  REMUNIT's for  several  popular
           personal  computers  have  been distributed through the USUS
           library.

           1.3 TEXTIO
+              ______

           TEXTIO handles reading and  writing  text  lines  from  disk
           files.   It  has two advantages: It allows ARRAY's of FILES,
           and on II.0 systems it is much faster than Pascal  READ  and
           WRITE statements.

           I  have  included sources of TEXTIO for II.0 and IV systems.
           Both should run without modification on all systems  of  the
           proper  version.   If  you have II.1, you may have to modify
           the II.0 source to get it to compile.

           The  source  for  IV  includes  explicit  p-codes,  and  may
           therefore  have  to be modified due to future changes in the
           p-System.  It has been tested thru  Version  IV.03.   If  it
           stops  working when you upgrade to a later system, try using
           DECODE to look at the p-codes generated by  READ  and  WRITE
           statements.






1                                                                   1-2
                                                               84/04/16
        ---------------------------------------------------------------
        1.0 SEPARATE COMPILATION UNITS
        1.4 OSMISC
        ---------------------------------------------------------------

           1.4 OSMISC
+              ______

           This unit provides miscellaneous services, including  a  way
           to  pass  parameters  and commands between various programs,
           and a real-time timer.

           The UCSD operating  system  currently  does  not  provide  a
           standard  way  to  pass  a  parameter string to an executing
           program.  OSMISC implements my own scheme.  The  unit  first
           looks  for  a parameter string on a file called CMDLINE.TEXT
           on the system device.  If that file does  not  exist  or  is
           empty, a command string is requested from the keyboard.

           The  EXECUTE command calls OSMISC to pass a parameter string
           to  the  called  program.   That  string   is   written   to
           CMDLINE.TEXT on the system device.

           OSMISC  also  implements  the  real-time timers that CONVERS
           uses to keep track of how long it waits for  prompts.   Time
           periods   are   expressed   in  tenths  of  a  second.   The
           distributed  versions  of  these  UNIT's   approximate   the
           operation of the timers by delay loops.  If these UNIT's are
           used, the time periods specified in  scripts  will  be  only
           approximate.   If your system has a real-time clock, you may
           want to modify OSMISC to use it.

           There are two versions of OSMISC provided.  The II.0 version
           uses  a separate unit called CHAIN from Volume 8 of the USUS
           library.  The IV version uses interfaces  from  the  Softech
           standard unit COMMANDIO.

           Both  of  these  versions  follow  their own conventions for
           keyboard control, which may or may not match the conventions
           of  your  system.   The  backspace key is used to delete one
           character, and ASCII code CAN (control-X) is used to  delete
           the  entire  typein.   If  desired,  these can be changed by
           editing and compiling the source for the unit.
















1                                                                   2-1
                                                               84/04/16
        ---------------------------------------------------------------
        2.0 OTHER SYSTEM REQUIREMENTS AND INTERFACES

        ---------------------------------------------------------------

           2.0 OTHER SYSTEM REQUIREMENTS AND INTERFACES
+              ________________________________________


           2.1 DISPLAY
+              _______

           CONVERS uses the SC_USE_INFO procedure in SCREENOPS to  find
           out  the height of the display screen.  (It assumes that the
           screen is at least 80 characters wide.)

           Separate compilation unit  OSMISC  assumes  that  the  ASCII
           character  BS  (backspace)  moves  the cursor back one space
           when written to  the  display.   This  can  be  changed,  if
           necessary, by editing and re-compiling OSMISC.

           2.2 LINK
+              ____

           CONVERS  uses  the  USUS  standard  remote  compilation unit
           REMUNIT to interface to the link.   Normally,  the  physical
           implementation  of  the link is an asynchronous RS-232 line,
           possibly including modems and dial-up connections.

           When CONVERS begins operation, it "searches" for the highest
           baud  rate  accepted  by  REMUNIT.   The following rates are
           tried, in the order given: 9600, 1200, 300 and 110 baud.  If
           none  of  these  baud  rates is accepted and the remote unit
           does not supply its own default (indicated by  a  result  of
           CR_SELECT_NOT_SUPPORTED),   a   message  is  displayed,  and
           CONVERS aborts.

           If this procedure will not work with your REMUNIT,  set  the
           constant  DEFAULT_BAUD  at  the  beginning of CONVERS to the
           baud rate  desired,  and  all  of  this  searching  will  be
           bypassed.

           CONVERS    calls    CR_SETCOMMUNICATIONS   with   parameters
           specifying even parity, a character size of 7  bits,  and  1
           stop  bit.   If necessary, these defaults can be changed via
           the constant declarations at the beginning  of  the  CONVERS
           source code.

           To   reduce  the  possiblility  of  losing  incoming  serial
           characters during workstation disk I/O operations, the  link
           hardware  should  be interrupt-driven, and provide buffering
           capacity.   The  exact  amount  of  buffering  necessary  is
           dependent  upon  the link data rate and workstation hardware
           characteristics.  CONVERS has been successfully run  at  300
           baud  with  16  characters of buffer space, and at 1200 baud
           with 64 characters of space.

           If the host system recognizes flow-control  characters  such
           as  DC1 and DC3 (sometimes referred to as XON and XOFF), the


1                                                                   2-2
                                                               84/04/16
        ---------------------------------------------------------------
        2.0 OTHER SYSTEM REQUIREMENTS AND INTERFACES
        2.2 LINK
        ---------------------------------------------------------------

           interrupt driver for the link can use this flow  control  to
           prevent   overflow   of   its   buffers.   This  effectively
           eliminates any chance of losing characters.

           If  possible,  interaction  with  the  host  should  be   in
           full-duplex  mode.   This  eliminates  the possibility of an
           echoed character appearing in the middle of  a  host  string
           that   is   being  searched  for  by  CONVERS,  and  falsely
           preventing recognition of the match.  The UPLOAD  option  of
           TRANSFER attempts to read and discard any echos it receives,
           but CONVERS has not been extensively tested in this mode.

           The CONVERS commands DIAL and HANGUP have not  been  tested,
           due to the lack of an auto-dial modem.







































1                                                                   3-1
                                                               84/04/16
        ---------------------------------------------------------------
        3.0 MISCELLANEOUS NOTES

        ---------------------------------------------------------------

           3.0 MISCELLANEOUS NOTES
+              ___________________


           The UCSD P-system permits file names to begin with  a  digit
           character.   These file names cannot be used by CONVERS, due
           to a syntatic conflict between names and integer  constants.















































1                                                                   4-1
                                                               84/04/16
        ---------------------------------------------------------------
        4.0 PROGRAM TERMINAL

        ---------------------------------------------------------------

           4.0 PROGRAM TERMINAL
+              ________________


           This program provides "dumb terminal"  emulation,  with  the
           added capability of easily calling CONVERS.

           The  baud  rate, parity, character size and stop bit options
           used by terminal are determined by  compile-time  constants.
           The code uses separate compilation units REMUNIT, SCREENOPS,
           and OSMISC.

           When TERMINAL is executed, it immediately goes into terminal
           mode.   Every  key  hit will be transmitted to the host, and
           each character received from the host is displayed.

           Hitting Control-E will exit the program.

           Hitting Control-C will result in  a  prompt  for  a  CONVERS
           parameter  string.   The  user should enter a command string
           for CONVERS, in the usual  form.   When  carriage-return  is
           hit,  TERMINAL  ends  execution,  and  CONVERS  begins.   If
           carriage-return is hit without a  parameter  line,  TERMINAL
           continues execution.








                 





















1
                                                               84/04/16

                                 Table of Contents


           1.0 SEPARATE COMPILATION UNITS  . . . . . . . . . . .    1-1
           1.1 SCREENOPS . . . . . . . . . . . . . . . . . . . .    1-1
           1.2 REMUNIT . . . . . . . . . . . . . . . . . . . . .    1-1
           1.3 TEXTIO  . . . . . . . . . . . . . . . . . . . . .    1-1
           1.4 OSMISC  . . . . . . . . . . . . . . . . . . . . .    1-2

           2.0 OTHER SYSTEM REQUIREMENTS AND INTERFACES  . . . .    2-1
           2.1 DISPLAY . . . . . . . . . . . . . . . . . . . . .    2-1
           2.2 LINK  . . . . . . . . . . . . . . . . . . . . . .    2-1

           3.0 MISCELLANEOUS NOTES . . . . . . . . . . . . . . .    3-1

           4.0 PROGRAM TERMINAL  . . . . . . . . . . . . . . . .    4-1











































========================================================================================
DOCUMENT :usus Folder:VOL29:osmisc_ii0.text
========================================================================================

UNIT osmisc;

{                       UNIT OSMISC - II.0 Version

{  This unit provides various utility functions that may be system dependent.  }
{
{$C  Copyright 1981, 1982, 1983, 1984 by John Dykstra.  All rights reserved.  }


INTERFACE

TYPE

  os_timer = RECORD
               hitime:  INTEGER;
               lotime:  INTEGER;
             END;

  os_prog_name = STRING [ 25 ];
  
  os_prog_param = STRING [ 255 ];
  
  
PROCEDURE os_start_timer ( VAR user_timer:  os_timer );

FUNCTION os_elapsed_time ( VAR user_timer:  os_timer ):  INTEGER;

PROCEDURE os_get_param_string ( VAR param_string:  os_prog_param );

PROCEDURE os_store_command ( prog_name:  os_prog_name;
                             param_string:  os_prog_param );

PROCEDURE os_clear_commands;

PROCEDURE os_exit_to_next;

PROCEDURE os_chain_to_program ( prog_name:  os_prog_name );



IMPLEMENTATION

CONST
  
  {  The following constants define special control characters for 
  {  keyboard input within OS_GET_PARAM_STRING.                            }
  
  ch_bs = 8;                    {  character to delete one character  }
  ch_can = 24;                  {  character to delete entire field  }
  
  {  The following constant is used in OS_ELAPSED_TIME to approximate the
  {  operation of a real-time clock.  The value supplied is more or less
  {  right for a 4Mhz Z80 running II.0 or IV.03.                           }
  
  kludge_constant = 2;
  
  {  Other miscellaneous constant definitions.  }
  
  cmd_file_name = '*CMDLINE.TEXT';
  codefile_suffix = '.CODE';
      
  
VAR
  saved_name:  os_prog_name;
  
  
  
PROCEDURE chain ( codefile:  STRING );  EXTERNAL;


PROCEDURE os_start_timer;

  BEGIN
  user_timer.hitime := 0;
  END;
  
  
FUNCTION os_elapsed_time;

  BEGIN
  user_timer.hitime := user_timer.hitime + kludge_constant;
  os_elapsed_time := user_timer.hitime;
  END;
  
  
PROCEDURE os_get_param_string;

  CONST
    console = 2;
    ch_esc = 27;
    ch_cr = 13;
    
  VAR
    bs_string:  STRING [ 3 ];
    str:  STRING [ 1 ];
    cmd_file:  TEXT;
    index:  INTEGER;
    got_command:  BOOLEAN;
    
  BEGIN         {  PROCEDURE os_get_param_string  }
  bs_string := '   ';
  bs_string [ 1 ] := CHR ( ch_bs );
  bs_string [ 2 ] := ' ';
  bs_string [ 3 ] := CHR ( ch_bs );
  
  param_string := '';
  got_command := FALSE;
  
  {$I-  Disable implicit I/O checking  }
  RESET ( cmd_file, cmd_file_name );
  {$I+  Re-enable implicit I/O checking  }
  
  IF IORESULT = 0 THEN
    IF NOT EOF ( cmd_file ) THEN
      BEGIN
      READLN ( cmd_file, param_string );
      CLOSE ( cmd_file, PURGE );
      got_command := LENGTH ( param_string ) > 0;
      END;      {  ifend  }
  
  IF NOT got_command THEN
    BEGIN
    GOTOXY ( 0, 22 );
    WRITE( 'What is the parameter line?  ' );
    str := 'x';
    REPEAT
      BEGIN
      UNITREAD ( console, str [ 1 ], 1, , 4 + 2 );
      IF str [ 1 ] >= ' ' THEN
        BEGIN
        param_string := CONCAT ( param_string, str );
        UNITWRITE ( console, str [ 1 ], 1 );
        END
      ELSE
        IF ( str [ 1 ] = CHR ( ch_bs ) ) AND ( LENGTH ( param_string ) > 0) THEN
          BEGIN
          DELETE ( param_string, LENGTH ( param_string ), 1 );
          UNITWRITE ( console, bs_string [ 1 ], 3 );
          END
        ELSE
          IF str [ 1 ] = CHR ( ch_can ) THEN
            WHILE LENGTH ( param_string ) > 0 DO
              BEGIN
              DELETE ( param_string, LENGTH ( param_string ), 1 );
              UNITWRITE ( console, bs_string [ 1 ], 3 );
              END;
      END;      {  REPEATEND  }
    UNTIL ( str [ 1 ] = CHR ( ch_esc ) ) OR ( str [ 1 ] = CHR ( ch_cr ) );
    
    IF str [ 1 ] = CHR ( ch_esc ) THEN
      EXIT ( PROGRAM );
      
    END;        {  ifend  }

  END;          {  PROCEDURE os_get_param_string  }


PROCEDURE os_store_command;

  VAR
    cmd_file:  TEXT;
  
  BEGIN         {  PROCEDURE os_store_command  }
  saved_name := prog_name;
  REWRITE ( cmd_file, cmd_file_name );
  WRITELN ( cmd_file, param_string );
  CLOSE ( cmd_file, LOCK );
  END;          {  PROCEDURE os_store_command  }
  
  
  
PROCEDURE os_clear_commands;


  VAR
    cmd_file:  TEXT;

  BEGIN         {  PROCEDURE os_clear_commands  }
  {$I-  Disable implicit I/O checking  }
  RESET ( cmd_file, cmd_file_name );
  {$I+  Re-enable implicit I/O checking  }
  
  IF IORESULT = 0 THEN
    CLOSE ( cmd_file, PURGE );
  
  END;          {  PROCEDURE os_clear_commands  }
  
  
  PROCEDURE os_exit_to_next;
  
    BEGIN       {  PROCEDURE os_exit_to_next  }
    IF LENGTH ( saved_name ) > 0 THEN
      chain ( CONCAT ( saved_name, codefile_suffix ) );
    EXIT ( PROGRAM );
    END;        {  PROCEDURE os_exit_to_next  }
    
  
  
  PROCEDURE os_chain_to_program;
  
    BEGIN
    chain ( CONCAT ( prog_name, codefile_suffix ) );
    EXIT ( PROGRAM );
    END;
    
    
 END.

========================================================================================
DOCUMENT :usus Folder:VOL29:osmisc_iv.text
========================================================================================

PROGRAM aunit;
{$S+}

UNIT osmisc;

{                       UNIT  OSMISC                                           }

{                      P-System Version IV.03                           }

{  This unit provides various utility functions that may be system-dependent.  }

    {$C   Copyright 1981, 1982, 1984 by John Dykstra.  All rights reserved.  }


INTERFACE

TYPE

  os_timer = RECORD
               hitime:  INTEGER;
               lotime:  INTEGER;
             END;

  os_prog_name = STRING [ 25 ];
  
  os_prog_param = STRING [ 255 ];
  
  
PROCEDURE os_start_timer ( VAR user_timer:  os_timer );

FUNCTION os_elapsed_time ( VAR user_timer:  os_timer ):  INTEGER;

PROCEDURE os_get_param_string ( VAR param_string:  os_prog_param );

PROCEDURE os_store_command ( prog_name:  os_prog_name;
                             param_string:  os_prog_param );

PROCEDURE os_clear_commands;

PROCEDURE os_exit_to_next;

PROCEDURE os_chain_to_program ( prog_name:  os_prog_name );



IMPLEMENTATION

USES commandio;

CONST
  
  {  The following constants define special control characters for 
  {  keyboard input within GET_PARAM_STRING.                            }
  
  ch_bs = 8;                    {  character to delete one character  }
  ch_can = 24;                  {  character to delete entire field  }
  
  {  The following constant is used in OS_ELAPSED_TIME to approximate the
  {  operation of a real-time clock.  The value supplied is more or less
  {  right for a 4Mhz Z80 running II.0 or IV.03.                           }
  
  kludge_constant = 2;
  
  {  Other miscellaneous constant definitions.  }
  
  cmd_file_name = '*CMDLINE.TEXT';
  codefile_suffix = '.CODE';
      

PROCEDURE os_start_timer;

  BEGIN
  user_timer.hitime := 0;
  END;
  
  
FUNCTION os_elapsed_time;

  BEGIN
  user_timer.hitime := user_timer.hitime + kludge_constant;
  os_elapsed_time := user_timer.hitime;
  END;
  
  
PROCEDURE os_get_param_string;

  CONST
    console = 2;
    ch_esc = 27;
    ch_cr = 13;
    
  VAR
    bs_string:  STRING [ 3 ];
    str:  STRING [ 1 ];
    cmd_file:  TEXT;
    index:  INTEGER;
    got_command:  BOOLEAN;
    
  BEGIN         {  PROCEDURE os_get_param_string  }
  bs_string := '   ';
  bs_string [ 1 ] := CHR ( ch_bs );
  bs_string [ 2 ] := ' ';
  bs_string [ 3 ] := CHR ( ch_bs );
  
  param_string := '';
  got_command := FALSE;
  
  {$I-  Disable implicit I/O checking  }
  RESET ( cmd_file, cmd_file_name );
  {$I+  Re-enable implicit I/O checking  }
  
  IF IORESULT = 0 THEN
    IF NOT EOF ( cmd_file ) THEN
      BEGIN
      READLN ( cmd_file, param_string );
      CLOSE ( cmd_file, PURGE );
      got_command := LENGTH ( param_string ) > 0;
      END;      {  ifend  }
  
  IF NOT got_command THEN
    BEGIN
    GOTOXY ( 0, 22 );
    WRITE( 'What is the parameter line?  ' );
    str := 'x';
    REPEAT
      BEGIN
      UNITREAD ( console, str [ 1 ], 1, , 4 + 2 );
      IF str [ 1 ] >= ' ' THEN
        BEGIN
        param_string := CONCAT ( param_string, str );
        UNITWRITE ( console, str [ 1 ], 1 );
        END
      ELSE
        IF ( str [ 1 ] = CHR ( ch_bs ) ) AND ( LENGTH ( param_string ) > 0) THEN
          BEGIN
          DELETE ( param_string, LENGTH ( param_string ), 1 );
          UNITWRITE ( console, bs_string [ 1 ], 3 );
          END
        ELSE
          IF str [ 1 ] = CHR ( ch_can ) THEN
            WHILE LENGTH ( param_string ) > 0 DO
              BEGIN
              DELETE ( param_string, LENGTH ( param_string ), 1 );
              UNITWRITE ( console, bs_string [ 1 ], 3 );
              END;
      END;      {  REPEATEND  }
    UNTIL ( str [ 1 ] = CHR ( ch_esc ) ) OR ( str [ 1 ] = CHR ( ch_cr ) );
    
    IF str [ 1 ] = CHR ( ch_esc ) THEN
    
      {  The following code is temporarily deleted due to a bug in IV.03's
      {  implementation of the EXIT statement from UNIT's.  It is up to the
      {  caller to check for a null command.                                }
    
      (*  
      EXIT ( PROGRAM );
        *)
      param_string := '';
    
      
    END;        {  ifend  }

  END;          {  PROCEDURE os_get_param_string  }
  
{$P}

PROCEDURE os_store_command;

  VAR
    cmd_file:  TEXT;
  
  BEGIN         {  PROCEDURE os_store_command  }
  CHAIN ( prog_name );
  REWRITE ( cmd_file, cmd_file_name );
  WRITELN ( cmd_file, param_string );
  CLOSE ( cmd_file, LOCK );
  END;          {  PROCEDURE os_store_command  }
  
  
  
PROCEDURE os_clear_commands;


  VAR
    cmd_file:  TEXT;

  BEGIN         {  PROCEDURE os_clear_commands  }
  
  CHAIN ( '' );
  
  {$I-  Disable implicit I/O checking  }
  RESET ( cmd_file, cmd_file_name );
  {$I+  Re-enable implicit I/O checking  }
  
  IF IORESULT = 0 THEN
    CLOSE ( cmd_file, PURGE );
  
  END;          {  PROCEDURE os_clear_commands  }
  
  
  PROCEDURE os_exit_to_next;
  
    BEGIN       {  PROCEDURE os_exit_to_next  }
    
    {  The following code is temporarily deleted due to a bug in IV.03's
    {  implementation of the EXIT statement from UNIT's.  It is up to the
    {  caller to exit after calling this noop procedure.                  }
    
    (*
    EXIT ( PROGRAM );
      *)
      
    END;        {  PROCEDURE os_exit_to_next  }
    
  
  
PROCEDURE os_chain_to_program {  ( prog_name:  STRING )  };

  BEGIN         {  PROCEDURE os_chain_to_program  }
  chain ( prog_name );
  END;          {  PROCEDURE os_chain_to_program  }

    
 END.



========================================================================================
DOCUMENT :usus Folder:VOL29:scrnop_ii0.text
========================================================================================

{$S+}
{$I *GLOBAL.II0 }


{                       SCREENOPS 
{
{                       Version C1
{
{  This unit implements a subset of the Softech definition of SCREENOPS for
{  version II.0 systems.  
{
{  WARNING - Not all SCREENOPS functions are currently implemented.
{
{  The INTERFACE section of this code is copyrighted by Softech Microsystems.
{                                                                       }
{$C (C) Copyright 1982, 1984 by John Dykstra.  All rights reserved.}


SEPARATE UNIT screenops;
  
  INTERFACE
  

CONST
    sc_fill_len = 11;
    sc_eol = 13;  

TYPE
    sc_chset        = SET OF CHAR;
    sc_misc_rec     = PACKED RECORD
                        height, width : 0..255;
                        can_break, slow, xy_crt, lc_crt,
                        can_upscroll, can_downscroll : BOOLEAN;
                      END;
    sc_date_rec     = PACKED RECORD
                        month : 0..12;
                        day :   0..31;
                        year :  0..99;
                      END;
    sc_info_type    = PACKED RECORD
                        sc_version : STRING;
                        sc_date : sc_date_rec;
                        spec_char : sc_chset; {Characters not to echo}
                        misc_info : sc_misc_rec;
                      END;
    sc_long_string  = STRING[255];
    sc_scrn_command = (sc_whome, sc_eras_s, sc_erase_eol, sc_clear_lne,
                       sc_clear_scn, sc_up_cursor, sc_down_cursor,
                       sc_left_cursor, sc_right_cursor);
    sc_key_command  = (sc_backspace_key, sc_dc1_key, sc_eof_key, sc_etx_key,
                       sc_escape_key, sc_del_key, sc_up_key, sc_down_key, 
                       sc_left_key, sc_right_key, sc_not_legal);
    sc_choice       = (sc_get, sc_give);
    sc_window       = PACKED ARRAY [0..0] OF CHAR;
    sc_tx_port      = RECORD
                        row, col,             { screen relative}
                        height, width,        { size OF txport (zero based)}
                        cur_x, cur_y  : INTEGER;
                                     {cursor positions relative to the txport }
                      END;
                    
  PROCEDURE sc_use_info(do_what:sc_choice; VAR t_info:sc_info_type);
  PROCEDURE sc_use_port(do_what:sc_choice; VAR t_port:sc_tx_port);
  PROCEDURE sc_erase_to_eol(x,line:INTEGER);
  PROCEDURE sc_left;
  PROCEDURE sc_right;
  PROCEDURE sc_up;
  PROCEDURE sc_down;
  PROCEDURE sc_getc_ch(VAR ch:CHAR; return_on_match:sc_chset);
  PROCEDURE sc_clr_screen;
  PROCEDURE sc_clr_line (y:INTEGER);
  PROCEDURE sc_home;
  PROCEDURE sc_eras_eos (x,line:INTEGER);
  PROCEDURE sc_goto_xy(x, line:INTEGER);
  PROCEDURE sc_clr_cur_line;
  FUNCTION  sc_find_x:INTEGER;
  FUNCTION  sc_find_y:INTEGER;
  FUNCTION  sc_scrn_has(what:sc_scrn_command):BOOLEAN;
  FUNCTION  sc_has_key(what:sc_key_command):BOOLEAN;
  FUNCTION  sc_map_crt_command(VAR k_ch:CHAR):sc_key_command;
  FUNCTION  sc_prompt(line :sc_long_string; x_cursor,y_cursor,x_pos,
                       where:INTEGER; return_on_match:sc_chset; 
                       no_char_back:BOOLEAN; break_char:CHAR):CHAR;
  FUNCTION sc_check_char(VAR buf:sc_window; VAR buf_index,bytes_left:INTEGER)
                         :BOOLEAN;
  FUNCTION space_wait(flush:BOOLEAN):BOOLEAN;
  PROCEDURE sc_init;
    
  IMPLEMENTATION
  
  PROCEDURE sc_use_info { do_what:sc_choice; VAR t_info:sc_info_type };
  
    BEGIN
    IF do_what = sc_get THEN
      BEGIN
      t_info.sc_version := 'II.0 emulation by John Dykstra';
      t_info.sc_date := thedate;
      t_info.spec_char := [];
      t_info.misc_info.height := 23;
      t_info.misc_info.width := 79;
      t_info.misc_info.can_break := FALSE;        {  ?  }
      t_info.misc_info.slow := FALSE;
      t_info.misc_info.xy_crt := TRUE;            {  ?  }
      t_info.misc_info.lc_crt := FALSE;           {  ?  }
      t_info.misc_info.can_upscroll := TRUE;
      t_info.misc_info.can_downscroll := TRUE;
      END;      {  IFEND  }
    END;
  
  
  PROCEDURE sc_use_port { do_what:sc_choice; VAR t_port:sc_tx_port };

    BEGIN
    END;
  
  
  PROCEDURE sc_erase_to_eol { x,line:INTEGER };

    BEGIN
    GOTOXY ( x, line );
    WRITE ( OUTPUT, syscom ^ .crtctrl. eraseeol );
    END;
    
    
  PROCEDURE sc_left;

    BEGIN
    WRITE ( OUTPUT, syscom ^ . crtctrl . backspace );
    END;

    
  PROCEDURE sc_right;

    BEGIN
    WRITE ( OUTPUT, syscom ^ . crtctrl . ndfs );
    END;

    
  PROCEDURE sc_up;

    BEGIN
    WRITE ( OUTPUT, syscom ^ . crtctrl . rlf  );
    END;

    
  PROCEDURE sc_down;

    CONST
      ch_lf = 10;
    
    BEGIN
    WRITE ( OUTPUT, CHR ( ch_lf )  );
    END;

    
  PROCEDURE sc_getc_ch { VAR ch:CHAR; return_on_match:sc_chset };

    BEGIN
    END;

    
  PROCEDURE sc_clr_screen;

    BEGIN
    WRITE ( OUTPUT, syscom ^ .crtctrl.clearscreen );
    END;

    
  PROCEDURE sc_clr_line  { y:INTEGER };

    BEGIN
    GOTOXY ( 0, y );
    WRITE ( OUTPUT, syscom ^ . crtctrl . clearline );
    END;

    
  PROCEDURE sc_home;

    BEGIN
    WRITE ( OUTPUT, syscom ^ . crtctrl . home );
    END;

    
  PROCEDURE sc_eras_eos  { x,line:INTEGER };

    BEGIN
    GOTOXY ( x, line );
    WRITE ( OUTPUT, syscom ^ . crtctrl . eraseeos );
    END;

    
  PROCEDURE sc_goto_xy { x, line:INTEGER };

    BEGIN
    GOTOXY ( x, line );
    END;

    
  PROCEDURE sc_clr_cur_line;

    BEGIN
    WRITE ( OUTPUT, syscom ^ . crtctrl . clearline );
    END;

    
  FUNCTION  sc_find_x { :INTEGER };

    BEGIN
    END;

    
  FUNCTION  sc_find_y { :INTEGER };

    BEGIN
    END;

    
  FUNCTION  sc_scrn_has { what:sc_scrn_command } { :BOOLEAN };

    BEGIN
    sc_scrn_has := TRUE;
    END;

    
  FUNCTION  sc_has_key { what:sc_key_command } { :BOOLEAN };

    BEGIN
    END;

    
  FUNCTION  sc_map_crt_command { VAR k_ch:CHAR } { :sc_key_command };

    BEGIN
    END;

    
  FUNCTION  sc_prompt { line :sc_long_string; x_cursor,y_cursor,x_pos,
                 where:INTEGER; return_on_match:sc_chset; 
                 no_char_back:BOOLEAN; break_char:CHAR } { :CHAR };

    BEGIN
    END;

    
  FUNCTION sc_check_char { VAR buf:sc_window; VAR buf_index,bytes_left:INTEGER }
                   { :BOOLEAN };

    BEGIN
    END;

    
  FUNCTION space_wait { flush:BOOLEAN } {:BOOLEAN };

    BEGIN
    END;

    
  PROCEDURE sc_init;

    BEGIN
    END;
    
  END;
  
  
  BEGIN
  END.
  
  

========================================================================================
DOCUMENT :usus Folder:VOL29:terminal.text
========================================================================================

PROGRAM terminal;

{
29 Apr 84 gws  removed a unitwrite to suppress half duplex
29 Apr 84 gws  added $U directives to unit list
}

USES   screenops, 
       (*$U remunit.code*) remunit, 
       (*$U osmisc.code*) osmisc;

CONST
  version = 'C1';
  baud_rate = 300;
  convers_name = '*CONVERS';

  exit_command = 5;             {  CTL-E  }
  convers_command = 3;          {  CTL-C  }
  ch_esc = 27;


VAR
  c             : CHAR ;
  exit_requested:  BOOLEAN;
  to_convers:  BOOLEAN;
  keyboard:  INTERACTIVE;
  command_string:  STRING [ 255 ];

PROCEDURE initialize ;

  VAR
    havedial     : BOOLEAN ;
    haverem      : BOOLEAN ;
    result       : cr_baud_result ;
  
  BEGIN
  sc_clr_screen;
  GOTOXY ( 0, 0 );
  WRITE ( 'TERMINAL Version ', version, '.  Baud rate = ', baud_rate, '.' );
  GOTOXY ( 0, 3 );
  cr_comminit( cr_orig, CHR( 5 ), haverem, havedial ) ;
  IF NOT haverem THEN
    BEGIN
    WRITELN( ' REMOTE not supported in current environment.' ) ;
    WRITELN( ' Program is terminating.' ) ;
    EXIT( PROGRAM ) ;
    END ;

  cr_setcommunications(
                TRUE,
                TRUE,
                baud_rate,
                7,
                1,
                cr_orig,
                '',
                result ) ;

  WRITE ( 'Waiting for carrier...' );
  cr_answer ;
  GOTOXY ( 0, 3 );
  sc_clr_cur_line;
  
  END;          {  PROCEDURE initialize  }



BEGIN   {  PROGRAM terminal  }

initialize ;
exit_requested := FALSE;
to_convers := FALSE;

REPEAT
  IF cr_remstat THEN
    BEGIN
    c := cr_getrem;
    if c <> chr ( 10 ) then unitwrite ( 1,c,1 ); (* lsi-11 can't suppress lf *)
    (** UNITWRITE(1,c,1,,4+8 );*)(* use this line instead for most p-systems *)
    END
  ELSE
    BEGIN
    IF cr_kbstat THEN
      BEGIN
      c := cr_getkb ;
      IF ( c = CHR ( exit_command ) ) OR ( c = CHR ( convers_command )) THEN
        CASE ORD ( c ) OF
          exit_command:     exit_requested := TRUE;
          convers_command:  BEGIN
                            WRITE ( 'CONVERS command string: ');
                            READLN ( INPUT, command_string );
                            IF LENGTH ( command_string ) > 0 THEN
                              BEGIN
                              os_store_command ( convers_name, command_string );
                              exit_requested := TRUE;
                              to_convers := TRUE;
                              END;      {  IFEND  }
                            END;        {  CASE ITEM  }
          END  {  CASEND  }

      ELSE
        BEGIN
        (**UNITWRITE(1,c,1,,4+8 ) ;*)  (* don't want local echo - gws *)
        cr_putrem( c ) ;
        END ;
      END ;
    IF NOT cr_carrier THEN
      BEGIN
      WRITELN ;
      WRITELN('LOST CARRIER');
      WRITELN ;
      cr_commquit;
      EXIT ( PROGRAM )
      END;
  END;

UNTIL exit_requested;

sc_clr_screen;
cr_commquit ;

IF to_convers THEN
  os_exit_to_next;

END.


========================================================================================
DOCUMENT :usus Folder:VOL29:textio_ii0.text
========================================================================================

{$S+}
{$U-}
{               SEPARATE COMPILATION UNIT   -   TEXTIO
{
{                       Version for p-system II.0
{
{  This unit provides line-oriented text I/O to and from disk file.  The 
{  procedures in this file execute much faster than the corresponding
{  procedures built into the p-system.                                  }

{  Some of the following type declarations describe segment 0 of the 
{  p-system.  They are copyrighted by the University of California and
{  Softech Microsystems.                                                }

{  A note on error processing:  All callers of these procedures should
{  check IORESULT after the call.  A close look at the following code will
{  reveal that nothing much is done if an I/O error occurs.  This is due
{  to some peculiarities in the way that p-system version II.0 handles
{  (or rather, does not handle) EXIT's within separate procedures.          }

{$C (C) Copyright 1981, 1982, 1983, 1984 by John Dykstra.  All rights reserved}


PROGRAM pascalsystem;

TYPE
  window = PACKED ARRAY [ 1..1024 ] OF CHAR;
  windowp = ^ window;
  fib = ARRAY [ 1..290 ] OF INTEGER;
  fibp = ^ fib;
  closetype = ( cnormal, clock, cpurge, ccrunch );
  
PROCEDURE EXECERROR;
  FORWARD;
PROCEDURE FINIT(VAR F: FIB; WINDOW: WINDOWP; RECWORDS: INTEGER);
  FORWARD;
PROCEDURE FRESET(VAR F: FIB);
  FORWARD;
PROCEDURE FOPEN(VAR F: FIB; VAR FTITLE: STRING;
                FOPENOLD: BOOLEAN; JUNK: FIBP);
  FORWARD;
PROCEDURE FCLOSE(VAR F: FIB; FTYPE: CLOSETYPE);
  FORWARD;
PROCEDURE FGET(VAR F: FIB);
  FORWARD;
PROCEDURE FPUT(VAR F: FIB);
  FORWARD;
PROCEDURE XSEEK;
  FORWARD;
FUNCTION FEOF(VAR F: FIB): BOOLEAN;
  FORWARD;
FUNCTION FEOLN(VAR F: FIB): BOOLEAN;
  FORWARD;
PROCEDURE FREADINT(VAR F: FIB; VAR I: INTEGER);
  FORWARD;
PROCEDURE FWRITEINT(VAR F: FIB; I,RLENG: INTEGER);
  FORWARD;
PROCEDURE XREADREAL;
  FORWARD;
PROCEDURE XWRITEREAL;
  FORWARD;
PROCEDURE FREADCHAR(VAR F: FIB; VAR CH: CHAR);
  FORWARD;
PROCEDURE FWRITECHAR(VAR F: FIB; CH: CHAR; RLENG: INTEGER);
  FORWARD;
PROCEDURE FREADSTRING(VAR F: FIB; VAR S: STRING; SLENG: INTEGER);
  FORWARD;
PROCEDURE FWRITESTRING(VAR F: FIB; VAR S: STRING; RLENG: INTEGER);
  FORWARD;
PROCEDURE FWRITEBYTES(VAR F: FIB; VAR A: WINDOW; RLENG,ALENG: INTEGER);
  FORWARD;
PROCEDURE FREADLN(VAR F: FIB);
  FORWARD;
PROCEDURE FWRITELN(VAR F: FIB);
  FORWARD;
PROCEDURE SCONCAT(VAR DEST,SRC: STRING; DESTLENG: INTEGER);
  FORWARD;
PROCEDURE SINSERT(VAR SRC,DEST: STRING; DESTLENG,INSINX: INTEGER);
  FORWARD;
PROCEDURE SCOPY(VAR SRC,DEST: STRING; SRCINX,COPYLENG: INTEGER);
  FORWARD;
PROCEDURE SDELETE(VAR DEST: STRING; DELINX,DELLENG: INTEGER);
  FORWARD;
FUNCTION SPOS(VAR TARGET,SRC: STRING): INTEGER;
  FORWARD;
FUNCTION FBLOCKIO(VAR F: FIB; VAR A: WINDOW; I: INTEGER;
                  NBLOCKS,RBLOCK: INTEGER; DOREAD: BOOLEAN): INTEGER;
  FORWARD;
PROCEDURE FGOTOXY(X,Y: INTEGER);
  FORWARD;

SEPARATE UNIT textio;      
  
INTERFACE

TYPE
  io_fib = ARRAY [ 1..290 ] OF INTEGER;
  
  io_direction = ( io_input, io_output );
  
  io_file = RECORD
    osfib:  io_fib;
    direction:  io_direction;
    eof_flag:  BOOLEAN;
    buffer:  PACKED ARRAY [ 1..1024 ] OF CHAR;
    next_free:  1..1024;
    END;        {  RECEND  }
    
  io_string = STRING [ 255 ];
    

PROCEDURE io_open_file ( VAR file_blk:  io_file;
                         file_title:  STRING;
                         direction:  io_direction;
                         VAR successful:  BOOLEAN  )  ;

PROCEDURE io_close_file ( VAR file_blk:  io_file );

PROCEDURE io_write_line ( VAR file_blk:  io_file;  
                          data_string:  io_string );

PROCEDURE io_read_line ( VAR file_blk:  io_file;
                         VAR data_string:  io_string );

PROCEDURE io_seek_line ( VAR file_blk:  io_file;
                         desired_line:  INTEGER );

FUNCTION io_end_of_file ( VAR file_blk:  io_file ):  BOOLEAN;



IMPLEMENTATION
  
{$R+  Re-enable run-time checking (turned off by U- above)  }

PROCEDURE io_open_file {  ( VAR file_blk:  io_file;
                         file_title:  STRING;
                         direction:  io_direction;
                         successful:  BOOLEAN   )  };

CONST
    blk_size = 512;
    ch_nul = 0;
    
VAR
  complete_title:  STRING;
  
BEGIN           {  PROCEDURE io_open_file  }
finit ( file_blk.osfib, NIL, -1 );
complete_title := CONCAT ( file_title, '.TEXT' );
IF direction = io_output THEN
  BEGIN
  file_blk.direction := io_output;
  file_blk.eof_flag := TRUE;
  fopen ( file_blk.osfib, complete_title, FALSE, NIL  );
  successful := TRUE;
  FILLCHAR ( file_blk.buffer [ 1  ], 1025 , CHR ( ch_nul ) );
  IF fblockio ( file_blk.osfib, file_blk.buffer, 0, 2, -1, FALSE ) <> 2 THEN
    BEGIN
    successful := FALSE;
    END;
  file_blk.next_free := 1;
  END
ELSE
  BEGIN
  file_blk.direction := io_input;
  fopen ( file_blk.osfib, complete_title, TRUE, NIL  );
  
  IF IORESULT <> 0 THEN
    successful := FALSE
  ELSE
    BEGIN
    successful := TRUE;
  
    {  Insert code here to handle case of open of an empty file.  }
    
    file_blk.eof_flag := FALSE;
    IF ( fblockio ( file_blk.osfib, file_blk.buffer, 0, 2, 2, TRUE ) <> 2 )
     THEN
      BEGIN
      successful := FALSE;
      END;      {  IFEND  }
    file_blk.next_free := 1;
    END;        {  ELSEND  }
  END;
END;            {  PROCEDURE io_open_file  }


PROCEDURE io_close_file {  ( VAR file_blk:  io_file )  };

CONST
    blk_size = 512;
    ch_nul = 0;
    
  BEGIN         {  PROCEDURE io_close_file  }
  IF file_blk.direction = io_output THEN
    BEGIN
    FILLCHAR ( file_blk.buffer [ file_blk.next_free ], 1025 -
      file_blk.next_free, CHR ( ch_nul ) );
    IF fblockio ( file_blk.osfib, file_blk.buffer, 0, 2, -1, FALSE ) <> 2 THEN
      BEGIN
      END;
    fclose ( file_blk.osfib, clock );
    END
  ELSE
    BEGIN
    fclose ( file_blk.osfib, cnormal );
    END;
  END;          {  PROCEDURE io_close_file  }

PROCEDURE io_write_line { ( VAR file_blk:  io_file;  
                       data_string:  io_string )  };
  CONST
    blk_size = 512;
    ch_nul = 0;
    ch_cr = 13;
    
  VAR
    new_index:  1..1161;        {  1..blksize*2+max_line_length+1  }

  BEGIN
  new_index := file_blk.next_free + LENGTH ( data_string ) + 1;
  
  {  If the string would overflow the buffer, fill the remainder of
     the buffer with <NUL> characters and write it out.              }
     
  IF new_index >= 1025 THEN
    BEGIN
    FILLCHAR ( file_blk.buffer [ file_blk.next_free ], 1025 -
      file_blk.next_free, CHR ( ch_nul ) );
    IF fblockio ( file_blk.osfib, file_blk.buffer, 0, 2, -1, FALSE ) =  2 THEN
      BEGIN
      file_blk.next_free := 1;
      new_index := LENGTH ( data_string ) + 2;
      END;
    END;                {  IFEND  }
  
  {  Put the string into the output buffer, followed by a <CR>  }
  
  IF LENGTH ( data_string ) > 0 THEN
    MOVERIGHT ( data_string [ 1 ], file_blk.buffer [ file_blk.next_free ],
      LENGTH ( data_string ) );
  file_blk.buffer [ new_index - 1 ] := CHR ( ch_cr );
  file_blk.next_free := new_index
  END;          {  PROCEDURE io_write_line  }


PROCEDURE io_read_line {  ( VAR file_blk:  io_file;
                        VAR data_string:  io_string )  };

  CONST
    blk_size = 512;
    ch_nul = 0;
    ch_dle = 16;
    ch_cr = 13;
    
  VAR
    search_length:  1..1024;
    count:  0..255;
    index:  1..255;
    
  BEGIN         {  PROCEDURE read_line  }
  IF NOT file_blk.eof_flag THEN
    BEGIN
    IF file_blk.buffer [ file_blk.next_free ] = CHR ( ch_dle ) THEN
      BEGIN       {  get compressed blank count }
      count := ORD ( file_blk.buffer [ file_blk.next_free + 1 ] ) - 32;
      file_blk.next_free := file_blk.next_free + 2;
      END
    ELSE
      count := 0;
    search_length := 1025 - file_blk.next_free;
    {$R-}
    data_string [ 0 ] := CHR ( SCAN ( search_length, = CHR ( ch_cr ),
      file_blk.buffer [ file_blk.next_free ] )  + count );
    
    {  Check to see if we searched without finding a carriage return.  This
    {  can happen on the last page of a file created by the editor if no
    {  carriage return was typed after the last line.                   }
    
    IF ( ORD ( data_string [ 0 ] ) - count ) = search_length THEN
      BEGIN
      data_string [ 0 ] := CHR ( SCAN ( search_length, = CHR ( ch_nul ), 
        file_blk.buffer [ file_blk.next_free ] )  + count );
      END;      {  IFEND  }
      
    {$R+}
    
    IF ( LENGTH ( data_string ) - count ) > 0 THEN
      MOVERIGHT ( file_blk.buffer [ file_blk.next_free ], 
        data_string [ 1 + count ], LENGTH ( data_string ) - count );
    IF count > 0 THEN
      FILLCHAR ( data_string [ 1 ], count, ' ' );
    file_blk.next_free := file_blk.next_free + LENGTH ( data_string ) - count +
      1;
    IF file_blk.buffer [ file_blk.next_free ] = CHR ( ch_nul ) THEN
      BEGIN
      IF feof ( file_blk.osfib ) THEN
        file_blk.eof_flag := TRUE
      ELSE
        BEGIN
        IF ( fblockio ( file_blk.osfib, file_blk.buffer, 0, 2, -1, TRUE ) <>
         2 ) THEN
          BEGIN
          END;
        file_blk.next_free := 1;
        END;      {  ELSEND  }
      END;        {  IFEND  }
      
    END;        {  IFEND - at end of file  }
  END;          {  PROCEDURE io_read_line  }

{$P}

PROCEDURE io_seek_line {  ( VAR file_blk:  io_file;
                         desired_line:  INTEGER )  };

  CONST
    ch_cr = 13;
    ch_nul = 0;
    x_2_blk_size = 1024;
    
  VAR
    line_count:  INTEGER;
    
  BEGIN         {  PROCEDURE io_seek_line  }
  IF file_blk.direction <> io_input THEN
    BEGIN
    END;        {  IFEND  }
  IF fblockio ( file_blk.osfib, file_blk.buffer, 0, 2, 2, TRUE ) <> 2 THEN
    BEGIN                                   
    END;
  file_blk.eof_flag := FALSE;
  file_blk.next_free := 1;
  
  line_count := 1;
  WHILE line_count < desired_line DO
    BEGIN
    file_blk.next_free := file_blk.next_free + SCAN ( x_2_blk_size, 
      = CHR ( ch_cr ), file_blk.buffer [ file_blk.next_free ] ) + 1;
    IF file_blk.buffer [ file_blk.next_free ] = CHR ( ch_nul ) THEN
      BEGIN
      IF NOT feof ( file_blk.osfib ) THEN
        BEGIN
        IF fblockio ( file_blk.osfib, file_blk.buffer, 0, 2, -1, TRUE ) <> 
         2 THEN
          BEGIN
          END;    {  IFEND  }
        file_blk.next_free := 1;
        END;      {  IFEND  }
      END;      {  IFEND  }
    line_count := line_count + 1;
    END;        {  WHILEND  }
  END;          {  PROCEDURE io_seek_line  }


FUNCTION io_end_of_file {  ( VAR file_blk:  io_file ):  BOOLEAN  };

  BEGIN           {  FUNCTION io_end_of_file  }
  io_end_of_file := file_blk.eof_flag;
  END;            {  FUNCTION io_end_of_file  }



END;
  
  
BEGIN
END.
  
  

========================================================================================
DOCUMENT :usus Folder:VOL29:textio_iv.text
========================================================================================

UNIT textio; 
  
{$C Copyright 1982, 1983 by John Dykstra.  All rights reserved.  }


{               This is an implementation of the TEXTIO unit for
{               P-System Version Iv.03.                                 }


INTERFACE

TYPE
  
  io_direction = ( io_input, io_output );
  
  io_window = ARRAY [ 0..1 ] OF CHAR;
  
  io_file = RECORD
              os_fib:   RECORD
                          fwindow: ^ io_window;
                          feof,feoln: BOOLEAN;
                          fstate: (fjandw,fneedchar,fgotchar);
                          frecsize: INTEGER;
                          f_lock : SEMAPHORE;
                          fisopen: BOOLEAN; 
                          filler:  PACKED ARRAY [ 1..570 ] OF 0..255;
                          END;       {  RECEND  }
              os_window:  io_window;
              END;    {  RECEND  }
  
  io_string = STRING [ 255 ];
  

PROCEDURE io_open_file ( VAR file_blk:  io_file;
                         file_title:  STRING;
                         direction:  io_direction;
                         VAR successful:  BOOLEAN  )  ;

PROCEDURE io_close_file ( VAR file_blk:  io_file );

PROCEDURE io_write_line ( VAR file_blk:  io_file;
                          data_string:  io_string );

PROCEDURE io_read_line ( VAR file_blk:  io_file;
                         VAR data_string:  io_string );

PROCEDURE io_seek_line ( VAR file_blk:  io_file;
                         desired_line:  INTEGER );

FUNCTION io_end_of_file ( VAR file_blk:  io_file ):  BOOLEAN;

IMPLEMENTATION
  
{$R+}

{  The following procedure exists in the codefile only to force the compiler
{  to generate segment references to FILEOPS and PASCALIO.  }

PROCEDURE dummy;

  VAR
    dum_file:  TEXT;
    name:  STRING;
    
  BEGIN
  name := CONCAT ( '', '' );
  REWRITE ( dum_file, name );
  IF EOF ( OUTPUT ) THEN WRITELN;
  END;
  

PROCEDURE io_open_file {  ( VAR file_blk:  io_file;
                         file_title:  STRING;
                         direction:  io_direction;
                         successful:  BOOLEAN   )  };

  VAR
    complete_title:  STRING;
    
  BEGIN           {  PROCEDURE io_open_file  }
  
  {  Initialize the file block.  This operation is normally done by code
  {  emitted by the compiler at the start of the procedure in which the 
  {  file is declared, which calls routine finit in FILEIO.                 }
  
  { file_blk.os_fib.fwindow := ^ file_blk.os_window;  }
  
  PMACHINE (                    ^ file_blk.os_fib.fwindow,
                                ^ file_blk.os_window,
                {  STO  }       196 );
                
  file_blk.os_fib.fwindow ^ [ 1 ] := CHR ( 0 );
  file_blk.os_fib.feof := TRUE;
  file_blk.os_fib.feoln := TRUE;
  file_blk.os_fib.fstate := fjandw;
  file_blk.os_fib.frecsize := 1;
  SEMINIT ( file_blk.os_fib.flock, 1 );
  file_blk.os_fib.fisopen := FALSE;
  
  complete_title := CONCAT ( file_title, '.TEXT' );
  IF direction = io_output THEN
    BEGIN
    
    {  REWRITE ( file_blk.os_fib, complete_title );  }
    
    PMACHINE (  {  LDL 130  }           ^ file_blk.os_fib   ,
                {  SLLA 1  }            ^ complete_title,
                {  LDCN  }              152,
                {  SLDC 0  }            0,
                {  SLDC 0  }            0,
                {  SCXG FILEOPS 2  }    114, 2
                );
    
    successful := TRUE;
    END
  ELSE
    BEGIN
    
    {  RESET ( file_blk.os_fib, complete_title );  }
    PMACHINE (  {  LDL 130  }           ^ file_blk.os_fib,
                {  SLLA 1  }            ^ complete_title,
                {  LDCN  }              152,
                {  SLDC 1  }            1,
                {  SLDC 0  }            0,
                {  SCXG FILEOPS 2  }    114, 2
                );
    
    IF IORESULT <> 0 THEN
      successful := FALSE
    ELSE
      BEGIN
      successful := TRUE;
      END;        {  ELSEND  }
    END;
  END;            {  PROCEDURE io_open_file  }


PROCEDURE io_close_file {  ( VAR file_blk:  io_file )  };

  BEGIN         {  PROCEDURE io_close_file  }
  
  {  CLOSE ( file_blk.os_fib, LOCK );  }
  PMACHINE (    {  SLDL 1  }            32,
                {  SLDC 1  }            1,
                {  SCXG FILEOPS 3  }    114, 3
                );
                
  END;          {  PROCEDURE io_close_file  }

PROCEDURE io_write_line { ( VAR file_blk:  io_file; 
                       data_string:  io_string )  };
  BEGIN
  
  {  WRITELN ( file_blk.os_fib, data_string );  }
  PMACHINE (    {  LDL 131  }           135, 128, 131,
                {  SLLA 1  }            96,
                {  LDCN  }              152,
                {  SLDC 0  }            0,
                {  SCXG PASCALIO 11  }  116, 11,
                {  LDL 131  }           135, 128, 131,
                {  SCXG PASCALIO 14  }  116, 14
                );
  
  END;          {  PROCEDURE io_write_line  }


PROCEDURE io_read_line {  ( VAR file_blk:  io_file;
                        VAR data_string:  io_string )  };

  BEGIN         {  PROCEDURE read_line  }
  
  {  READLN ( file_blk.os_fib, data_string );  }
  PMACHINE (    {  SLDL 2  }            33,
                {  SLDL 1  }            32,
                {  LDCB 255  }          128, 255,
                {  SCXG PASCALIO 10 }   116, 10,
                {  SLDL 2  }            33,
                {  SCXG PASCALIO 13  }  116, 13);
  
  END;          {  PROCEDURE io_read_line  }

{$P}

PROCEDURE io_seek_line {  ( VAR file_blk:  io_file;
                         desired_line:  INTEGER )  };

  VAR
    line_count:  INTEGER;
  
  BEGIN         {  PROCEDURE io_seek_line  }
  
  {  RESET ( file_blk.os_fib );  }
  PMACHINE (    {  SLDL 3  }            ^ file_blk.os_fib,
                {  SCXG FILEOPS 6  }    114, 6
                );
  
  line_count := 1;
  WHILE line_count < desired_line DO
    BEGIN
    
    {  READLN ( file_blk.os_fib );  }
    PMACHINE (  { SLDL 3 }              ^ file_blk.os_fib,
                { SCXG PASCALIO 13 }    116, 13);
    
    line_count := line_count + 1;
    END;        {  WHILEND  }
  END;          {  PROCEDURE io_seek_line  }


FUNCTION io_end_of_file {  ( VAR file_blk:  io_file ):  BOOLEAN  };

  BEGIN           {  FUNCTION io_end_of_file  }
  
  {  io_end_of_file := EOF ( file_blk.os_fib );  }
  PMACHINE (    {  SLDC 0  }            00, 
                {  SLDL 1  }            32, 
                {  SCXG PASCALIO 5  }   116, 5, 
                {  SSTL 2  }            105 
                );
  
  END;            {  FUNCTION io_end_of_file  }


  END.

========================================================================================
DOCUMENT :usus Folder:VOL29:vol29.doc.text
========================================================================================

                                 USUS VOLUME 29
                               CONVERS and WEAVE
          A script driven communications package and a weaver's helper
             (a USUS REMUNIT is needed for CONVERS, see volume #15)

DRAW4A.TEXT       32  A simple pattern weave analyzer
DRAW4A.1.TEXT     34   an include file
DRAW8A.TEXT       32  A more complex pattern weave analyzer 
DRAW8A.1.TEXT     36   an include file
DRAWDN.DOC.TEXT   26  Documentation for the weaver's design package
OSMISC_II0.TEXT   12  Misc routines for CONVERS for version II.0
OSMISC_IV.TEXT    14    Same for IV.x
TEXTIO_II0.TEXT   26  Text file routines for CONVERS for version II.0
TEXTIO_IV.TEXT    14    Same for IV.x
SCRNOP_II0.TEXT   14  An ersatz SCREENOPS for II.0
CONV_TEST.TEXT     6  A test script 
CONVDOC.TEXT      70  Documentation for CONVERS
INSTALL.TEXT      26  Installation notes for CONVERS
CONVERS.TEXT     112  CONVERS itself
TERMINAL.TEXT      8  A dumb terminal emulator which can stand alone
VOL29.DOC.TEXT     6  You're reading it.
-----------------------------------------------------------------------------

Please transfer the text below to a disk label if you copy this volume.

    USUS Volume 29 -***- USUS Software Library
                         
   For not-for-profit use by USUS members only.
  May be used and distributed only according to 
      stated policy and the author's wishes.



This volume was assembled by George Schreyer from material collected by
the Library committee.

__________________________________________________________________________


========================================================================================
DOCUMENT :usus Folder:VOL2A:512.doc.text
========================================================================================


        DOCUMENTATION FOR THE 512-BYTE SECTOR SYSTEM

     This volume of two disks contains a sophisticated new BIOS (Basic Input-
Output System) as well as other supporting programs to implement a noticable 
speedup of disk access and a 23% greater disk capacity by the use of single-
density disks with 512-byte sectors accessed sequentially.  The use of double-
density and double-sided disks is also supported; these formats can be mixed 
among the disk drives of your system in a manner transparent to the UCSD 
operating system.  I have been running under this system for several months 
now and am aware of no bugs in its operation.

     You MUST have the following equipment and facilities in order to 
implement the 512-byte package:

     1) 8080, Z-80, or 8085 CPU.

     2) Western Digital-based Disk Controller (i.e., containing a 1771, 1773, 
1791, 1792, 1793, 1794, or 1795).  Adaptations to the code must be made if you 
do not have one of the Tarbell boards or the Delta disk controller.

     3) The source code to the 8080/Z-80 UCSD interpreter.

     4) The UCSD 8080/Z-80 system assembler (though the interpreter could be 
transported to CP/M and assembled with a CP/M-based assembler).

     5) Digital Research's MAC (Macroassembler) running under CP/M (though it 
is likely that a similar macroassembler, such as M-80 from Microsoft, would 
also work -- you'd have to check that the syntax for the macro package is 
compatible).

DESCRIPTION OF THE 512-BYTE SYSTEM

     The disk format used by the "standard" UCSD system on 8-inch disks is a
derivative of DEC's RT-11 format, and consists of 76 tracks (track 0 is
reserved for the booter and is not really used by the UCSD system once it's
going) of 26 128-byte sectors each.  Every other sector is read from or
written to, rather than sequential sectors being used, so that accessing a
track requires two disk revolutions.  The scheme is somewhat complicated in
that the first sector accessed on a new track is offset six sectors from the
first sector on the previous track, which allows a six-sector delay for head
settling when moving from track to track.  This arrangement speeds up disk
access (you don't have to wait a full disk revolution when moving to a new
track) and improves reliability.

     Thus, the sectors on the "standard" disk are read as follows:
TRACK 1:  1,3,5,...,23,25,2,4,...,24,26
TRACK 2:  7,9,11,...,3,5,8,10,...,4,6
TRACK 3:  13,15,17,...,9,11,14,16,...10,12
and so on.  Notice that the change from odd to even occurs when the logical 
first sector on the track is reached and differs from track to track, rather
than occuring at a fixed point.

     Those of us who use LSI-based disk controllers (until recently, 
universally one of the Western Digital 1770 or 1790 series) realized that we 
were not entirely happy with this disk format.  First, the UCSD operating 
system utilizes logical sectors ("blocks") that are 512 bytes long, something 
we could easily achieve physically on a floppy disk.  Second, our controllers 
were quite capable of reading sequential sectors.  Finally, there is no 
provision in the standard UCSD system for double-density 8-inch disks.

     So I have provided programs on these two disks that provide the user of
the UCSD system who has specific hardware (you MUST have a Z-80, 8080, or 8085
CPU as well as a Western Digital-based disk controller) with a sophisticated
UCSD-compatible BIOS that will utilize disks formatted with 128- or 512-byte
sectors in single density or 512-byte sectors double density.  This BIOS
contains most of the disk-handling and character-handling routines from the
CPMIO section of the UCSD interpreter, so that within the BIOS we have
complete control over the disk formats we use.  As a result, the BIOS on this
disk allows operation of the UCSD system in a manner that is TRANSPARENT to
the disk format currently in use, as well as allowing you to use disks of
different formats simultaneously.  The only gotchas in this system are two:
1) to change the density of the disks in a given disk drive requires rebooting
the system, since the density code is read only at boot time (otherwise the
drive will hang up), and 2) you can change the sector size of the single-
density disks in a drive only if another drive is accessed immediately before
the system tries to use the new disk you've just inserted.  This is because 
the BIOS checks sector size (if the disk drive has been initialized as single-
density) each time the system changes from one disk drive to another, and the 
system will hang up if it tries to read a 128-byte sector from a 512-byte disk 
or vice-versa without first checking sector size.

     The routines on these two disks include specific code for three S-100 
disk controller boards:  the Tarbell single- and double-density controllers 
and the Delta double-density controller.  (All the Western Digital-based 
double density controllers of which I am aware allow software-controlled 
switching between single- and double-density disks.)   The routines have 
already been altered by others for other Western-Digital-based controllers 
such as the S.D. Sales and the Cromemco; you must have an intimate familiarity 
with your disk controller and a reasonable facility with assembly language to 
be able to accomplish this conversion.  All the programs that form this system 
are amply documented, but there is no discussion of alternate controllers.

     The programs that make up the 512-byte sector system include the 
following:

     VOLUME 2A (normally UCSD format):

CPMIO.DOC.TEXT.  This file contains a discussion of the changes you must make 
to CPMIO.TEXT (part of the UCSD Z-80/8080 interpreter) to move most of the 
hardware-specific code out of the interpreter to the PBIOS (Pascal Basic Input-
Output System), as well as implementing a number of nifty extensions to the 
I/O Unit system, such as direct port I/O, a form of Peek and Poke, and a 
system clock.  Deletions are fully described, and insertions are listed.  For 
copyright reasons, we are NOT able to give you the full text of CPMIO.  Note 
that CPMIO has changed very little since the first 8080/Z-80 release, so the 
changes described will work for releases 1.4 to 2.0.  The new Adaptable System 
just released by SofTec is NOT supported by this CPMIO file, although you 
could probably adapt the files on the CP/M disk (Volume 2B) to work with that 
system, since the conversion routines required are a part of the Adaptable 
System.

     To implement the system, after making the necessary changes in CPMIO (and 
in the main INCLUDE file, as discussed in CPMIO.DOC), you must reassemble the
entire interpreter and save it until the new PBIOS is ready.


TIMING.DOC.TEXT contains a discussion of the timing considerations for the
512-byte system; you will find that when you run your disk system at its
maximum speed, you will discover all the subtle timing constraints you didn't
have to worry about when you were going slower.


     VOLUME 2B (normally CP/M format):

DFOCO.ASM and DFOCO.DOC.  FOCO stands for fast FOrmat and COpy routine, and it 
is the fastest such disk utility I have ever used, as well as being the most 
flexible.  The D stands for the Double-density version.  It is highly hardware
specific, including all the disk-access routines within the program for 
improved speed.  Conditional assemblies are available for the Delta and both 
Tarbell controller boards; adaptations for the Cromemco and other Western 
Digital-based controllers have not been terribly difficult but require careful 
attention to timing (best done by trying it out with your system).  DFOCO has 
been around in various versions for two years; the present one has been 
adapted to be compatible with the majority of disk hardware (you will note 
long delays after a disk home, for instance, required by some systems).  In 
its evolution, several routines that worked in the original version but turned 
out not to be useful now bomb if you try to use them, particularly the logical-
to-physical mapping utility or the facility that allows custom logical-to-
physical sector numbering.  However, anything you really need (sector size 
control, single or double density formatting and reading, the option of SKEW 
within a track, or sector-numbering OFFSET between tracks) works well.  Only 
one needed facility does not yet exist, which is the ability to copy one disk 
to another when the disks have 512-byte sectors.

     DFOCO is fairly well documented in DFOCO.DOC.  One aspect may not be 
noted there: if you wish a track-to-track sector numbering offset, you must 
use the compliment of the desired offset in your command (based on the number 
of sectors per track).  So, if you wish a one-sector offset between tracks, 
include the command "OFFSET 25" if a 26-sector track is used, or "OFFSET 7" if
an 8-sector track is required.  I have noted other assorted bugs in DFOCO 
which preclude its release as a proprietary program, but it is still head and 
shoulders above any other such program I have used.  Mostly, the bugs do not 
affect operation.  If you have trouble with DFOCO, particularly if you find 
and fix a bug, Sam Singer (it author) would like to hear from you.  His 
address is in the listing.


BOOTER.ASM.  This file contains a combination of a custom PBIOS and the
original UCSD PINIT file released with that system on the CP/M disk.  It has 
been greatly expanded and revised.  Sophisticated terminal-handling routines 
for an ADM-3A are provided, allowing you to use a "dumb terminal" with the 
fancy UCSD screen editor.  Basically, the combination of BOOTER, DFOCO, and 
PGEN should provide a full and sophisticated I/O system for the majority of 
UCSD users running an 8080/Z-80 system.

     
PGEN.ASM.  This file contains the original PGEN released with the UCSD system 
(to read and write the Track 0 booter and PBIOS on UCSD system disks).  In 
addition, it has the 1-sector booter already in the file and will read the 
format code of a newly formatted disk and preserve it correctly for use by the 
initialization section of BOOTER.  See the documentation within the listings 
of both BOOTER and PGEN for a more detailed discussion of what a format code 
is and how it is used.

     
MACRO.LIB.  This file is a sophisticated macro library developed by Sam Singer 
and used in the majority of his software (though not required by BOOTER or 
PGEN).  Specifically, it must be on the disk before you can assemble DFOCO or 
DUMP (a utility not related to the UCSD Pascal system).  MACRO.LIB is 
relatively specific to the Digital Research macroassembler, though it should 
not be hard to adopt for Microsoft's macroassembler.

     
SAMPLEIO.ASM.  This file contains the I/O portions of my EPROM-based monitor, 
and has examples of sophisticated drivers for a keyboard queue and a memory-
mapped video terminal.  It is well documented within the listing.

========================================================================================
DOCUMENT :usus Folder:VOL2A:acoustic.text
========================================================================================

; FOR MY ACOUSTIC COUPLER NO INITIALIZATION IS NECESSARY    

        .PROC   MODEMINIT,1 
        .PRIVATE RETADDR
        
        POP     HL
        LD      (RETADDR),HL
        POP     HL              ;POP ARGUMENT OFF STACK
        LD      HL,(RETADDR)
        JP      (HL)


; HANGUP FOR FOR AN ACOUSTIC COUPLER (WOULD YOU BELIEVE)     

        .PROC   HANGUP,0 
        .PRIVATE RETADDR
        POP     HL
        LD      (RETADDR),HL
        LD      HL,(RETADDR)
        JP      (HL)
        .END



========================================================================================
DOCUMENT :usus Folder:VOL2A:bootasm.text
========================================================================================

PROGRAM BOOTASM;
{ COPYRIGHT 1979 BY BARRY A. COLE
  THIS MAY BE FREELY DISTRIBUTED IF COPYRIGHT NOTICE RETAINED
  PURPOSE: LOAD ASSEMBLY MODULE TO LOW MEM AND XEQ
  INTENDED USE:  GENERATE CODE, CALL CPMRAM, SWITCH TO
                 CPM DISK, BOOT CPM, SAVE XX FILE  }
  TYPE BUFFER=PACKED ARRAY[0..20000] OF CHAR;
  VAR I,BLOKNUM,BYTES,LOC: INTEGER; BUF: BUFFER;
      F:FILE; TITLE: STRING[13];

PROCEDURE MOVRAM(FROMAD:BUFFER; TOAD,NBYTES:INTEGER); EXTERNAL;
  BEGIN
  WRITE('FILE NAME? '); READLN(TITLE);
  TITLE:=CONCAT(TITLE,'.CODE');
  RESET(F,TITLE); BYTES:=512*BLOCKREAD(F,BUF,20,1);
  WRITE('LOCATION? '); READLN(LOC); MOVRAM(BUF,LOC,BYTES);
  END.


========================================================================================
DOCUMENT :usus Folder:VOL2A:bootcpm.text
========================================================================================

        .PROC   BOOTCPM,0
; COPYRIGHT 1979 BY BARRY A. COLE
; THIS MAY BE FREELY DISTRIBUTED IF COPYRIGHT NOTICE RETAINED
; PURPOSE:       BOOT CPM FROM PASCAL
BOOTLOC .EQU    80H
TADDR   .EQU    40H
UNIT    .EQU    TADDR+2
SECTOR  .EQU    TADDR+3
TRACK   .EQU    TADDR+4
PROMPT  LD      DE,MSG
$100    LD      A,(DE)
        OR      A
        JR      Z,WAIT
        LD      C,A
        LD      L,0CH   ;OFFSET OF CONOUT IN BIOS
        CALL    BIOS
        INC     DE
        JR      $100
WAIT    LD      L,09H   ;OFFSET OF CONIN IN BIOS
        CALL    BIOS
        CP      0DH     ;CR?
        JR      NZ,PROMPT
        LD      HL,BOOTLOC
        LD      SP,HL
        LD      (TADDR),HL
        LD      A,0FEH  ;UNIT
        LD      (UNIT),A
        XOR     A
        LD      (TRACK),A
        INC     A
        LD      (SECTOR),A
        LD      L,27H   ;READ OFFSET INTO BIOS
        CALL    BIOS
        JP      BOOTLOC
BIOS    LD      A,(2)
        LD      H,A
        JP      (HL)
MSG     .BYTE   0DH,0AH
        .ASCII  "MOUNT CPM DISK IN A--THEN CR"
        .BYTE   0
        .END


========================================================================================
DOCUMENT :usus Folder:VOL2A:catalog.2.text
========================================================================================


     VOLUME 2A AND VOLUME 2B CATALOG, UCSD PASCAL USERS' GROUP LIBRARY

Machine-dependent software, 512-byte sequential sectors, and other goodies.*


Contents of Volume 2A:

512.DOC.TEXT.......Documentation for the 512-byte sectoring routines on 2A & 2B.
ACOUSTIC.TEXT......Use an acoustic modem with the Pascal Transfer Program (PTP).
BOOTASM.TEXT.......Assemble a file with the UCSD assembler and save it on CP/M.
BOOTCPM.TEXT.......Start up under UCSD and then boot up CP/M.
CPMIO.DOC.TEXT.....How to alter the CP/M interpreter for fancy disk action.
DCHAYES.IO.TEXT....Use a D.C. Hayes modem w/ the Pascal Transfer Program (PTP).
DELETE.LF.TEXT.....After transfering a textfile to UCSD, dummp ASCII linefeeds.
DFOCO.DOC.TEXT.....Documentation for DFOCO.ASM on Volume 2B.
H14.DRIVER.TEXT....Print out a text file on the Heath printer at full speed.
H19.DOC.TEXT.......Notes on optimizing the Heath terminal for UCSD Pascal.
H19.GOTOXY.........Textfile to compile your own GOTOXY for the Heath H19.
H19.MISCINFO.......SYSTEM.MISCINFO for the Heath terminal.
HAZEL.MISCINFO.....All ready SETUP for the Hazeltine terminal.
HEXOUT.TEXT........Pascal routine to print out integers in hexadecimal.
KBSTAT.TEXT........Yet another keyboard status routine, this time for PTP.TEXT.
LINECOUNTR.TEXT....Count the lines of a textfile.
MOVRAM.TEXT........Assembly-language routine for BOOTASM.
NEW.GOTOXY.TEXT....Good idea: let GOTOXY handle your CRT screen, too. Sample.
PE1100.GOTOXY......Textfile for GOTOXY for the Perkin-Elmer 1100 (Fox) terminal.
PERUSE.PG.TEXT.....Look over a textfile on your CRT one page at a time.
POLICY.DOC.TEXT....How the Users' Group Library runs.
PRIME1.TEXT........Pascal routine to find prime numbers.
PRIME2.TEXT........Another prime-number generator.
PTP.DOC.TEXT.......Documentation for the Pascal Transfer Program.
PTP.TEXT...........The Pascal Transfer Program.  Requires L2 editor to edit.
PUNCH.TAPE.TEXT....Send data from the UCSD system to the Heath paper punch.
RANDOMBYTE.TEXT....Assembly-language routine to access Z-80's R register.
READ.TAPE.TEXT.....Compliment of PUNCH.TAPE.
SHELLMSORT.TEXT....Sort a disk-based ASCII list.
SMARTREMOT.TEXT....Set up your machine as a smart remote terminal.
TIMING.DOC.TEXT....Notes on tuning your disk drives for fast 512-byte sectors.
TVI912C.GOTOXY.....Another GOTOXY text, this time for the TelVideo 912.
UPDATE.DOC.TEXT....Latest news on the UCSD Pascal Users' Group Library.
VOL.2B.DOC.TEXT....Documentation for the second disk of this volume.
VOLUME.2.TEXT......Notes on all the programs in Volume 2.
WRITER.DOC.TEXT....Documentation for WRITER.
WRITER.TEXT........A quick but nifty text or source file printer.

*    Note:  UCSD Pascal is a trademark of the Regents of the University of
California.  Please read the file POLICY.DOC.TEXT regarding the software on 
this disk.  All files are further documented in VOLUME.2.TEXT.


Volume 2B Contents:

     This disk is normally supplied in CP/M format, and includes my favorite
CP/M utilities.  For documentation see VOL.2B.DOC and DFOCO.DOC on Volume 2A.

BOOTER.ASM.......Sophisticated PINIT and *fast* PBIOS for Z-80 systems (can
                 modify easily for 8080) to run 128- & 512-byte sectored 
                 single density and 512-byte sectored double density disks
                 transparently.  Requires Z-80-compatible assembler
                 (extended Intel memnomics), Western Digital-based floppy
                 disk controller (eg, 1771, 179x series), and DFOCO-like
                 disk formatter.  May require attention to disk timing.
                 
CAT.COM..........Part of Ward Christenson's CP/M cataloging system.  From the
                 CP/M Users Group Volume 25.
               
CLEAN.COM........Nifty PIP-like utility to back up disk files; easy to use.

D.COM............Replacement for DIR that alphabetizes your directory & dis-
                 plays it in one screenful, along with filesize & room on disk.

DFOCO.ASM........Double/single density fast FOrmat and COpy, for disks of 
                 128, 256, or 512-byte sectors, single/double sided.  Requires
                 Digital Research's MAC (or equivalent) and MACRO.LIB.
                 All disk access is in the program for speed; Western Digital
                 chip on your floppy disk controller is a must.

DUMP.ASM.........Fancy file/track/sector hex & ASCII dumps and patches for
                 3740-type disks.  Accesses CP/M's logical groups directly.

FMAP.COM.........Makes a file of CP/M directory names.  Part of Ward 
                 Christenson's disk cataloging system.

MACRO.LIB........Fancy 8080 macro library for Digital Research's macroassem-
                 bler.  Used by DFOCO and DUMP.

PGEN.ASM.........Rewrite of UCSD's distribution PGEN to include booter and 
                 support multiple disk formats.
               
SAMPLEIO.ASM.....Sample UCSD-compatible I/O routines for console and memory-
                 mapped terminal.  VERY fancy.

SPAT.ASM.........Extensive updating of CP/M Users Group SPAT (Vol. 1), for
                 patching disks on systems with memory-mapped terminals. Nice.

UCAT.COM.........Update the CATalog; part of CP/M disk cataloging system.

UCSD2CPM.COM.....Object (Z-80 only) of program to transfer UCSD files to CP/M.
                 Runs under CP/M.

UCSD2CPM.MAC.....Source for program to transfer UCSD files to CP/M.  Requires
                 assembler that accepts Zilog memnomics (eg, Microsoft).
                 

========================================================================================
DOCUMENT :usus Folder:VOL2A:cpmio.doc.text
========================================================================================



     INSTRUCTIONS FOR CHANGING CPMIO.TEXT TO WORK WITH NEW PBIOS

     If copyright laws would allow, I would simply send you the new file.  
Alas, you'll have to do it yourself.

     CPMIO.TEXT has changed little since its first version with release 1.4.  
So the instructions to follow work with any version.  I assume you have
printed out CPMIO.TEXT for reference.  Also, note that many of the following
jump instructions are of the "JR" form, which produces Z-80 code.  If you have 
an 8080, you'll have to change them all to "JP".

     1)  First, add the following to the main file to be assembled (variously 
known as INCLUDE.TEXT, NOINCLUDE.TEXT, CPMINC.TEXT, and similar names), which 
you can identify because it is short and contains mostly a list of secondary 
files to be .INCLUDE'd or not, as well as some global variables.  Put it near
the beginning:

TIO     .EQU    0040H   ;or wherever in the first page you want to put it...
                        ; This table is the primary means of communication
                        ; between CPMIO and your BIOS, so make sure they both
                        ; look for it in the same place.
BIOS    .EQU    TIO     ;holds pointer to PBIOS in memory


     2) Next, edit the file CPMIO.TEXT to make the following changes:
a)      Change MAXU to equal 15, not 8.
b)      Add the following to the end of UNITBL:

        .WORD   ALLBIT          ; Unit 9: drive 2
        .WORD   DR2DRVR
        .WORD   ALLBIT          ; Unit 10: drive 3
        .WORD   DR3DRVR
        .WORD   0               ; Unit 11: RESERVED FOR ADDED DISK DRV
        .WORD   0
        .WORD   0               ; Unit 12: REVERVED FOR ADDED DISK DRV
        .WORD   0
        .WORD   INBIT|OUTBIT    ; Unit 13: PORT I/O
        .WORD   PORTDRVR
        .WORD   0               ; Unit 14: RESERVED
        .WORD   0
        .WORD   INBIT|OUTBIT    ; Unit 15: MEMORY I/O (PEEK AND POKE)
        .WORD   MEMDRVR

        
c)      Change the statement "UPTR  .EQU  TIO" to "UPTR  .EQU  BIOS".
Add after "URTN .EQU UASY+2": ERRFLG .EQU URTN+2 ;PBIOS IO error flag.

d)      Leave IOC and IOR unchanged.  Add the following line to GETU
just ahead of the third line, POP HL:
        LD      (ERRFLG),A      ;zero PBIOS error flag also.

e)      Leave BDIR, BLUN, and BOMIT unchanged.  Substitite the following
for the three lines at UBUSY:

UBUSY   POP     HL              ;POP OFF RETURN ADDR
        EX      (SP),HL         ;GET UNIT NO
        LD      A,L
        CP      03H
        JR      NC,$20
        LD      A,0CH           ;BIOS OFFSET FOR CONSOLE READY
        CALL    GOBIOS
        LD      L,A             ;TRUE OR FALSE TO L
        PUSH    HL
        JR      UOUT
$20     LD      HL,0
        PUSH    HL
UOUT    JP      BACK1
        
        
e)      The next part is unchanged through IOXIT.

f)      The rest of CPMIO.TEXT (the disk drivers, character drivers, BIOS
calling routines, and IOINIT) is deleted.  Save the disk drivers and character
drivers, since you will have to insert them where called for in PBIOS, first
translating to 8080 memnomics (although if you have the Microsoft assembler,
you can switch to Zilog memnomics in midstream with the ".Z80" pseudoop).
Replace the deleted text with the following:

;------------ Disk driver's ---------------

DR0DRVR LD      C,00H   ;select drive
        JR      DSK0
DR1DRVR LD      C,01H
        JR      DSK0
DR2DRVR LD      C,02H
        JR      DSK0
DR3DRVR LD      C,03H
DSK0    XOR     A               ;reg A=0  offset into bios
        CALL    GOBIOS
        LD      A,(ERRFLG)      ;check for error's from pbios
        LD      (IORSLT),A      ;if no error then ERRFLG and IORSLT =0
XIT     JP      IOXIT           ;done with disk IO

;---------- PORT I/O DRIVER --------------------

PORTDRVR
        LD      A,(UBLK)        ;LOW ORDER BYTE OF BLOCK NO IS THE PORT
        LD      HL,(UBUF)       ;POINTS TO MEMORY
        LD      C,A             ;MOVE PORT NO TO REG C
        LD      A,(UREQ)        ;INPUT OR OUTPUT ?
        CP      INBIT
        JR      NZ,$10
        INI                     ;Z-80 I/0 IS SO NICE
        JR      XIT             ;BYE
$10     OUTI                    ;DO OUTPUT
        JR      XIT             ;BYE
        

;---------- MEMORY I/O DRIVER ------------------

MEMDRVR
        LD      HL,(UBLK)       ;BLOCK NO IS MEMORY ADDR
        LD      BC,(UBUF)       ;POINTS TO MEMORY
        LD      A,(UREQ)        ;PEEK OR POKE ?
        CP      INBIT
        JR      NZ,$10
        LD      A,(HL)          ;PEEK
        LD      (BC),A
        JR      XIT             ;BYE
$10     LD      A,(BC)          ;POKE
        LD      (HL),A
        JR      XIT             ;BYE
        
;-------- BIOS linker ---------

GOBIOS  LD      HL,(BIOS)
        LD      D,0
        LD      E,A
        ADD     HL,DE           ;ADD OFFSET TO BIOS ADDR
        JP      (HL)
;
;---------- Character driver's -----------------

REMIN   LD      A,6
        JR      CHARIO
REMOUT  LD      A,9
        JR      CHARIO
CHDRVR  LD      A,3
CHARIO  CALL    GOBIOS
        JP      IOXIT
;-----------------------------------------------
        
; Booter stuff
        .ALIGN  2               ; must start on word boundary
INTEND
        
IOINIT
        LD      HL,(BIOS)
        LD      DE,-10 
        ADD     HL,DE
        LD      (MEMTOP),HL
        RET

        

@
========================================================================================
DOCUMENT :usus Folder:VOL2A:dchayes.io.text
========================================================================================

        .FUNC   SRECSTAT,0
        .PRIVATE RETADDR
STAT    .EQU    81H
RECRDY  .EQU    1H
        POP     HL
        LD      (RETADDR),HL
        POP     HL              ;CORRECT STACK
        POP     HL
        LD      HL,1            ;TRUE
        PUSH    HL
        IN      A,(STAT)          ;READ STATUS
        AND     RECRDY          ;CHECK SER READ STATUS
        JP      NZ,DONE         ;REC NOT RDY
        POP     HL
        LD      HL,0            ;FALSE
        PUSH    HL
DONE    LD      HL,(RETADDR)
        JP      (HL)


        .FUNC   SERREAD,0
        .PRIVATE RETADDR
STAT    .EQU    81H             ;STATUS PORT
DATA    .EQU    80H             ;DATA PORT

RECRDY  .EQU    01H             ;REC BUF FULL
        POP     HL
        LD      (RETADDR),HL    ;SAVE RET ADDR
        POP     HL              ;CORRECT STACK
        POP     HL              ;CORRECT STACK
WAIT:   IN      A,(STAT)        ;READ STATUS WORD
        AND     RECRDY          ;IS REC FULL
        JP      Z,WAIT
        IN      A,(DATA)
        AND     07FH            ;CLEAR PARITY BIT
        LD      L,A             ;STORE FOR RETURN
        PUSH    HL              ;RETURN VALUE ON STACK
        LD      HL,(RETADDR)
        JP      (HL)


        .PROC   SERWRITE,1
        .PRIVATE OUTC,RETADDR
STAT    .EQU    81H             ;STATUS PORT
DATA    .EQU    80H             ;DATA PORT

TRE     .EQU    02H             ;XMIT REG EMPTY    

        POP     HL
        LD      (RETADDR),HL
        POP     HL
        LD      (OUTC),HL
WAIT:   IN      A,(STAT)        ;GET STATUS
        AND     TRE             ;CK STATUS        
        JP      Z,WAIT          ;XMIT BUSY 
        LD      A,(OUTC)
        OUT     (DATA),A        ;SEND DATA
        LD      HL,(RETADDR)
        JP      (HL)


; THIS IS A VERY CRUDE D C HAYES INITIALIZER FOR THE PURPOSE
;OF CHECKING OUT THE REST OF THE PROGRAM CERTAINLY MUCH MORE
;WORK WILL NEED TO BE DONE ON THIS ROUTINE

        .PROC   MODEMINIT,1 
        .PRIVATE DIR,RETADDR
ANSW300 .EQU    83H             ;300 BAUD, ANSWER, OFFHOOK, XMITTER ON
ORIG300 .EQU    87H             ;300 BAUD, ORGINATE, OFFHOOK, XMITTER ON
WORD    .EQU    17H             ;8 BITS, NO PARITY, 1 START
RNGMASK .EQU    080H            ;RING DETECT MASK

STAT    .EQU    081H            ;STATUS PORT
MODE    .EQU    082H            ;MODE PORT
        
        POP     HL
        LD      (RETADDR),HL
        POP     HL
        LD      (DIR),HL
        LD      A,(DIR)
        AND     01H             ;LOOK AT ANS BIT
        OR      A
        JP      Z,ORIG
;ANSWER MODE
;WAIT FOR PHONE TO RING
RNGCK:  IN      A,(STAT)        ;READ STATUS
        AND     RNGMASK         ;ISOLATE RING DETECT
        JP      NZ,RNGCK        ;WAIT FOR RING LOW 
;SET ANSWER MODE AND ANSWER PHONE
        LD      A,ANSW300       ;SET MODEM TO ANSWER 300 BAUD AND OFFHOOK
        OUT     (MODE),A          
        JP      DONE
;ORIGINATE MODE
ORIG    LD      A,ORIG300       ;SET MODEM TO ORIGNATE 300 BAUD
        OUT     (MODE),A
DONE    LD      A,WORD          ;SET MODEM TO WORD FORMAT
        OUT     (STAT),A
        LD      HL,(RETADDR)
        JP      (HL)


; HANGUP FOR D C HAYES     

        .PROC   HANGUP,0 
        .PRIVATE RETADDR
MODE    .EQU    82H             ;MODE PORT
ONHOOK  .EQU    0H              ;ON HOOK

        POP     HL
        LD      (RETADDR),HL
        LD      A,ONHOOK
        OUT     (MODE),A
        LD      HL,(RETADDR)
        JP      (HL)
        .END



========================================================================================
DOCUMENT :usus Folder:VOL2A:delete.lf.text
========================================================================================

(*   Program Author:  Frank Monaco
                      679 Lowell Drive
                      Marietta, GA 30060
                      404-424-1460
                      
Rewritten for blockread/write and improved filename i/o by:
                Jim Gagne
                Datamed Research
                1433 Roscomare Road
                Los Angeles, CA 90024
                                                        *)
                                                        

program copyit;

CONST  MaxArraySizeLess1 = 4095;
       MaxBlocks         = 8;    {MaxArraySize DIV 512}
       Testing           = false;

TYPE  ArrayPointer = 0..MaxArraySizeLess1;

var
  InPointer, OutPointer, Insize, i, j: ArrayPointer;
  InfileName, OutfileName: string [30];
  typed: string;
  Infile, Outfile: file;
  OutChararray: PACKED ARRAY [0..511] OF char;
  InChararray: PACKED ARRAY [ArrayPointer] OF char;


PROCEDURE GetString (x,y, maxlength: integer);
VAR j, k: integer;
    Gotstring: boolean;
    bell: char;
BEGIN
  bell := CHR (7);
  Gotstring := false;
  REPEAT
    Gotoxy (x,y);
    FOR j := 1 TO maxlength DO write ('.');
    Gotoxy (x,y);
    Readln (typed);
    k := length (typed);
    IF k > maxlength
      THEN BEGIN
        Gotoxy (x,y);
        Write (' ':k);
        Gotoxy (0,23);
        Write (bell, 'You have entered too many characters in this line.  ',
               'Please try again.')
      END
      ELSE Gotstring := true
  UNTIL Gotstring;
  Gotoxy ((x+k),y);
  Write (' ':(maxlength - k));
  Gotoxy (2,22);
  Write (' ':70);
  Gotoxy (0,73);
  Write (' ':70)
END (*GetString*);


PROCEDURE GetFile;

VAR gotfn: boolean;
    bell, response: char;
  
BEGIN
  Bell := CHR (7);
  REPEAT
    Gotoxy (11,20);
    Write ('Please type the name of the desired input file.');
    Gotoxy (15,21);
    Write ('-->      ');
    Gotoxy (11,22);
    Write ('  (Or just press the <return> key if you wish to quit.)');
    Typed := '';
    GetString (20,21, 23);
    IF LENGTH (typed) = 0
      THEN BEGIN
        Gotoxy (11,23);
        Write ('Would you prefer to quit this program (Y/N)?     ');
        Read (Keyboard, response);
        Gotoxy (11,23);
        Write (' ':47);
        IF (Response = 'Y') OR (Response = 'y')
          THEN EXIT (Program)
      END
      ELSE BEGIN
        InfileName := Typed;
        (*$I-*)
        Reset (Infile, InfileName);
        IF IORESULT > 0 THEN Reset (Infile, CONCAT (InfileName, '.TEXT'));
        (*$I+*)
        Gotfn := IORESULT = 0;
        IF NOT Gotfn
          THEN BEGIN
            Gotoxy (0,23);
            Write (bell, '<<**** ERROR ****>>   ',
                   'Wrong volume or file name.  Type <space> to continue.');
            REPEAT Read (Keyboard, Response) UNTIL Response = ' ';
            Gotoxy (0,23);
            Write (' ':78)
          END
      END(*else*)
  UNTIL Gotfn;
END (*GetFile*);


  
begin
writeln('This program copies a textfile and removes extraneous line feeds.');
GETFILE;
Gotoxy (0,5);
Write ('What is the name of the file to which you wish to send the copy?');
GETSTRING (0,6, 23);
OutfileName := Typed;
Rewrite (Outfile, OutfileName);
OutPointer := 0;
IF testing THEN Write ('Outfile opened. ');
while not eof (Infile) do
   begin
     i := Blockread (Infile, InChararray, MaxBlocks);
     IF testing THEN Write ('Read ', i, ' blocks. ');
     IF i > 0
       THEN BEGIN
         Insize := (i * 512) - 1;
         IF testing THEN Writeln ('Insize = ', Insize);
         FOR InPointer := 0 TO Insize DO
           IF OutPointer < 512
             THEN BEGIN 
               IF InChararray [InPointer] <> CHR (10)
                 THEN BEGIN
                   OutChararray [OutPointer] := InChararray [InPointer];
                   OutPointer := succ (OutPointer)
                 END 
             END
             ELSE BEGIN
               i := Blockwrite (Outfile, OutChararray, 1);
               IF testing THEN Write ('Wrote ', i, ' blocks');
               IF InChararray [InPointer] <> CHR (10)
                 THEN BEGIN
                   OutChararray [0] := InChararray [InPointer];
                   OutPointer := 1;
                 END
                 ELSE OutPointer := 0
             END;
       END;
    end;
  IF OutPointer > 0 {Write out the last block,...}
    THEN BEGIN      {zeroing the unused bytes.}
      IF testing THEN Writeln ('Last OutPointer = ', OutPointer);
      IF OutPointer < 512 THEN FOR OutPointer := OutPointer TO 511
          DO OutChararray [OutPointer] := CHR (0);
      i := Blockwrite (Outfile, OutChararray, 1);
      IF testing THEN Write ('Last block written = ', i)
    END;
  close(Outfile,lock);
end.
  

========================================================================================
DOCUMENT :usus Folder:VOL2A:dfoco.doc.text
========================================================================================

			DFOCO DOCUMENTATION

						COPYRIGHT 1979
						BY S. J. SINGER


	DFOCO IS A FAST FORMAT AND COPY UTILITY FOR CP/M AND THE DELTA
FLOPPY DISK CONTROLLER. IT PERMITS FORMATTING DISKS IN BOTH THE STANDARD
IBM FORMAT AND A VARIETY OF NON STANDARD FORMATS AS WELL AS COPYING
ENTIRE DISKS OR ONLY SPECIFIED TRACKS FROM ONE DISK TO ANOTHER. 
IN ADDITION DFOCO PERMITS RELATIVELY EFFICIENT SINGLE DISK DRIVE COPIES
AND WILL COPY FORMATS AND DISPLAY THE FORMAT ON ANY SPECIFIED TRACK OF
ANY DISK. DFOCO SUPPORTS THE USE OF 4 DISK DRIVES.
	DFOCO MAY BE USED BOTH SINGLE DENSITY (FM) AND DOUBLE DENSITY (MFM).
THE OPERATIONS PERFORMED ARE IN GENERAL THE SAME BUT MAY BE SLIGHTLY
MORE LIMITED IN THE CASE OF DOUBLE DENSITY.
	DFOCO WILL RUN ON ANY 8080 OR Z-80 BASED SYSTEM USING THE DELTA
DISK CONTROLLER. THE PROGRAM USES CP/M FOR ALL CONSOLE INPUT-OUTPUT,
HOWEVER ALL DISK OPERATIONS ARE DIRECTLY EXECUTED BY DFOCO. THIS IS
NECESSARY BECAUSE DFOCO USES NON CP/M COMMANDS LIKE DISK TRACK READ,
AND DFOCO KEEPS CONTROL OF ALL DISK ERRORS TO FACILITATE ACCOUNTING
AND ERROR RECOVERY. IT SHOULD BE POSSIBLE HOWEVER, TO MODIFY DFOCO
TO RUN WITH ANY WESTERN DIGITAL 1771 OR 1791 BASED DISK CONTROLER.
THERE ARE TWO DIFFERENT VERSIONS OF DFOCO, ONE FOR STANDARD DISK DRIVES
AND THE OTHER FOR FAST SEEK PERSCI DRIVES. THE SINGLE DENSITY OPERATIONS
WILL BE DESCRIBED IN DETAIL FIRST.



	* * * * * * *  SINGLE DENSITY OPERATIONS  * * * * * * *


			VALIDATING DISKS

	IT IS OFTEN USEFUL TO BE ABLE TO TELL WHETHER OR NOT THE RECORDING
SURFACE OF A DISK IS COMPLETELY INTACT BEFORE USING THE DISK. THIS IS
ESPECIALLY TRUE SINCE WHILE CP/M ALWAYS CHECKS FOR READ ERRORS THERE IS
NO CHECK DONE FOR WRITE ERRORS. YOU WILL NOT KNOW YOU HAVE A BAD COPY
OF A FILE UNTIL THE FIRST TIME YOU TRY TO READ IT AGAIN WHICH MAY BE DAYS
OR EVEN MONTHS LATER.
	VALIDATING A DISK CONSISTS SIMPLY OF READING EACH SECTOR ON THE
DISK AND VERIFYING THAT THE CRC IS CORRECT. THIS SIMPLE PROCESS NOT ONLY
DETECTS PHYSICAL DAMAGE TO THE MEDIA SUCH AS SCRATCHES BUT ALSO FORMATTING
ERRORS SOMETIMES CAUSED BY NOISE TRANSIENTS, ERRORS WHICH WILL DISAPPEAR
UPON REFORMATTING THE DISK. THE FOLLOWING ARE EXAMPLES OF VALIDATION COMMANDS.

		VALID			(DEFAULT IS DRIVE A:)
		VALID C:
		VALID D:  RETRY 20

	THE PROGRAM WILL READ THE ENTIRE DISK AND REPORT ANY READ ERRORS.
IF A CRC ERROR OCCURS THE SECTOR WILL BE REREAD A MAXIMUM OF EITHER
THE NUMBER OF RETRYS SPECIFIED OR 10 TIMES IF NO RETRY COUNT IS ENTERED.
BOTH THE TOTAL NUMBER OF PERMANENT OR HARD ERROR AND RETRYS ARE REPORTED
AT THE END OF THE VALIDATION PROCESS.

		SUCCESSFUL VALIDATION DRIVE B:

			   OR

		PERMANENT READ ERROR TRACK 17 SECTOR 5 DRIVE B
		PERMANENT READ ERROR TRACK 42 SECTOR 19 DRIVE B
		THERE WERE 27 RETRYS AND 2 HARD ERRORS


			COPYING DISKS

	ALL OR PART OF A DISK MAY BE COPIED BETWEEN ANY SPECIFIED DRIVES.
THE FOLLOWING ARE EXAMPLES OF TYPICAL COPY COMMANDS:

	COPY				(DEFAULT IS A: TO B:)
	COPY A: TO C:
	COPY D:  TO  B:  RETRY 20
	COPY A: TO C: TRACK 0-1
	COPY B: TO D:  TRACK  3 - 20
	COPY A: TO A:			(SINGLE DISK TRANSFER)

DFOCO WILL RESPOND WITH AND ACKNOWLEDGMENT AND INSTRUCTIONS. FOR EXAMPLE:

	COPYING DISK A TO DISK B
	TYPE RETURN TO START

	THE PROGRAM WILL HALT AND WAIT FOR DISKS TO BE CHANGED ETC. AND
WILL BEGIN THE ACTUAL COPY OPERATION AFTER RETURN IS TYPED. IF YOU HAVE
MADE AN ERROR AND WISH TO REENTER THE COMMAND TYPE CONTROL C. THE COPY
OPERATION IS OPTIMIZED FOR SPEED. THE PROGRAM WILL DETERMINE THE MAXIMUM
AMOUNT OF MEMORY AVAILABLE AND READ WHOLE TRACKS FROM THE SOURCE DISK
UNTIL THE MEMORY IS FILLED. THEN THE ENTIRE MEMORY BUFFER IS WRITTEN
ONTO THE DESTINATION DISK. ALL TRANSFERS ARE VERIFIED. AS EACH TRACK IS
WRITTEN ONTO THE DESTINATION DISK IT IS READ BACK AND COMPARED BYTE BY
BYTE WITH THE CONTENTS OF THE MEMORY BUFFER. ANY ERRORS ARE REPORTED.
	IF THE SOURCE AND DESTINATION ARE THE SAME DFOCO WILL FIRST
RESPOND WITH A REQUEST THAT YOU VERIFY THAT YOU REALLY WANT TO PERFORM
A SINGLE DRIVE COPY. IF THE REQUEST IS ACKNOWLEDGED THE PROGRAM
WILL INDICATE WHICH DISK TO MOUNT IN THE SPECIFIED DRIVE.
AS WITH TWO DRIVE COPIES THE PROGRAM WILL FILL THE ENTIRE MEMORY BUFFER
WITH DATA. THE PROGRAM WILL THEN HALT AND NOTIFY YOU TO CHANGE DISKS.
THE NUMBER OF DISK CHANGES REQUIRED WILL OF COURSE DEPEND UPON THE
AMOUNT OF MEMORY AVAILABLE. WITH A 48K SYSTEM 8 SWAPS ARE REQUIRED, WITH
A 64K SYSTEM ONLY 6 ARE NEEDED.


		COPYING DISKS WITH DIFFERENT SIZE SECTORS

	DFOCO WILL COPY DISKS WITH SECTORS OF 128, 256 OR 512 BYTES. THE
PRIMARY LIMITATION OF THE PROGRAM IS THAT BOTH DISKS MUST HAVE THE SAME
SIZE SECTORS. THE SIZE SHOULD BE SPECIFIED IN THE COPY COMMAND.

		COPY A: TO C:  SIZE 256
		COPY B: TO A: SIZE 512
		COPY C:  TO D:  SIZE 128

	SPECIFYING A SECTOR SIZE OF OTHER THAN 128, 256 OR 512 BYTES WILL
GENERATE AN ERROR MESSAGE.



		ERROR HANDLING DURING COPY OPERATIONS


	ERROR HANDLING AND RECOVERY IS AN EXTREMELY INPORTANT PART OF ANY
DISK FILE MANAGEMENT SYSTEM. DFOCO IS DESIGNED TO PERMIT THE MAXIMUM RECOVERY
OF DATA FROM DAMAGED OR "CRASHED" DISKS. TWO TYPES OF ERRORS OCCUR DURING
COPY OPERATIONS, ERRORS IN READING FROM THE SOURCE DISK AND ERRORS WRITING
TO THE DESTINATION DISK. READ ERRORS ARE BY FAR THE MOST COMMON.
	IF A READ ERROR OCCURS DFOCO WILL ATTEMPT TO REREAD THE SECTOR 10
(OR RETRY) TIMES. IF THE READ ERROR PERSISTS ONE OF TWO ACTIONS MAY BE CHOSEN.
THE DEFAULT IS TO FILL THE SECTOR WITH E5H AND WRITE IT ON THE DESTINATION
DISK. THE OTHER CHOICE IS SIMPLY TO ACCEPT THE DATA AS READ IN AND WRITE IT ON
THE DESTINATION DISK. THIS IS THE NOFILL OPTION. NOFILL PERMITS THE MAXIMUM
DATA RECOVERY BUT REQUIRES CAREFUL INSPECTION OF THE SECTOR CAUSING THE ERROR
SINCE THE ERRORS MAY NOT BE OBVIOUS.
	WRITE ERRORS ARE HANDLED IN A SOMEWHAT DIFFERENT FASHION. SINCE THERE
IS USUALLY NO VALUABLE DATA ON THE DESTINATION DISK, THE NORMAL CHOICE IS TO
NOT PERMIT COPY OPERATIONS IF WRITE ERROR OCCUR. DFOCO WILL ATTEMPT TO WRITE
A SECTOR 10 (OR RETRY) TIMES. IF THE ERROR PERSISTS, DFOCO WILL STOP THE COPY
OPERATION AND VALIDATE THE DESTINATION DISK THUS REPORTING ALL BAD SECTORS.
IT IS POSSIBLE TO COPY IN THE PRESENCE OF WRITE ERRORS BY TURNING OFF THE
WRITE VERIFICATION, THE NOVERIFY OPTION. HOWEVER SINCE DISKS HAVE BECOME
RELATIVELY INEXPENSIVE THIS OPTION IS PROBABLY UNWISE EXCEPT IN VERY SPECIAL
CASES. SOME EXAMPLES ARE AS FOLLOWS:

	COPY B: TO C: NOFILL   RETRY 25
	COPY A: TO B: TRACK 0-5 NOVERIFY
	COPY D: TO A: NOVERIFY NOFILL 


			DISK FORMATTING AND MAPPING

	THE STANDARD IBM FORMAT FOR 8 INCH FLOPPY DISKS IS GIVEN IN THE
WESTERN DIGITAL DOCUMENTATION FOR THE 1791 DISK CONROLLER CHIP AND IN VARIOUS
IBM DOCUMENTS. THE USUAL FORMAT IS "SOFT SECTORED". THIS MEANS ESSENTIALLY
THAT THE TRACK AND SECTOR NUMBERS ARE ACTUALLY WRITTEN ON THE DISK AS DATA
RATHER THAN BEING DETERMINED BY THE PRESENCE OF PHYSICAL INDICATORS SUCH AS
HOLES IN THE DISK. FORMATTING A DISK CONSISTS OF WRITING BOTH THE TRACK
AND SECTOR NUMBERS AS WELL AS CLOCKING INFORMATION FOR THE CONTROLER ON THE
DISK. IT IS IMPORTANT TO REMEMBER THAT A "BLANK" DISK IS BY NO MEANS REALLY
BLANK. RATHER IT CONTAINS A GREAT DEAL OF FORMATTING INFORMATION WITHOUT
WHICH THE CONTROLER IS TOTALLY UNABLE TO READ IT.
	BECAUSE OF THIS "SOFT SECTORING" IT IS SOMETIMES POSSIBLE AND OFTEN
USEFUL TO CHANGE THE FORMAT TO ALLOW INCREASED AMOUNTS OF DATA TO BE WRITTEN
ON THE DISK OR HIGHER SPEED OF OPERATION. THERE ARE TWO POSSIBLE CHANGES
THAT ARE USEFUL, CHANGING THE SIZE OF THE SECTORS OR CHANGING THEIR ORDERING.
	THIS VERSION OF DFOCO SUPPORTS THREE DIFFERENT SECTOR SIZES USING
THE "IBM" SOFT SECTOR FORMAT. SECTORS MAY BE FORMATED WITH THE NORMAL
26 SECTORS OF 128 BYTES OR WITH 16 SECTORS OF 256 BYTES OR 8 SECTORS OF
512 BYTES EACH. USING 256 OR 512 BYTE SECTORS ALLOWS APPROXIMATELY
20% MORE DATA TO BE WRITTEN ON A SINGLE DISK, HOWEVER THERE ARE AT PRESENT
FEW PROGRAMS WHICH WILL SUPPORT THE USE OF LARGER SECTORS.
DFOCO ALSO SUPPORTS A WIDE VARIETY OF SECTOR ORDERINGS.
	THE DESIGN OF CP/M DATES FROM A TIME WHEN DISK CONTROLLERS WERE
QUITE SLOW AND COMPUTER MEMORIES SMALL AND VERY COSTLY. SMALL MEMORIES 
DICTATED SMALL SECTOR SIZES ON DISKS SINCE THE LARGER THE SECTORS THE LARGER
THE MEMORY BUFFERS REQUIRED. SLOW CONTROLERS MEANT THAT HAVING READ A SECTOR
FROM THE DISK IT WAS NECESSARY TO WAIT BEFORE ANOTHER SECTOR COULD BE READ.
DELAYS OF 5 SECTOR TIMES (ABOUT 25 MSEC) WERE COMMON. THUS CP/M IS SET UP
TO READ EVERY 6TH SECTOR AROUND THE DISK. THIS STRATEGY UNFORTUNATELY IS
FAR FROM OPTIMAL FOR PRESENT DAY CONTROLLERS WHICH CAN READ CONSECUTIVE
SECTORS FROM A DISK WITH EASE. NOTE THAT DFOCO WHICH READS AN ENTIRE TRACK
IN A SINGLE DISK REVOLUTION IS OVER 5 TIMES AS FAST AS PIP. UNFORTUNATELY
CP/M STANDARD SYSTEM PROGRAMS SUCH AS PIP AND THE ASSEMBLER CAN ONLY BE
SPEEDED UP A SMALL AMOUNT, ABOUT 20 PER CENT, BY CHANGING DISK FORMATS ALONE.
HOWEVER, NEW PROGRAMS WRITTEN TO TAKE ADVANTAGE OF FASTER CONTROLERS CAN
BE SPEEDED UP A GREAT DEAL MORE.


			MAPPING DISK FORMATS

	WHEN EXPERIMENTING WITH NONSTANDARD FORMATS IT IS OFTEN VERY USEFUL
TO BE ABLE TO READ AND DISPLAY THE ACTUAL DISK FORMAT. YOU CAN'T NECECESSARILY
TELL WHATS ON A DISK BY LOOKING AT THE LABEL. THE MAP COMMAND READS THE FORMAT
FROM A SINGLE TRACK ON A SPECIFIED DISK AND DISPLAYS IT. THERE ARE 26 SECTORS
PER TRACK IN THE STANDARD IBM FORMAT WHICH ARE NUMBERED IN SEQUENTIAL ORDER.
TO DISPLAY THE SECTOR ORDERING TYPE:

		MAP			(DEFAULT IS TRACK 0 DRIVE A:)
		MAP C: TRACK 76

	THE PROGRAM WILL READ THE SPECIFIED TRACK AND DISPLAY THE PHYSICAL TO
LOGICAL SECTOR MAPPING. THE PHYSICAL SECTORS STARTING FROM THE SINGLE INDEX
HOLE IN THE DISK ARE SIMPLY NUMBERED 1 THRU 26. THE CORRESPONDING LOGICAL
SECTORS ACTUALLY WRITTEN ON THE DISK ARE DISPLAYED BESIDE THE PHYSICAL SECTOR
NUMBER.  FOR DISKS FORMATTED WITH LESS THAN 26 SECTORS, THE UNUSED LOGICAL
SECTOR NUMBERS DISPLAY AS A '-'.
	OCCASIONALLY DFOCO WILL DISPLAY OBVIOUSLY INCORRECT MAPPING DATA, FOR
EXAMPLE TRACK 404 SECTOR NUMBER 201. THIS MEANS THE FORMAT ON THE DISK IS
INCORRECT. THE DISK CONTROLLER WILL OFTEN READ THESE DISKS CORRECTLY
BUT IT IS USUALLY A GOOD IDEA TO COPY THE DATA TO A CORRECTLY FORMATTED DISK.
FORMATTING PROBLEMS OF THIS TYPE OFTEN SHOW UP WHEN YOU ATTEMPT TO READ
DISKS PRODUCED ON ANOTHER COMPUTER SYSTEM. IF THE HEAD ALLIGNMENT IF ONLY
SLIGHTLY DIFFERENT FROM YOURS YOU MAY GET MAPPING ERRORS EVEN THOUGH YOU ARE
USUALLY ABLE TO READ THE DATA CORRECTLY.


			FORMATTING DISKS


	DFOCO PERMITS FORMATTING DISKS ON ANY DRIVE SUPPORTED BY CP/M. EITHER
THE ENTIRE DISK OR SPECIFIED TRACKS MAY BE FORMATTED. IT IS EVEN POSSIBLE
TO WRITE DIFFERENT FORMATS ON DIFFERENT TRACKS OF THE SAME DISK. 

			STANDARD FORMAT


	TO WRITE THE STANDARD IBM FORMAT ON A DISK TYPE

		FORMAT				(DEFAULT IS DRIVE A)
		FORMAT B: 
		FORMAT C:  TRACK  20-40

	THE PROGRAM WILL HALT AND THEN RESPOND WITH:

		STANDARD IBM 3740 FORMAT

		INSERT DISK TO BE FORMATTED IN DRIVE A
		TYPE CARRIAGE RETURN

	NON STANDARD FORMATS MAY HAVE ALMOST ANY FORM YOU SPECIFY. THE FIRST
VARIATION IS TO OFFSET THE SAME FORMAT FROM TRACK TO TRACK. THIS IS USEFUL
TO COMPENSATE FOR THE TIME IT TAKES TO STEP THE HEAD FROM ONE TRACK TO
ANOTHER AND IS ONE OF THE TECHNIQUES USED IN DFOCO TO INCREASE THE COPY SPEED.
THE FOLLOWING IS AN EXAMPLE OF TRACK OFFSETTING:

		FORMAT B: OFFSET 5

THIS RESULTS IN THE FOLLOWING FORMAT ON THE DISK

		TRACK 0		TRACK 1		TRACK 2		ETC.

SECTOR		  1		  6		  11
SECTOR		  2		  7		  12
SECTOR		  3		  8		  13
SECTOR		  4		  9 		  14

	A SECOND FORMATTING VARIATION IS TO SKEW THE SECTORS BY A CONSTANT
AMOUNT. THIS CAN BE SPECIFIED AS FOLLOWS.

		FORMAT B: SKEW 3

	THIS WILL RESULT IN A DISPLAY OF THE PHYSICAL TO LOGICAL SECTOR MAPPING
AND PERMIT CHANGING THE SPECIFICATIONS BEFORE WRITING THE FORMAT ON THE DISK.

	PHYSICAL	LOGICAL		PHYSICAL	LOGICAL
	 SECTOR		SECTOR		 SECTOR		SECTOR
	   1		  1		   14		  14
	   2		  4		   15		  17
	   3		  7		   16		  20
	   4		 10		   17		  23
	   5		 13		   18		  26
	   6		 16		   19		   3
	   7		 19		   20		   6
	   8		 22		   21		   9
	   9		 25		   22		  12
	  10		  2		   23		  15
	  11		  5	  	   24		  18
	  12		  8		   25		  21
	  13		 11		   26		  24

TYPE RETURN TO FORMAT, SECTOR NO TO CORRECT

	TYPING A SECTOR NUMBER ALLOWS THE LOGICAL SECTOR NUMBER TO BE CHANGED.
BEFORE USING A SECTOR NUMBER IT MUST BE FIRST SET TO ZERO SINCE THE PROGRAM
CHECKS AND DOES NOT PERMIT TWO SECTORS WITH THE SAME NUMBER. THE SECTOR MAPPING
IS REDISPLAYED FOR VERIFICATION AFTER EACH CHANGE.
	THE FINAL FORMATTING OPTION IS SIMPLY TO TYPE IN THE PHYSICAL TO LOGICAL
SECTOR MAPPING FOR EACH SECTOR. TO SELECT THIS OPTION TYPE:

		SPECIAL FORMAT A:

	THE PROGRAM WILL RESPOND BY DISPLAYING EACH PHYSICAL SECTOR NUMBER
AND WAITING FOR THE CORRESPONDING LOGICAL SECTOR NUMBER TO BE ENTERED. AGAIN
THE PROGRAM CHECKS THE SECTOR NUMBERS AS ENTERED AND WILL NOT ALLOW THE SAME
SECTOR NUMBER TO BE USED TWICE.
	NOTE THAT THE VARIOUS OPTIONS MAY BE COMBINED IF DESIRED.


		SPECIAL FORMAT B: TRACK 0-1
		FORMAT C: OFFSET 6 SKEW 3 TRACK 10-76

	IT IS EVEN POSSIBLE TO COPY THE FORMAT FROM ONE DISK TO ANOTHER

		COPY FORMAT A: TO B:
		COPY FORMAT B: TO D:  TRACK 10



		FORMATTING WITH DIFFERENT SIZE SECTORS

	THE DEFAULT SECTOR SIZE GENERATED BY DFOCO IS 128 BYTES, HOWEVER THE
PROGRAM WILL ALSO FORMAT TRACKS WITH 16 SECTORS OF 256 BYTES OR 8 SECTORS OF
512 BYTES. THE SECTOR SIZE IS SPECIFIED BY THE SIZE PARAMETER.

		FORMAT B: SIZE 512
		SPECIAL FORMAT A:  SIZE 256
		FORMAT C: OFFSET 2 SIZE 512

	CAUTION MUST BE USED WITH THE SPECIAL FORMAT OPTION SINCE DFOCO WILL
ALLOW SECTOR NUMBERS GREATER THAN THE NUMBER OF SECTORS ON A TRACK. THE
1791 WILL ACTUALLY READ SECTORS NUMBERED IN THIS FASHION. FOR EXAMPLE
A TRACK MAY BE FORMATTED WITH 8 512 BYTE SECTORS NUMBERED 11 THRU 18, HOWEVER
DISKS WRITTEN IN THIS FASHION MAY NOT VALIDATE CORRECTLY. IT IS ALSO POSSIBLE
TO FORMAT A DISK WITH DIFFERENT SIZE SECTORS ON DIFFERENT TRACKS. AGAIN, DISKS
WRITTEN IN THIS FASHION MAY NOT VALIDATE CORRECTLY.
	REGARDLESS OF THE SECTOR SIZE AND MAPPING CHOSEN, TRACK 0 OF THE
DISK IS ALWAYS WRITTEN IN THE STANDARD IBM 3740 FORMAT. THIS IS DONE TO
FACILITATE IDENTIFICATION OF THE DISK FORMAT BY A PROGRAM. READ AND WRITE
OPERATIONS TO A DISK MAY ACTUALLY BE IMPOSSIBLE AND "HANG" THE CONTROLLER
IF THE PROGRAM EXPECTS A FORMAT THAT IS NOT PRESENT. THIS IS ESPECIALLY
TRUE IF THE INCORRECT DENSITY IS SELECTED.


			PROGRAM TIMING

	THE FOLLOWING TIMING FIGURES ARE TYPICAL OF A 64K SYSTEM AND WILL BE
SLIGHTLY HIGHER FOR SMALLER SYSTEMS. THE COPY TIMINGS VARY WITH DISK FORMATS.
IF THE FORMAT IS NON STANDARD BUT THE SAME ON BOTH DISKS THE TIMES ARE THE
SAME AS FOR STANDARD FORMATS BUT IF THE SECTOR FORMATS ARE DIFFERENT ON THE
TWO DISKS THE COPY TIMES WILL BE INCREASED. THE FOLLOWING TIMINGS ARE FOR
SINGLE DENSITY ONLY.


		VALIDATING		17 SEC
		FORMATTING		43 SEC (INCLUDES VALIDATION)

		COPY SAME FORMAT	46 SEC
		COPY DIFFERENT FORMAT	90 SEC AVERAGE
				       300 SEC WORST CASE

	IF THE FORMAT IS DIFFERENT ON DIFFERENT TRACKS OF A DISK IT MAY BE
POSSIBLE TO INCREASE COPY SPEED WITH THE USING OPTION. SINCE A WRITE OPERATION
TAKES TWICE AS LONG AS A READ OPERATION THE PROGRAM CAN OPTIMIZE THE COPY
BY READING THE TRACK FORMAT FROM THE DESTINATION DISK AND USING IT TO
CONTROL READING AND WRITING. A SAMPLE COPY WITH THIS OPTION IS

		COPY A: TO B: USING 3

	THIS CAUSES TRACK 3 TO BE READ FROM THE DESTINATION DISK AND USED TO
CONTROL THE COPY OPERATION. THIS CAN OFTEN DOUBLE THE COPY SPEED IF THE FORMATS
ARE DIFFERENT ON THE TWO DISKS.


	* * * * * * *  DOUBLE DENSITY OPERATIONS  * * * * * * *


	WITH A FEW EXCEPTIONS THE SAME OPERATIONS ARE AVAILABLE DOUBLE
DENSITY AS ARE AVAILABLE SINGLE DENSITY. DOUBLE DENSITY MAY BE SELECTED EITHER
BY ADDING A D TO THE DESIRED COMMAND OR BY PLACING THE CODE DD ANYWHERE
ON THE COMMAND LINE. SOME EXAMPLES:

		DVALID B:
		VALID A: SIZE 512  DD

		DCOPY A: TO B:  SIZE 256
		DCOPY
		COPY B: TO D: DD SIZE 512

		DFORMAT
		DFORMAT B: SIZE 512
		FORMAT C: SIZE 256  DD

	THE FOLLOWING EXCEPTIONS SHOULD BE NOTED. THE MAPPING FUNCTION
IS NOT AVAILABLE DOUBLE DENSITY. IT IS DIFFICULT TO DO AN ACCURATE
TRACK READ OF THE FORMAT ON A DOUBLE DENSITY DISK DUE TO THE FORMAT USED.
EVEN WHERE NOT SPECIFICALLY PROHIBITED, IT IS RECOMMENDED THAT OPERATIONS
REQUIRING TRACK READ SUCH AS COPY FORMAT OR COPY USING NOT BE ATTEMPED.
PROBLEMS IN READING THE FORMAT FROM DISKS MAY CAUSE UNPREDICTABLE RESULTS.
	THE SPECIAL FORMAT FUNCTION IS NOT AVAILABLE DOUBLE DENSITY.
THE STANDARD FORMATS PROVIDED BY THE PROGRAM DOUBLE DENSITY ARE AS FOLLOWS:

	128 BYTE SECTORS -  

	TRACK 0 STANDARD 3740 FORMAT SINGLE DENSITY. TRACKS 1-76 HAVE 51
SECTORS WRITTEN IN A 6 TO 1 INTERLACE PATTERN FOR USE WITH CP/M VERS 1.4.
THE SECTOR ORDER IS AS FILLOWS:

    1,18,35,10,27,44,2,19,36,11,28,45,3,20,37,12,29,46,4,21,38,13,30,47,5,
    22,39,14,31,48,6,23,40,15,32,49,7,24,41,16,33,50,8,25,42,17,34,51,9,26,43

	ONE ADDITIONAL FEATURE IS PROVIDED FOR USE WITH CP/M. THE LAST BYTE
OF DATA ON TRACK ZERO SECTOR ONE IS WRITTEN WITH A SPECIAL FLAG BYTE TO
INDICATE THE FORMAT OF THE REST OF THE DISK. THE CODES ARE

		E5	SINGLE DENSITY  (E5 IS THE STANDARD FILL CHAR)
		DD	DOUBLE DENSITY 51 SECTORS PER TRACK
		4D	"QUAD" DOUBLE DENSITY DOUBLE SIDED DISK
	TO INSERT THE "QUAD" CODE INTO SECTOR ONE OF A 128 BYTE SECTOR DISK 
THE FOLLOWING EXAMPLES MAY BE USED:

		DFORMAT C:  QUAD
		DFORMAT A:  QUAD

	256 BYTE SECTORS -

	DOUBLE DENSITY DISKS FORMATTED WITH 256 BYTE SECTORS ARE IN STANDARD
IBM FORMAT. 26 SECTORS OF 256 BYTES. TRACK ZERO IS SINGLE DENSITY 3740 FORMAT.
THERE IS NO FLAG BYTE IN SECTOR 1 OF TRACK ZERO

	512 BYTE SECTORS -

	DOUBLE DENSITY DISKS FORMATTED WITH 512 BYTE SECTORS HAVE 16 SECTORS
PER TRACK. TRACK ZERO IS STANDARD 3740 FORMAT. NO FLAG BYTE ON TRACK ZERO

	THE OFFSET AND SKEW FUNCTIONS WORK AS BEFORE ALTHOUGH THE EFFECT OF
FURTHER SKEWING THE ALREADY INTERLACED 128 BYTE PATTERN MAY BE CONFUSING.

	COPYING DISKS DOUBLE DENSITY IS ALMOST EXACTLY THE SAME AS COPYING
THEM SINGLE DENSITY. TWO SIMPLE RULES MUST BE OBSERVED.

	1. BOTH DISKS MUST BE OF THE SAME DENSITY.
	2. BOTH DISKS MUST HAVE THE SAME SECTOR SIZE.

A VIOLATION OF THES RULES MAY CAUSE THE CONTROLLER TO "HANG" REQUIRING THE
COMPUTER TO BE RESET TO RECOVER.

	IT WILL BE NOTED THAT COPY OPERATIONS ON DOUBLE DENSITY DISKS HAVING
51 SECTORS IS MUCH SLOWER THAN OTHER COPY OPERATIONS. THIS IS BECAUSE THE
SECTORS ON THESE DISKS ARE WRITTEN SO CLOSE TOGETHER THAT THE 1791 CONTROLLER
DOES NOT HAVE TIME TO WRITE CONSECUTIVE SECTORS ALTHOUGH IT IS ABLE TO
READ CONSECUTIVE SECTORS IN THIS FORMAT. COPY OPERATIONS ON DISKS IN THIS
FORMAT READ AND WRITE EVERY OTHER SECTOR THUS REQUIRING TWICE AS MANY DISK
REVOLUTIONS AND TWICE THE TIME.
	DOUBLE SIDED OR "QUAD" DISKS ARE NOT AUTOMATICALLY COPIED BY DFOCO
IN A SINGLE OPERATION BUT REQUIRE TWO COPY OPERATIONS. TO COPY A "QUAD"
DISK YOU MIGHT TYPE:

		DCOPY A: TO C:		(COPY THE FRONT SIDE)
		DCOPY B: TO D:		(COPY THE BACK SIDE)

	A SINGLE "QUAD" COPY OPERATION WILL BE ADDED TO DFOCO LATER.


========================================================================================
DOCUMENT :usus Folder:VOL2A:h14.driver.text
========================================================================================

(*   Program Author:  Frank Monaco
                      679 Lowell Drive
                      Marietta, GA 30060
                      404-424-1460
                                                        *)
                                                        


PROGRAM H14PRINTERDRIVER( (* FROM *) INPUT  (* TO PRINTER AND 
                        SCREEN *));



(* SENDS UCSD PASCAL DISK FILES TO THE HEATHKIT H14 LINE PRINTER
WHILE INTERACTIVELY ALLOWING THE USER TO SPECIFY OPTIONS AT RUN
TIME. PROMPTS FOR FILE(S) TO BE PRINTED, AND ALSO FOR USE OF 
FORTRAN/NOFORTRAN CARRIAGE CONTROL CONVENTIONS IN COLUMN ONE OF 
THE FILE TO BE PRINTED. IF NOFORTRAN IS SELECTED, PRODUCES PAGED
AND TITLED OUTPUT (WITH USER NAMING OPTIONS)  *)



(*
    *******************************************************
    *     FORTRAN CARRIAGE CONNTROL                       *
    *        1....TOP OF FORM                             *
    *        +....NO LINE FEED                            *
    *        0....DOUBLE SPACE                            *
    *        -....TRIPLE SPACE                            *
    *******************************************************


*)

CONST              (*ASCII CONTROL CHARACTERS (DECIMAL) THAT H14 
                    UNDERSTANDS TO CONTROL COLUMN AND VERTICAL 
                    SPACING AS WELL AS CHARACTER SIZE. SEE PAGE
                    13, HEATHKIT MANUAL FOR H14 (OPERATION).    *)



      LF    = 10;
      FF   = 12;
      CR     = 13;
      ESC  = 27;
      LCU   = 117;
      LCX  = 120;
      LCY    = 121;
      CTLA = 1;
      CTLD  = 4;
      CTLH = 8;
      CTLP   = 16;
      CTLT = 20;
      CTLX  = 24;
      SP   = 32;
      DOL    = 36;
      LPAREN = 40;



TYPE 
     CONTROLCOLUMNWIDTH = PACKED ARRAY[0..2] OF CHAR;
                        (* BUFFER FOR PRINTER OPTIONS *)



VAR 
    C8080, C8096, C80132, C9680,C9696,C96132,
    C13280,C13296,C132132                     : CONTROLCOLUMNWIDTH;
    COLUMNOPTION, LINESPERINCH                : INTEGER;
    CH, LASTCH                                : CHAR;
    FIRSTPART, FILENAME                       : STRING;
    F                                         : TEXT;
    FIRSTPOS, BOLDFACE, FORTRANCONTROLS       : BOOLEAN;
    I                                         : INTEGER;



PROCEDURE PUTP;
EXTERNAL;
     (*  ASSEMBLY ROUTINE THAT PUTS ONE CHARACTER 
         INTO THE H14'S SERIAL BOARD AT 177514. 
         ALSO CHECKS BIT 15 (RTS)  OF 177510 TO
         VERIFY STATUS OF FIFO BUFFER      *)



PROCEDURE SENDARRAY(T : CONTROLCOLUMNWIDTH);
     (* SENDS A THREE CHARACTER COLUMN CONTROL 
      SEQUENCE TO THE H14. SEE PAGE 13, H14 
      MANUAL FOR OPERATION    *)

VAR 
    I : INTEGER;
BEGIN
  FOR I := 0 TO 2 DO
     BEGIN
        CH :=  T[I];
        PUTP
     END
END;  (* SENDARRAY *)



PROCEDURE INITIALIZE; (* GIVES VALUES TO COLUMN OPTIONS AND SOLICITS 
                        INTERACTIVELY FROM THE USER WHETHER THE FILE 
                        SELECTED IS TO BE PRINTED USING FORTRAN
                        CONTROLS OR WHETHER IT IS TO BE 
                        PAGED AND TITLED *)
BEGIN
         (* DEFINE COLUMN CONTROL SEQUENCES FOR "SENDARRAY " *)


   C8080[0]   := CHR (ESC);
   C8096[0]   := CHR (ESC);
   C80132[0]  := CHR (ESC);
   C9680[0]   := CHR (ESC);
   C9696[0]   := CHR (ESC);
   C96132[0]  := CHR (ESC);
   C13280[0]  := CHR (ESC);
   C13296[0]  := CHR (ESC);
   C132132[0] := CHR (ESC);
   C8080[1]   := CHR (LCU);
   C8096[1]   := CHR (LCU);
   C80132[1]  := CHR (LCU);
   C9680[1]   := CHR (LCU);
   C9696[1]   := CHR (LCU);
   C96132[1]  := CHR (LCU);
   C13280[1]  := CHR (LCU);
   C13296[1]  := CHR (LCU);
   C132132[1] := CHR (LCU);
   C8080[2]   := CHR (CTLA);
   C8096[2]   := CHR (CTLD);
   C80132[2]  := CHR (CTLH);
   C9680[2]   := CHR (CTLP);
   C9696[2]   := CHR (CTLT);
   C96132[2]  := CHR (CTLX);
   C13280[2]  := CHR (SP);
   C13296[2]  := CHR (DOL);
   C132132[2] := CHR (LPAREN);



   WRITELN;  (* SEE HEATHKIT MANUAL FOR H14 OPERATION, PAGE 13 *)
   WRITELN('Please select column control options', CHR(7));
   WRITELN;
   WRITELN ('1) 80x80; 2) 80x96; 3) 80x132; 4) 96x80; 5) 96x96; ');
   WRITE ('6) 96x132; 7) 132x80; 8) 132x96; or 9) 132x132 - - > ', CHR(7));
   READLN(KEYBOARD,COLUMNOPTION);



   CASE COLUMNOPTION OF
     1 : SENDARRAY(C8080);
     2 : SENDARRAY(C8096);
     3 : SENDARRAY(C80132);
     4 : SENDARRAY(C9680);
     5 : SENDARRAY(C9696);
     6 : SENDARRAY(C96132);
     7 : SENDARRAY(C13280);
     8 : SENDARRAY(C13296);
     9 : SENDARRAY(C132132)
   END;  (*CASE COLUMOPTION *)


   WRITELN;  (* SEE HEATHKIT MANUAL FOR H14 OPERATION, PAGE 13 *)
   WRITELN('Please select number of lines per inch ', CHR(7));
   WRITE(' 1) 6 lines per inch; 2) 8 lines per inch - - -> ', CHR(7));
   READLN(KEYBOARD,LINESPERINCH);
   IF LINESPERINCH = 1
     THEN
       BEGIN
         CH := CHR (ESC);
         PUTP;
         CH := CHR (LCX);
         PUTP
       END
     ELSE
       BEGIN
         CH := CHR (ESC);
         PUTP;
         CH := CHR (LCY);
         PUTP
       END;
   WRITELN;
  WRITE(CHR(7),CHR(7));
   WRITELN;
   WRITE('Do you want to use Fortran Carriage Controls?');
   READLN(KEYBOARD,CH);
   WRITELN;
   IF CH IN ['y','Y']
     THEN
       FORTRANCONTROL := TRUE  (* USE FORTRAN CARRIAGE CONTROLS *)
     ELSE
       FORTRANCONTROL := FALSE;  (* USE PAGED AND TITLED OUTPUT *)
END; (*INITIALIZE*)



PROCEDURE FORTRAN; (* IF SELECTED, THIS OPTION USES THE CHARACTER
                     IN COLUMN ONE FOR CARRIAGE CONTROL *)



BEGIN
   BOLDFACE := FALSE;
   WHILE NOT EOF(F) DO
       BEGIN
         FIRSTPOS := TRUE;
         WHILE NOT EOLN (F) DO
           BEGIN
             IF FIRSTPOS
               THEN
                 BEGIN
                   READ(F,CH);
                   CASE CH OF
                     '1' : BEGIN    (* TOP OF FORM CASE *)
                             CH := CHR(FF);
                             PUTP;
                             FIRSTPOS := FALSE
                           END;
                     '+' : BEGIN    (* OVERSTRIKE CASE *)
                             BOLDFACE := TRUE;
                             FIRSTPOS := FALSE
                           END;
                     '0' : BEGIN    (* SKIP TWO LINES CASE *)
                             CH := CHR (LF);
                             PUTP;
                             PUTP;
                             FIRSTPOS := FALSE
                           END;
                     '-' : BEGIN    (* SKIP THREE LINES CASE *)
                             CH := CHR (LF);
                             PUTP;
                             PUTP;
                             PUTP;
                             FIRSTPOS := FALSE
                           END
                   END; (*CASE*)


                   IF FIRSTPOS
                     THEN
                       BEGIN
                         LASTCH := CH;
                         CH := CHR(LF);
                         PUTP;
                         CH := LASTCH;
                         PUTP;
                         WRITE(CH);
                         FIRSTPOS := FALSE
                       END;
                 END
               ELSE
                 BEGIN
                   IF BOLDFACE
                     THEN   (* COMPENSATE FOR '+' IN COLUMN ONE *)
                       BEGIN
                         BOLDFACE := FALSE;
                         CH := ' ';
                         PUTP
                       END
                     ELSE
                       BEGIN
                         READ(F,CH);
                         PUTP;
                         WRITE(CH)
                       END
                 END
           END;
         READLN(F);
         CH := CHR(CR);
         PUTP;
         WRITELN;
      END;
END; (* PROCEDURE FORTRAN *)



PROCEDURE NOFORTRAN;  (* PRINTS A HEADER (TITLE AND PAGE) WITH THE 
                        APPROPRIATE NUMBER OF LINES (DEPENDING ON 
                        COLUMN/CHARACTER OPTIONS SELECTED *)

VAR 
    NOLINES, NOPAGES, MAXLINES : INTEGER;



  PROCEDURE WRITEHEADER;



      PROCEDURE HEADER; (* HANDLES HEADER SPACING, LITERAL CONVERSION, 
                          AND ACTUAL OUTPUT TO THE PRINTER *)

      VAR 
          FIRSTDIGIT, LASTDIGIT, NUMBLANKS : INTEGER;
          FIRSTCH, LASTCH : CHAR;
          PAGE : STRING;

        BEGIN  (* HEADER *)
           CASE COLUMNOPTION OF
             1, 4, 7 : NUMBLANKS := 80 - LENGTH(FIRSTPART) - 7;
             2, 5, 8 : NUMBLANKS := 96 - LENGTH(FIRSTPART) - 7;
             3, 6, 9 : NUMBLANKS := 132 - LENGTH(FIRSTPART) - 7
           END; (* CASE *)


           FOR I := 1 TO (NUMBLANKS - 1) DO
             BEGIN
               CH := ' ';
               PUTP;
               WRITE(CH)
             END;



           FIRSTDIGIT := NOPAGES DIV 10;
           LASTDIGIT := NOPAGES MOD 10;
           FIRSTCH := CHR ( FIRSTDIGIT + ORD ('0'));
           LASTCH := CHR (LASTDIGIT + ORD ('0'));


           IF FIRSTCH = '0'
             THEN
               FIRSTCH := ' ';



           CH := 'P';
          PUTP;
          WRITE(CH);
           CH := 'a';
          PUTP;
          WRITE(CH);
           CH := 'g';
          PUTP;
          WRITE(CH);
           CH := 'e';
          PUTP;
          WRITE(CH);
           CH := ' ';
          PUTP;
          WRITE(CH);
           CH := FIRSTCH;
           PUTP;
           WRITE(CH);
           CH := LASTCH;
           PUTP;
           WRITE(CH);
           CH := CHR(LF);
           PUTP;
          PUTP;
          WRITELN;
       END; (* HEADER *)



     BEGIN (* WRITEHEADER  *)
        CH := CHR(FF);
        PUTP;
        IF FIRSTPART[1] = '#'  (* STRIP FROM FILENAME FOR TITLING *)
          THEN
            FIRSTPART[1] := ' ';
        IF FIRSTPART[2] IN ['4'..'5']
          THEN
            FIRSTPART[2] := ' ';
        IF FIRSTPART[3] = ':'
           THEN
             FIRSTPART[3] := ' ';
        FOR I := 1 TO LENGTH (FIRSTPART) DO
          BEGIN
            CH := FIRSTPART[I];
            PUTP;
            WRITE(CH)
          END;


        HEADER;


     END; (* WRITEHEADER *)



     BEGIN  (* NOFORTRAN *)
       IF LINESPERINCH = 1
         THEN
           MAXLINES := 60
          ELSE
            MAXLINES := 80;
        NOPAGES  := 1;
        NOLINES := 3;


        REPEAT   (* MAIN LOOP : EXECUTE ONCE PER PAGE *)
          WRITEHEADER;
          REPEAT  (* INNER LOOP : EXECUTE ONCE PER LINE *)
            NOLINES := SUCC (NOLINES);
            WHILE NOT EOLN(F) DO
              BEGIN
                READ(F, CH);
                PUTP;
                WRITE(CH)
              END;
            READLN(F);
            WRITELN;
            CH := CHR(LF);
            PUTP
          UNTIL (NOLINES = MAXLINES) OR (EOF(F)); (* LINE LOOP *)


          NOLINES := 3;
          NOPAGES  := SUCC(NOPAGES)
       UNTIL EOF(F);  (* PAGE LOOP *)
END; (* NOFORTRAN *)



PROCEDURE GETFILE; (* SOLICIT FILE NAME TO BE PRINTED FROM USER *)

BEGIN
   WRITE('Please enter text file name--> ');
   READLN(INPUT,FIRSTPART);
   FILENAME := CONCAT(FIRSTPART,'.text');
   RESET(F,FILENAME); (* NOW GIVE USER OPTION TO NAME OUTPUT *)
   IF NOT FORTRANCONTROLS
     THEN
       BEGIN
         WRITE(' 1) Use your title  or 2) Use Filename --> ');
         READLN(CH);
         WRITELN;
         IF CH = '1'
            THEN
               BEGIN
                  WRITE('Please enter your title--> ');
                  READLN(FIRSTPART);
                   WRITELN
                  END
       END;
END;  (* GETFILE *)



PROCEDURE ASKFORMORE; (* MORE FILES TO PRINT? *)

BEGIN
   WRITE('Do you want to print any more files? ');
   READLN(KEYBOARD,CH);
   IF (CH IN ['y','Y'])
     THEN
       CLOSE(F,LOCK); (* CAN ONLY OPEN
                                              ONE FILE AT
                                              A TIME *)
END; (*ASKFORMORE*)



BEGIN (*PROGRAM H14 MAIN*)

   FORTRANCONTROL := FALSE;
   REPEAT           (* MAIN PROGRAM LOOP : EXECUTED ONCE PER FILE
                                                       PRINTED  *)
     INITIALIZE;
     GETFILE;
     IF FORTRANCONTROL
       THEN
         FORTRAN
       ELSE
         NOFORTRAN;
     ASKFORMORE
   UNTIL CH IN ['n','N'];


END. (*PROGRAM H14 MAIN*)

========================================================================================
DOCUMENT :usus Folder:VOL2A:h19.doc.text
========================================================================================


                                      Oct 29, 1979
               From Walter Hess to users of the Heath H19 
               terminal:
               
               
                    First, you should initially set the switches 
               in the H19 as follows:
               
                    S401    0 0 1 1 0 0 0 1
               
                    S402    0 0 0 0 0 0 1 0
               
                      I could not get the BACKSPACE key to do 
               its thing and after much work and frustration, I 
               put a "Patch" into SYSSEGS.TEXT (which is part of 
               the source program for SYSTEM.PASCAL) consisting 
               of an assignment of "CHR(8)" to the variable 
               CRTINFO.CHARDEL.  This solved the problem in all 
               parts of the system and also in my own programs.
                    

========================================================================================
DOCUMENT :usus Folder:VOL2A:h19.gotoxy
========================================================================================


(* Program Author:   Walter Hess
                     1460 Seven Pines Rd.
                     Schaumberg, IL 60193
                     
                                                        *)
                                                        

(*$U-,S+*)
PROCEDURE H19GOTOXY (X,Y : INTEGER);

VAR
  T : PACKED ARRAY[0..3] OF CHAR;

BEGIN
  T[0] := CHR(27); (* ESC *)
  T[1] := CHR(89); (* "Y" *)
  IF X < 0 THEN T[3] := CHR(32)
  ELSE
    IF X > 79 THEN T[3] := CHR(32+79)
    ELSE
      T[3] := CHR(X + 32);
  IF Y < 0 THEN T[2] := CHR(32)
  ELSE
    IF Y > 23 THEN T[2] := CHR(32 + 23)
    ELSE
      T[2] := CHR(Y + 32);
  UNITWRITE(1,T,4)
END;

BEGIN
END.

========================================================================================
DOCUMENT :usus Folder:VOL2A:h19.miscinfo
========================================================================================

ҫ:d  f vߤ q *    E >  IO  
 
  HJKCA lE  P ABDC ?                           ! " # $ % & ' ( ) * + , - . / A A A A A A A A A A :                                                                                                                                                                                                                                                                                                                                                                                                                                                        O  ^ SS                                                            
========================================================================================
DOCUMENT :usus Folder:VOL2A:hazel.miscinfo
========================================================================================


      P \?                                                                                                                                                                                                                                                                                                                                                                                                                                                          O  ^                                                                 
========================================================================================
DOCUMENT :usus Folder:VOL2A:hexout.text
========================================================================================


PROGRAM HEXTEST;
VAR CH : CHAR;
     I : 0..1;

PROCEDURE HEXOUT (C:CHAR);
TYPE        HEX = PACKED ARRAY[0..1] OF 0..15;
      ALIASTYPE = RECORD
                   CASE BOOLEAN OF
                     TRUE: (CHAREP:CHAR);
                     FALSE: (HEXREP:HEX)
                   END;
VAR  ALIAS:ALIASTYPE;
BEGIN
  ALIAS.CHAREP:=C;
  FOR I:=1 DOWNTO 0 DO
  IF ALIAS.HEXREP[I] < 10 THEN WRITE(ALIAS.HEXREP[I]) 
    ELSE WRITE(CHR(ALIAS.HEXREP[I]+55));
END;


BEGIN
  REPEAT
    WRITELN;
    READ(KEYBOARD,CH);
    HEXOUT(CH);
  UNTIL CH='Z'
END.

j
========================================================================================
DOCUMENT :usus Folder:VOL2A:kbstat.text
========================================================================================

        .FUNC   KBSTAT,0
        .PRIVATE RETADDR
        POP     HL
        LD      (RETADDR),HL
        POP     HL              ;CORRECT STACK
        POP     HL
        LD      HL,RADDR        ; RETURN ADDRESS
        PUSH    HL
        LD      HL,(1)
        LD      L,6
        JP      (HL)
RADDR   OR      A               ; SET FLAGS
        LD      HL,1
        JP      NZ,DONE         ;READY
        LD      HL,0            ;FALSE
DONE    PUSH    HL
        LD      HL,(RETADDR)
        JP      (HL)
        .END


========================================================================================
DOCUMENT :usus Folder:VOL2A:linecountr.text
========================================================================================

(*   Program Author:  Frank Monaco
                      679 Lowell Drive
                      Marietta, GA 30060
                      404-424-1460
                      
Rewritten to include improved filename input and blockreads to speed it up:
                Jim Gagne
                Datamed Research
                1433 Roscomare Road
                Los Angeles, CA 90024
                                                        *)
                                                        

program lcnt; (*counts lines in any file*)

var
  numberoflines, i, j : integer;
  infilename: string [30];
  typed: string;
  infile: file;
  chararray: PACKED ARRAY [0..1023] OF char;


PROCEDURE GetString (x,y, maxlength: integer);
VAR j, k: integer;
    Gotstring: boolean;
    bell: char;
BEGIN
  bell := CHR (7);
  Gotstring := false;
  REPEAT
    Gotoxy (x,y);
    FOR j := 1 TO maxlength DO write ('.');
    Gotoxy (x,y);
    Readln (typed);
    k := length (typed);
    IF k > maxlength
      THEN BEGIN
        Gotoxy (x,y);
        Write (' ':k);
        Gotoxy (0,23);
        Write (bell, 'You have entered too many characters in this line.  ',
               'Please try again.')
      END
      ELSE Gotstring := true
  UNTIL Gotstring;
  Gotoxy ((x+k),y);
  Write (' ':(maxlength - k));
  Gotoxy (2,22);
  Write (' ':70);
  Gotoxy (0,73);
  Write (' ':70)
END (*GetString*);


PROCEDURE GetFile;

VAR gotfn: boolean;
    bell, response: char;
  
BEGIN
  Bell := CHR (7);
  REPEAT
    Gotoxy (11,20);
    Write ('Please type the name of the desired input file.');
    Gotoxy (15,21);
    Write ('-->      ');
    Gotoxy (11,22);
    Write ('  (Or just press the <return> key if you wish to quit.)');
    Typed := '';
    GetString (20,21, 23);
    IF LENGTH (typed) = 0
      THEN BEGIN
        Gotoxy (11,23);
        Write ('Would you prefer to quit this program (Y/N)?     ');
        Read (Keyboard, response);
        Gotoxy (11,23);
        Write (' ':47);
        IF (Response = 'Y') OR (Response = 'y')
          THEN EXIT (Program)
      END
      ELSE BEGIN
        Infilename := Typed;
        (*$I-*)
        Reset (Infile, Infilename);
        IF IORESULT > 0 THEN Reset (Infile, CONCAT (Infilename, '.TEXT'));
        (*$I+*)
        Gotfn := IORESULT = 0;
        IF NOT Gotfn
          THEN BEGIN
            Gotoxy (0,23);
            Write (bell, '<<**** ERROR ****>>   ',
                   'Wrong volume or file name.  Type <space> to continue.');
            REPEAT Read (Keyboard, Response) UNTIL Response = ' ';
            Gotoxy (0,23);
            Write (' ':78)
          END
      END(*else*)
  UNTIL Gotfn;
END (*GetFile*);


begin
writeln(' *** This program counts number of lines in a text file ***');
GETFILE;
numberoflines := 0;
GOTOXY (3,4);
write ('...counting');
while not eof(infile) do 
   begin
      i := Blockread (Infile, chararray, 2);
      IF i > 0 
        THEN BEGIN 
          IF i = 2 THEN i := 1023 ELSE i := 511;
          FOR j := 0 TO i DO IF chararray [j] = CHR (13)
            THEN BEGIN
              numberoflines := succ(numberoflines);
              gotoxy(1,4);
              write(numberoflines);
            END;
        END;
   end;
writeln;
writeln('Your file ', InfileName, ' contains ', numberoflines, ' lines...');
end.


========================================================================================
DOCUMENT :usus Folder:VOL2A:movram.text
========================================================================================

        .PROC   MOVRAM,3
; COPYRIGHT 1979 BY BARRY A. COLE
; THIS MAY BE FREELY DISTRIBUTED IF COPYRIGHT NOTICE RETAINED
; PURPOSE:       MOVE BUFFER DOWN TO TOADDR)
; PASCAL CALL:   CPMRAM(FROMADDR,TOADDR,#BYTES);
; INTENDED USE:  GENERATE CODE, CALL CPMRAM, SWITCH TO
;                CPM DISK, BOOT CPM, SAVE XX FILE
        POP     HL      ;RETURN ADDRESS
        POP     BC      ;#BYTES
        POP     DE      ;MOVE TO ADDRESS
        POP     HL      ;BUFFER ADDRESS
        LDIR            ;MOVE THEM
        HALT            ;  AND WAIT FOR DISKETTE CHANGE
        .END


========================================================================================
DOCUMENT :usus Folder:VOL2A:new.gotoxy.text
========================================================================================

(*The following is a sample gotoxy procedure for the HAZELTINE-2000*)
(*TO PUT IT INTO THE SYSTEM, COMPILE IT, RUN 'BINDER' (YOU'VE GOT
  TO HAVE 60 BLOCKS OF UNUSED AREA ON THE DISK), TELL BINDER THE
  NAME OF THIS FILE, AND REBOOT THE SYSTEM ('I' TO COMMAND WON'T DO
  IT.).*)
(*$U-*)
PROGRAM DUMMY;
PROCEDURE FGOTOXY(X,Y:INTEGER);
  CONST  ESC = 126;  CLRSCREEN = 28;  XYCHR = 17;
	 DELETELINE = 19;
BEGIN

 IF (X = -1) AND (Y = -1) THEN
    WRITE(CHR(ESC),CHR(CLRSCREEN))
  ELSE BEGIN
  IF (X = -2) AND (Y = -2) THEN
      WRITE(CHR(ESC),CHR(DELETELINE))
      (* THIS DELETES THE ENTIRE LINE THAT THE CURSOR IS
	 ON AND CLOSES UP THE SCREEN FROM THE BOTTOM. *)
    ELSE BEGIN
      IF X<0 THEN X:=0;
      IF X>74 THEN X:=73;
      IF Y<0 THEN Y:=0;
      IF Y>26 THEN Y:=26;
      WRITE (CHR(ESC),CHR(XYCHR),CHR(X+32),CHR(Y+32));
      END;
  END;

END;
BEGIN
END.

========================================================================================
DOCUMENT :usus Folder:VOL2A:pe1100.gotoxy
========================================================================================



(* This is a GOTOXY procedure for the Perkin-Elmer Data Systems
   1100 (Fox) terminal.  Author:
                                        Paul Gilliam
                                        P.O. Box 2202
                                        Pullman, WA 99163
                                                              *)
                                                              
PROGRAM DUMMY;  
  PROCEDURE MYGOTOXY(X,Y: INTEGER);
    VAR
      P : PACKED ARRAY [0..5] OF CHAR;  
    BEGIN
      IF X < 0 THEN X := 0;
      IF X > 79 THEN X := 79;
      IF Y < 0 THEN Y := 0;
      IF Y > 23 THEN Y := 23;
      P[0] := CHR(27);
      P[1] := 'X';
      P[2] := CHR(Y+32);
      P[3] := CHR(27);
      P[4] := 'Y';
      P[5] := CHR(X+32);
      UNITWRITE(2,P,6);
    END  { MYGOTOXY };
  BEGIN  END.


========================================================================================
DOCUMENT :usus Folder:VOL2A:peruse.pg.text
========================================================================================


(*   Program Author:  Frank Monaco
                      679 Lowell Drive
                      Marietta, GA 30060
                      404-424-1460
                                                        *)
                                                        

program perusepage;

var
  i : integer;
  ch : char;
  file1, f1 : string;
  source : text;
  more : boolean;


begin
more := true; i := 0;
write('enter file to be perused- - -> '); readln(f1);
file1 := concat(f1,'.text');
reset(source,file1);
while (not eof(source) and more) do
   begin
      while not eoln(source) do
         begin
            read(source, ch);
            write(ch)
         end;
      readln(source);
      writeln;
      i := succ(i);
      if i = 23 then
         begin
           write('more? '); readln(ch);
           if ch = 'q' then
              begin
                 more := false
              end
              else
              begin
                 i := 0;
                 reset(input)
              end
         end
  end 
end.
         



========================================================================================
DOCUMENT :usus Folder:VOL2A:policy.doc.text
========================================================================================


     INTERIM POLICY OF THE UCSD PASCAL USERS' GROUP LIBRARY

Obtaining Library Software.

     Floppy disks full of donated Pascal programs are available from the
Library as follows:

     8-inch, single-sided, single-density UCSD- or CP/M-format disks are $10 
each postpaid (California residents MUST add 6% sales tax; Canadian and
Mexican recipients should add $3 per order for the extra hassle involved;
other out-of-country sales must add $8 for the first disk of an order and
$1.50 per each additional disk to cover air mail) from Jim Gagne, Datamed
Research, 1433 Roscomare Road, Los Angeles CA 90024. Both UCSD Pascal and CP/M-
compatible Pascals are supported, though UCSD programs will require
modification to run under other systems.

     5-1/4 inch diskettes of UCSD software (2 or 3 are required to hold an 8-
inch volume) are available from Bruce Sherman, SofTech Microsystems, 9494
Black Mountain Road, San Diego CA 92126.  Pricing is not yet established, but
will probably exceed $20 per volume due to order processing costs.  (We are
looking for volunteers to distribute the various 5-1/4 inch formats so we can
offer them at lower cost.) Software of interest only to users of certain 
systems will as a rule not be distributed to incompatible systems.  Contact
Bruce for further information.

     Western Digital has indicated an interest in distributing Users' Group 
software on 8-inch disks compatible with the Microengine (these are NOT UCSD 
compatible because of differences in disk sectoring).  In addition, they can 
provide Microengine users with software that will enable them to convert UCSD
standard disks on their machines.  Contact them directly for more information.

     You can obtain a free disk volume of your choice by donating software to
the group if the software is accepted (see below).

     Any user may copy Users' Group software and give it away to others FREE
for nothing.  This includes OEM's and retailers.  However, if any charge
whatsoever is made to the recipient of the software, then: 1) the maximum
charge is limited to a $5 fee per volume plus the retail cost of each floppy
disk and 2) the Users' Group must be reimbursed $2 per disk volume sold.  (A
disk volume is the contents of one 8-inch, single-sided, single-density
diskette.) These charges apply no matter how indirectly the seller obtains
Users' Group software.  These editing fees should be paid to Datamed Research
at the above address, within a month's time of the sale.

     All software is furnished with the understanding that no one may sell it
for profit without the written consent of the author.  In addition, the 
software MAY NOT be copied without continuing to carry whatever statements of
authorship it may now contain.  Finally, despite hard work to maintain the 
highest standards possible, we of course cannot guarantee in any way that
programs obtained from the Users' Group Library will be suitable for your
intended purpose.

     
Submitting Software.

     We are interested in receiving software from anyone who may wish to 
contribute.  Every type of program is welcomed, and we are particularly eager
to receive donations of software tools: those procedures and programs you
have developed to make your programming simpler and more productive, and
which may be of broad interest to the Pascal community.  Such items as double-
precision integer packages, business math routines, generic input/output
processing, program timers and debuggers, system utilities, and reports of
specific techniques to speed UCSD programs are particularly desired.  It is
clear that if we can all develop the habit of donating particularly useful
tools to the Users' Group, a broad base of software support will quickly
develop which will benefit us all enormously.

     To be accepted, software must: 1) be in source form, 2) be relatively 
free of bugs, 3) be reasonably clearly written and documented so that it may
be easily modified, 4) come with sufficient instructions so that we can use
it, 5) be capable of being placed in the public domain, and 6) not have been
received previously from someone else.  If you have an especially long program
or one that is for some reason tricky to compile, you may wish to submit
object code as well as source.  Certain items may be submitted in object form
only: if you have a quality program undergoing development that you eventually
wish to sell, we would be willing to pilot it for you if it is of sufficient
interest to the group at large and works moderately well.  I am certain many
members would enjoy writing you with their comments, and you should wind up
with a product of much higher quality in a much shorter time than is the rule.

     We are also interested in reports of bugs in the system or user software
(preferably with fixes or kludges to get around them) and documentation of the
more obscure aspects of UCSD Pascal.

     
Editors.

     Many people have written to UCSD and SofTech wishing to assist in the
organization of a users group library.  We think this is grand.  Because it
makes little sense for the collection and distribution of programs to be
scattered all around the country, we plan to set up the following structure
for now and see how it works: Anyone who wishes to collect a disk full of
software may submit it to the Users' Group (send them to Datamed Research; 8-
inch diskettes preferred).  Fundamentally, the requirements for the acceptance
for the software are those stated previously; in addition, the disk editor
must have checked out the programs and organized them in some way.  You
should have a catalog of the files on the disk, and a separate file
containing: 1) descriptions of each program, 2) what you think of it, and 3)
any remaining documentation required for use.  Note that we are specifically
committed to full and complete documentation ON THE DISK whenever possible.
Programs should be of general interest, although it is all right to include
hardware-specific programs if they solve a pressing need.  (I would prefer to 
put most of the hardware-specific material on a special disk, which users can
ignore if they wish.)

     If you submit a disk that is reasonably well put together, you will: 1) 
be listed as editor of that volume, 2) receive $1 for each disk SOLD
(remember, many will be given to friends), and 3) be placed on the official
UCSD Pascal Users' Group Library Roster of Editors, and receive all past and
future volumes of the Users' Group library, so we can coordinate our efforts. 
(I reserve the right not to send you ALL the Users' Group volumes if this
thing gets too big and you haven't contributed for a while.) A word of
warning: most of the Pascal disks now floating around have much less work put
into them than we feel is required for them to be generally useful. I, in
particular, am a FANATIC about making our products helpful and/or fun to
programmers of various persuasions.  So the $1 payment per disk is intended to
reimburse you in part for the very real effort required to create a disk with
truly useful contents.

========================================================================================
DOCUMENT :usus Folder:VOL2A:prime1.text
========================================================================================

program primenumbers (input,output);
  const
    firstprime=2;
    maximum=30000;
    tab=9;
  var
    sieve : packed array[firstprime ..maximum] of boolean;
    leftin,range,factor,multiple: 0..maximum;
  begin
    writeln('PRIME NUMBER GENERATOR');
    write('Enter upper bound: ');
    read(range);
    for factor:=firstprime to range do
      sieve[factor]:=true;
    leftin:=range-firstprime+1;
    factor:=firstprime-1;
    repeat
      factor:=factor+1;
      if sieve[factor]
        then {factor is a prime }
          begin
            writeln(factor{,chr(tab)});
            multiple:=1;
            while factor*multiple<=range do
              begin
                if sieve[factor*multiple]
                  then
                    begin
                      sieve[factor*multiple]:=false;
                      leftin:=leftin-1
                    end;
                  multiple:=multiple+1
                end  { while }
                end
              until leftin=0
          end. {primenumbers}


========================================================================================
DOCUMENT :usus Folder:VOL2A:prime2.text
========================================================================================

program primes;
  var range,sample,test : integer;
      prime: boolean;
begin
  read(range);
  writeln(2);
  for sample:=3 to range do
    begin
      prime:=TRUE; test:=1;
      repeat
        begin
          test:=test+1;
          if sample mod test=0 then prime:=FALSE;
          end
        until (not prime) or (test>=sample div test);
      if prime then write(CHR(9),sample);
      end;
end.


========================================================================================
DOCUMENT :usus Folder:VOL2A:ptp.doc.text
========================================================================================

     The PTP system is made up of a large Pascal program and 6 small assembly
language routines. The large Pascal program should work with most systems and
because it requires 56K to compile a precomplied version PTP.CODE has been
provided. If you can recompile this program you should do so after changing
the constant called SYSTEMNAME which is intended to contain the latitude/
longitude, phone number, and a short system for your system.

     With the exception of the routine KBSTAT most of the assembly language
will have to modified to work with your system. The routine KBSTAT should work
with most systems that use CP/M BIOS.  Two versions of serveral routines have
been provided, one for use with an acoustic coupler system, the other for use
with a D C Hayes modem board. After modifing these routines for your system
they can be entered a library which is then linked with PTP.CODE (be sure to
use another name for the output file so as to not destroy this file).
 
     If you do not understand the library procedures you can link the program
by entering each of the routine names when the linker asks for lib file.
PTP.CODE is always used as the host file. The library "system.library" is not
used by this program and automatic linking which may occur if you say run
after compiling will not work correctly.
 

The following files make up the Pascal Transfer Program:

PTP.TEXT - This the main program written entirely Pascal.

PTP.CODE - A compiled but not linked version of the main program PTP.TEXT.
       PTP.TEXT requires a 56K system to compile therefore this precompiled
       version can be used as the main program during linking by those with
       less memory. Be sure not to call the outfile of the linker PTP.CODE or
       this file will be destroyed.

KBSTAT - An assembly language function which return a TRUE if there is a
       character ready at the keyboard port. Since this routine calls the CP/M
       keyboard status routine, it should work with most system that use the
       standard CP/M BIOS jump table with a vector at address 1.
           
THE FOLLOWING FUNCTIONS ARE CONTAINED IN "DCHAYES.IO.TEXT", AND MAY REQUIRE
ALTERATION TO RUN PROPERLY ON YOUR SYSTEM.

   DCHREAD - Performs the same function as SERREAD except for use with the D C
          Hayes modem.
    
   DCHWRITE - Performs the same function as SERWRITE except for use with the D
          C Hayes modem.
                   
   DCHMODINIT - An extremely primitive assemble language procedure which
          initializes a D C Hayes modem for use with PTP. The program performs
          a brute force auto answer but has no dialing capability. This
          routine was written only to perform initial testing and should not
          be used as guide for more reasonable modem interfaces.
               
   DCHHANGUP - A primitive assemble language procedure which causes the D C
          Hayes modem to hangup. Comments made about DCHMODINIT apply here.
                      

THE FOLLOWING ROUTINES ARE CONTAINED IN "ACOUSTIC.TEXT", AND MAY REQUIRE ALTER-
ATION AS NOTED ABOVE.
    
   ACSMODINIT - A dummy routine for use with acoustic coupler systems.
                      
   ACSHANGUP - A dummy routine used with acoustic coupler systems.
    

 
          An Introduction to Using the Pacsal Transfer Program

     This brief introduction will hopefully provide you with enough informa-
tion to run PTP. The first question you will be asked after starting PTP is if
you want to run answer or orginate mode. This question applies to the PTP prog-
ram itself since it has an answer and orginate mode just as the modem does.
The PTPs must be in different modes to communicate. In the case of the D C
Hayes modem, the modem board will be set to the same mode as the program. This
would seem a resonable standard for other modems also. This is the only ques-
tion, after which the program will start. In the case of answer mode for the D
C Hayes modem the program will go into a loop waiting for the phone to ring. 

     If you have made contact with another PTP, both programs should now be in
a loop sending empty packets back and forth. The first thing you will see
after a connection is established is the ID of the other program. At this
point you may try to send a terminal-to-terminal message. To do this type the
first character of the message and wait for a ">" follwed by the character you
typed. Type the rest of the message and hit return (if the message is to long
echoing will stop and the first part will be sent). The message will then be
sent to the other PTP. It should be realised that whenever a PTP program is
waiting for a character from the keyboard, it will not be listening or sending
on the modem line. This will cause the PTP on the other end to timeout while
waiting for a transmission and display a receiver timeout message. If this
were to continue for a long time, the PTP on the other end would finally give
up and abort. Also, even after you finish typing your message it may take
several transmissions for the programs to get their half duplex transmissions
resynced (both programs may be sending at the same time and miss part of the
other's transmission). This condition should correct itself shortly, since the
timeout for answer and orginate modes are different.
 
     To send files or perform other functions it is first necessary to get the
attention of the PTP; to do this type a control-E and wait. A menu should be
displayed shortly, similar to the type displayed by the UCSD Pascal system. It
should be remembered that when the program is in this mode, the other PTP will
be experiencing receiver timeouts. To exit the menu function and return
control to PTP just hit a carriage return while in the menu display. The
following is a description of the current menu functions:

   Get - Get a file from the other system. It should be noted that you must
          already know the name ow the file you wish transfered and there is
          no remote list directory function. For this reason it would be a
          good idea if each system contained a file with the well know name
          "dir.text" which contains the name of the files which that person
          is willing to have transfered. 

   Send - Send a file from your system to the other system. The PTP program
          will not create a file on a system if it already exists. This is to
          prevent overwriting files on the other system which you did not know
          existed.

   Raw - This puts you in a raw terminal mode in which makes the system look
          like a half duplex terminal and is intented mainly to allow logging
          into timesharing systems. Type a control-E to exit this mode.

   Init - This function will reinitialize most of the counters in the program.
          If you are in contact with another PTP this will result in a loss of
          sequencing from which there is no recovery. This function was
          included to allow the program to be reinitialized without having to
          exit the program which will generally cause the modem to hangup.
    
   Exit - Will cause PTP to terminate and hangup the phone (if you have modem
          control). If the program is currently busy transfering a file you
          will be warned and asked if you still wish to exit.

Monitor - This allows you to control various trace and other options as
described below:
          
   Trace LTB - Trace the link transmission blocks. This trace dumps the
          variously encoded forms of all transmissions sent and received. It
          is helpful in gaining an understanding of how the program works but
          does a lot of data and must be used with CRT type terminal.

   Trace PPS - Trace the process to process stream functions. In general this
          trace is not very helpful unless you already know what you are
          looking for.

   Trace FTP - Trace the file transfer functions and data. 

   Local loopback test - This puts the program in a mode where it talks to
          itself and can be very useful in testing the program especially
          when combined with the LTB trace. You should try this mode before
          attempting to use this program with another PTP to see if the
          program will run on your system.

   Enter data size - Allows use to specify the max amount of unencoded data
          that will be sent in one transmission block. The normal answer is
          64. If you have a noisy line you may notice a message from PTP that
          it is reducing this size.

     
     Because of the low baud rates that our modems use and the encoding done
in the PCNET format, the transmission of files will be very slow. However, the
transferred file should contain no transmission errors, and any type of file
including binary can be transferred. In addition, files can be transfered in
both directions at the same time, and the terminal to terminal mode can still
be used. In order to give you some assurance that the file is being 
transferred, a dot or comma will be printed after each block has been
transferred. Best of luck, and please contact me with errors, questions, or
suggestions you may have.

Mark Gang
408-267-4913

     

 


========================================================================================
DOCUMENT :usus Folder:VOL2A:ptp.text
========================================================================================

{$S+}
{$G+}
{***************************************************************}
{                                                               }
{                        PTP                                    }
{                                                               }
{               PASCAL  TRANSFER  PROGRAM                       }
{                                                               }
{                                                               }
{  (C) COPYRIGHT 1979  J. MARK GANG                             }
{                                                               }
{                                                               }
{  PERMISSION GRANTED FOR NON-COMMERCIAL USE BY INDIVIDUALS.    }
{  ALL OTHER RIGHTS RESERVED.                                   }
{                                                               }
{  HISTORY:                                                     }
{       VERSION 1.0   JULY 1979                                 }
{                                                               }
{***************************************************************}

{Note 1: In several places in this program it was necessary to set
         the length of a string. The length is held in byte 0 of the 
         string. In order to assign to this byte it is necessary that
         range checking be turned of.
}

program ptp ();
const
   SYSTEMNAME = '34.52N098.16W408-267-4913/MARKG'; {UNIQUE FOR EACH SYSTEM}
   
   ATTENCHAR=05;                        {^E - used to get to menu}
   BLKSZ = 512;                         {disk block size}
   MAXR41SZ=127;                        {maximum radix 41 character count}
   MAXDATASZ = 64;                      {max amount of data in LTB blocks}
   MAXREXMIT = 16;                      {maximum number of retransmit attempts}
   MAXDUPSEQ = 5;                       {max allowed dup seq before correction}
   NOPPS = 2;                           {number of pps streams -1}
   ANSTIMEOUT = 6000;                   {receiver timeout (1000 = 1 sec at 4mHz)}
   ORGTIMEOUT = 5000;                   {a different timeout for org made}
   LTBHDLEN = 2;                        {length of the LTB header}
   XPPSTBLSZ = 20;                      {maximum xmit process to process streams}
   RPPSTBLSZ = 20;                      {maximum rec process to process streams}
   
   {process numbers}
   CTRL = 0;                            {process number of control process}
   LSTNER=1;                            {process number of file xfer listener}
   FTPREC = 2;                          {process number of file xfer receiver}
   FTPSND = 3;                          {process number of file xfer sender}
   TERM = 4;                            {process number of terminal hanndler}
   GETFILE = 5;                         {process number of remote file requester}
   SINK = 6;                            {dummy process to dump unwamted input}

   {control messages codes}
   IWN = 0;                             {I won't}
   PDN = 64;                            {Please don't - hex 40}
   IW  = 128;                           {I will - hex 80}
   PD  = 192;                           {Please do - hex C0}
   SF  = 17;                            {send file - hex 11}
   RF  = 18;                            {receive file - hex 12}
   AF  = 19;                            {accept file - hex 13}
   
type
    string20=string[20];
    seqno=0..7;
    bytesz=0..255;
    iam= (ORG, ANS);
    coroutine = (rltb, xltb, done);
    blk= packed array [0..BLKSZ] of char;
    
    word = record case integer of       {address word as int or two char}
                0: (intval: integer);
                1: (byteval: packed record
                       hibyte, lobyte : char;
                       end);
                end;
    
    byte = packed record case char of
            'a':(hdr:  packed record    {LTB header format}
                  oob: seqno;
                  seq: seqno;
                  esc: 0..1;
                  oa : iam;
                  end);
            'b':(ppsh: packed record    {PPS header format}
                 seq: seqno;
                 fil: seqno;
                 lst: boolean;
                 fst: boolean;
                 end);
            'c':(bte:bytesz);
            'd':(ch: char);
            'e':(op: packed record      {control character format}
                msg: 0..63;
                flavor: 0..3;
                end);
         end;
   
   ltbarray = packed array [0..MAXR41SZ] of byte;       {LTB buffer}
   datarray = packed array [0..MAXDATASZ] of byte;      {send data buffer}

   pps = packed record                  {PPS header record format}
           ppsnum:bytesz;
           pseq:seqno;
           active:boolean;
           fstblk:boolean;
           lstblk:boolean;
           srcproc:bytesz;
           destproc:bytesz;
         end;

   xppsrec = array [0..XPPSTBLSZ] of pps;       {open PPS xmit table}
   rppsrec = array [0..RPPSTBLSZ] of pps;       {open PPS receive table}

{---------------- GLOBALS ------------------------------------------}

var
    c:char;
    {-- TEST --}
    ppsmon:boolean;                     {indicates PPS tracing is on}
    ftpmon:boolean;                     {indicates ftp tracing is on}
    loopbk:boolean;                     {internal loop back for debugging}
    trace:boolean;                      {LTB tracing}
    serbuf:array[0..512] of char;       {loopback buffer}
    serptr:integer;                     {loopback buffer pointer}
    {-- SCHEDULING/SEQUENCE/FLOW --}
    mynode:iam;                         {indicates sex of this site during a connection}
    i:integer;                          {answer delay counter}
    timeout: integer;                   {holds timeout constant}
    ansbrkt,orgbrkt:char;               {hold answer and orignate break characters}
    xmtgen:seqno;                       {seq no for next LTB generated}
    rcvoob:seqno;                       {old block not yet received }
    xmtoob:seqno;                       {oldest LTB not yet acked by other end}
    sch:coroutine;                      {next LTB process to be run}
    {-- XMIT LTB --}
    r41:string;                         {holds r41 character set}
    datasize: integer;                  {current data size}
    rexmtcnt:integer;                   {number of consetive rexmits attempted}
    xbuf,tbuf:ltbarray;                 {LTB xmit buffers}
    xlen,tlen:integer;                  {LTB xmit buffer pointers}
    {-- REC LTB --}
    dupseqcnt: integer;                 {cnt of consetive dup seq received}
    {-- PPS --}
    rppstbl:rppsrec;                    {receive PPS table}
    xppstbl:xppsrec;                    {xmit PPS table}
    pollpps:bytesz;                     {next process to be polled by PPS xmitter}
    {-- CTRL --}
    ctrlppsno:bytesz;                   {hold control process PPS number (always 0)}
    {--- TERMINAL---}
    termppsno:bytesz;                   {holds terminal handler PPS number}
    {-- FTP XMITTER --}
    xfile:file;                         {fileid of file to be xmitted}
    xfilptr:integer;                    {xmit file pointer}
    xblk:blk;                           {number of blocks xmitted}
    xbufptr:integer;                    {pointer into xmit data buffer}
    xname:string20;                     {name of file to be xmitted}
    destname:string20;                  {destination name of file being xmitted}
    xeof:boolean;                       {xmit file EOF flag}
    xppsno:bytesz;                      {holds xmit ftp process number}
    xfiletype:bytesz;                   {indicates type of file being xfered (not used in version 1.0)}
    xfilesize:word;                     {indicates size of file to be xfered (not used in version 1.0)}
    fsndstate: (idle, initiate, request, send, terminate, ack, extabort);
                                        {state of file xfer xmitter process}
    fsndcode:bytesz;                    {holds control to be sent}
    {---- LISTENER ------}
    lstnerxpps:bytesz;                  {holds listener reply process number}
    lstnreply:byte;                     {holds listener reply control code to be sent}
    {---- FTP RECEIVER ----}
    rfile:file;                         {ftp receive file fileid}
    rfilptr:integer;                    {receive file block pointer}
    rblk:blk;                           {receive buffer}
    rbufptr:integer;                    {receive buffer pointer}
    rname:string20;                     {receive file name}
    srcname:string20;                   {name of file at sending end}
    receiving:boolean;                  {indicates ftp receiver is active}
    frxpps:bytesz;                      {receiver reply PPS process number}
    frreply:byte;                       {ftp receiver reply code}
    rectype:bytesz;                     {file type to be received(not used in version 1.0)}
    recsize:word;                       {size of file to be received (not used in version 1.0)}
    {--- GET FILE ---}
    getstr:string[41];                  {name of remote file to be gotten}
    {---- TERMINAL---}
    kbinterrupt:boolean;                {keyboard has a character ready}
    kbchar:char;                        {character from keyboard}
    {--- MENU --- }
    menuexit:boolean;                   {flag to indicate to exit the menu}

procedure xpps (var xbuf:ltbarray; var xlen:integer); forward;
procedure rpps (var rbuf:ltbarray; var rstrt:integer; var rcnt:integer); 
forward;
procedure sched; forward;
procedure ctrlxmit (var dbuf:datarray; var dlen:integer; ppstat:pps); 
forward;
procedure ctrlrec (buf:ltbarray; strt, last:integer; ppstat:pps); 
forward;
procedure fsndxmit (var dbuf:datarray; var dlen:integer; ppstat:pps); 
forward;
procedure lstnerrec (buf:ltbarray; strt, last:integer; ppstat:pps); 
forward;
procedure lstnerxmit (var dbuf:datarray; var dlen:integer; ppstat:pps); 
forward;
procedure fsndrec (buf:ltbarray; strt, last:integer; ppstat:pps); 
forward;
function frecstart(buf:ltbarray; strt, last:integer):boolean; 
forward;
function rmtsndstart(buf:ltbarray; strt, last:integer):boolean; 
forward;
procedure frecxmit (var dbuf:datarray; var dlen:integer; ppstat:pps); 
forward;
procedure frecrec (buf:ltbarray; strt, last:integer; ppstat:pps); 
forward;
procedure getxmit (var dbuf:datarray; var dlen:integer; ppstat:pps); 
forward;
procedure getrec (buf:ltbarray; strt, last:integer; ppstat:pps); 
forward;
procedure termxmit (var dbuf:datarray; var dlen:integer; ppstat:pps); 
forward;
procedure termrec (buf:ltbarray; strt, last:integer; ppstat:pps); 
forward;
procedure sinker (buf:ltbarray; strt, last:integer; ppstat:pps); 
forward;
procedure menu; forward;
procedure init; forward;

{--- external procedures ----}
function serread:char; external;
procedure serwrite(c:char); external;
function kbstat: boolean; external;
function srecstat: boolean; external;
procedure modemInit (direction: iam); external;
procedure hangup; external;

{-------------------- LTB RECEIVER SECTION --------------------------------}

procedure byteprint (c: char);

{purpose: Print all characters use decimal when not a printing character}

begin
    if (ord(c) < 32) or (ord(c) = 255) then
        write ('<',ord(c),'>')
    else
        write (c);
end;


procedure getserial(var c:char); 

{purpose : Get a character for the LTB receiver from either the loopback
           buffer or the serial line  - if no character arrives 
           on the serial line by TIMEOUT return a turnaround character
}

var
   i:integer;
begin
    if loopbk then
        begin
        c := serbuf[serptr];
        if trace then byteprint (c);
        serptr := serptr +1;
        end
    else
        begin
        i:=0;
        repeat
            i:=i+1;
        until (i=timeout) or (srecstat=TRUE);
        if i=timeout then
            begin
            if trace then
                writeln ('RECEIVER TIMEOUT');
            if mynode = ORG then
                c:=ansbrkt
            else
                c:=orgbrkt;
            end
        else
            begin
            c := serread ;
            if trace then byteprint (c);
            end;
       end;
end;



procedure m41wd1 (var buf:ltbarray; var len:integer);

{purpose: Convert 3 bytes of mod 41 to 2 bytes of binary
          repeat thur entire buffer, output is placed back in 
          source buffer, length is set to the length of the converted form.
}

var
   i,j:integer;
   tmp:word;
begin
   j:=0;
   i:=0;
   while j < len do
      begin
      tmp.intval := buf[j].bte + ((buf[j+1].bte + (buf[j+2].bte*41))*41);
      buf[i].ch := tmp.byteval.lobyte;
      buf[i+1].ch := tmp.byteval.hibyte;
      j:= j+3;
      i:= i+2;
      end;
   len := i;
end;
    
    
    
procedure r41m41(var c:char);

{purpose: Converts a character from radix 41 character set to mod 41}

var
   co,cv,i:integer;
begin
   co := ord(c);
   if c = '(' then cv := 0
   else
   if (co > 47) and (co < 58) then   {'0' to '9'}
       cv := co - 47
   else
   if (co > 64) and (co < 91) then   {'A' to 'Z'}
       cv := co - 54
   else
   if c = '*' then cv := 37
   else
   if c = '+' then cv := 38
   else
   if c = '-' then cv := 9
   else
   if c = ')' then cv := 40
   else
   cv := 41;    {invalid character}
   c := chr (cv);          {convert back to char}
end;
    
    
    
procedure hdxscanner (var rbuf:ltbarray; var rcnt:integer);

{purpose: Pack incomming stream into LTB packets. Expects one 
          packet per transmission.
}
var
    turncnt, atcnt:integer;
    c:char;
begin
    if trace then begin writeln; write ('LTB REC ='); writeln; end;
    atcnt := 3;
    turncnt:=3;
    rcnt := 0;
    repeat
       getserial(c);                {get character from serial line}
       if c = '@' then
           begin
           if turncnt < 3 then turncnt := turncnt+1;
           if (rcnt = 0) and (atcnt > 0) then atcnt := atcnt -1;
           if rcnt <> 0 then atcnt := 1; {stop after first data block}
           end
       else
           if ((c=ansbrkt) and (mynode=ORG)) or ((c=orgbrkt) and (mynode=ANS)) then
               begin
               turncnt:=turncnt-1;
               end
           else
               begin
               if (rcnt < MAXR41SZ) and (atcnt = 0) then
                   begin
                   r41m41(c);
                   if ord(c)<>41 then {valid char}
                       begin
                       rbuf[rcnt].ch := c;
                       rcnt := rcnt+1;
                       end
                   end
               else
                  if atcnt < 3 then atcnt := atcnt+1;
               end
   until turncnt=0;
end;
    
    
function ckcksum (rbuf:ltbarray; rcnt:integer) : boolean;

{purpose: Check checksum of an incomming LTB packet}

var
   ck0,ck1:integer;     {running checksums}
   i:integer;
begin
   ck0 := 0;
   ck1 := 0;
   i:=0;
   while i < rcnt do
       begin
       ck0 := ck0 + ord(rbuf[i].ch);
       i:=i+1;
       ck1 := ck1 + ord(rbuf[i].ch);
       i := i+1;
       end;
   ck0 := ck0 mod 256;
   ck1 := ck1 mod 256;
   if (ck0 <> 0) or (ck1 <> 0) then
      begin
      writeln ('ck0=',ck0,' ck1=',ck1);
      ckcksum := false
      end
   else
      ckcksum := true;
end;
   
   
   
procedure ltbframer;

{purpose: Checks validity of incomming LTB packet. Updates sequence
          numbers as needed. Check to see if a character has been 
          typed on the keyboard before returning to the LTB xmitter.
}

label
    1;
var
    rbuf:ltbarray;
    rstrt, rcnt,i:integer;
    c:char;
    ch:packed array [0..0] of char;
begin
       hdxscanner (rbuf, rcnt);
       if rcnt >= MAXR41SZ then
           begin
           writeln; writeln ('REC ERROR - LTB TOO LONG');
           goto 1;
           end;
       if (rcnt mod 3) <> 0 then
           begin
           writeln; 
           writeln ('REC ERROR -  NOT MULTIPLE OF THREE RADIX-41 CHARACTERS');
           goto 1;
           end;
       m41wd1 (rbuf, rcnt);     {convert 3 byte m41 to 2 binary}
       if rcnt < 4 then
           begin
           writeln; writeln ('REC ERROR - TIMEOUT OR LTB TOO SHORT.');
           goto 1;
           end;
       if ckcksum (rbuf, rcnt) = FALSE then
          begin
          writeln; writeln ('REC ERROR - RECEIVE CHECKSUM');
          goto 1;
          end;
      if (odd(ord(rbuf[1].ch))) and (ord(rbuf[rcnt-1].ch)=0)
           then rcnt:=rcnt-1;
      rcnt:=rcnt-2;         {delete checksum bytes}
      if trace then 
         begin
         writeln;
         writeln ('RECEIVED ',rcnt,' BYTES');
         end;
      if rcnt <> ord(rbuf[1].ch) then        {lengths not equal}
           begin
           writeln; writeln ('REC ERROR - LTB LENGTH CHECK ERROR');
           goto 1;
           end;
     with rbuf[0], hdr do
         begin
         if (oa = mynode) and not loopbk or (oa <> mynode) and loopbk then
             begin
             writeln; writeln ('REC ERROR - LTB O/A MODE INCORRECT.');
             goto 1;
             end;
         if esc = 1 then  {should always be zero}
             begin
             writeln; writeln ('REC ERROR - PROTOCOL ESCAPE NON ZERO.');
             goto 1;
             end;
         if loopbk then
            xmtoob := (seq+1) mod 8
         else
            xmtoob:= oob;
         if seq = rcvoob-1 then
             begin
             writeln; writeln ('REC ERROR - DUPLICATE SEQUENCE RECEIVED.');
             if dupseqcnt = MAXDUPSEQ then
                 begin
                 datasize := datasize div 2;
                 writeln; writeln ('DATA SIZE REDUCED TO ',datasize);
                 if datasize < 8 then datasize := 8;
                 dupseqcnt := dupseqcnt + 1;
                 end
             else
                 dupseqcnt := dupseqcnt + 1;
             goto 1;
             end;
         if seq <> rcvoob then
             begin
             writeln; writeln ('REC ERROR - UNEXPECTED SEQUENCE RECEIVED.');
             goto 1;
             end
         else
             rcvoob:=(rcvoob+1) mod 8;
             rstrt := LTBHDLEN;
         end;
         {if length less than or equal to LTBHDLEN then no data in this LTB}
         if rcnt > LTBHDLEN then rpps (rbuf, rstrt, rcnt);
1:
if sch<>done then sch := xltb;

if kbstat then {this is a safe place to check for a keyboard interrupt}
    begin
    unitread(2,ch[0],1,0,0);
    if ch[0]=chr(ATTENCHAR) then 
        menu
    else
        begin
        kbinterrupt:=TRUE;
        kbchar:=ch[0]
        end
    end
end;

{--------------- LTB XMITTER SECTION ----------------------------}



procedure mkhdr(var buf:ltbarray; length:integer);

{purpose: Create LTB header for packet to sent}

begin
    with buf[0], hdr do
    begin
        oob := rcvoob;
        seq := (xmtgen+7) mod 8;
        esc := 0;
        oa  := mynode;
    end;
    buf[1].ch := chr(length);
end;
    
    
    
procedure gencksum( var buf:ltbarray; var len:integer );

{purpose: Generate checksum for LTB packet to be sent}

var ck0,ck1,i:integer;
begin
    ck0 := 0; ck1 := 0;
    i := 0;
    buf[ ord(buf[1].ch) ].ch := chr(0);
    while i<ord(buf[1].ch) do
        begin
        ck0 := ck0+ ord(buf[i].ch);
        i := i+1;
        ck1 := ck1 + ord(buf[i].ch);
        i := i+1;
        end;
    len := ord( buf[1].ch );
    buf[len+(len mod 2)].ch := chr( 256 - (ck0 mod 256) );
    buf[len+((len + 1) mod 2)].ch := chr( 256 - (ck1 mod 256) );
    len := len + 2;
    if odd(len) then
        begin
            buf[len].ch := chr(0);
            len := len + 1;
        end;
end;
        


procedure binm41(inbuf:ltbarray; var outbuf:ltbarray; inlen:integer;var otlen:integer);

{purpose: Convert incomming buffer from binary to mod 41 and place in output buffer}

var i,k,out,dtmp:integer;
    wd,tmp:word;
begin
    out:=0;
    i:=0;
    while i<inlen do
        begin
        wd.byteval.lobyte := inbuf[i].ch;
        i:=i+1;
        wd.byteval.hibyte := inbuf[i].ch;
        i:=i+1;
        for k:=0 to 2 do
            begin
            if wd.intval < 0 then   {correct for overflow problem}
                begin
                tmp.byteval.lobyte := wd.byteval.hibyte;
                tmp.byteval.hibyte := chr (0);
                dtmp := (tmp.intval div 41)*256;
                tmp.intval := tmp.intval mod 41;
                wd.byteval.hibyte := tmp.byteval.lobyte;
                end
            else
                dtmp := 0;
                
            outbuf[out+k].ch := chr( wd.intval mod 41 );
            wd.intval  := (wd.intval div 41) + dtmp;
            end;
        out:=out+3;
        end;
    otlen:=out;
end;



procedure m41r41( var buf:ltbarray; len:integer);

{purpose: Convert buffer from mod 41 to radix 41 character set}

var i:integer;
begin
    for i:=0 to len-1 do
        buf[i].ch := r41[ ord( buf[i].ch ) + 1 ];
end;



procedure putserial( c:char );

{purpose: Put a character out to either the loopback buffer or the
          the serial line
}
begin
    if loopbk then
        begin
        serbuf[serptr] := c;
        serptr := serptr+1;
        end
    else
        begin
        serwrite(c);
        end;
    if trace then byteprint(c);
end;



procedure endxmit;

{purpose: Send turnaround characters.}

var
   i:integer;
begin
   for i:=1 to 5 do
      begin
      if mynode = ANS then
          putserial ('[')
      else
          putserial (']');
      end;
end;
      
      
      
procedure xmitblk( buf:ltbarray; len:integer);

{purpose: Send the LTB buffer.}

var i:integer;
begin
    for i:=0 to 6 do
        putserial( '@' );
    for i:=0 to len-1 do
        putserial( buf[i].ch );
    putserial( '@' );
end;



procedure ltbsend(var xbuf:ltbarray; xlen:integer);

{purpose: Create an LTB packet containing the data, send it,
          and do turnaround.
}

var
   i:integer;
begin
        if trace then 
           begin
           writeln;
           writeln ('XMIT ',xlen,' BYTES');
           end;
        mkhdr (xbuf, xlen);              {update header info}
        gencksum (xbuf, xlen);           {generate checksum, return total length} 
        if trace then
            begin
            writeln;
            for i:=0 to xlen-1 do
               byteprint (xbuf[i].ch);
            writeln;
            end;
        binm41(xbuf,tbuf,xlen,tlen);        {convert to m41}
        m41r41(tbuf,tlen);                  {convert to r41}
        xmitblk(tbuf,tlen);                    {transmit}
        endxmit;
end;
    
    
    
procedure xmitltb;

{purpose: Determine if the previous packet must be retransmitted or
          if a new packet can be sent. In the case of excessive 
          retransmission attempts aborts the program.
}
var
  ylen:integer;
begin
   if rexmtcnt >= MAXREXMIT then
       begin
       writeln;
       writeln ('EXCESSIVE RETRANSMISSION ATTEMPTS -- CONNECTION ABORTED');
       sch := done;
       end
   else
       begin
       if xmtoob = xmtgen then  
           begin
           xlen := 2;
           xpps (xbuf, xlen);
           rexmtcnt := 0;
           dupseqcnt := 0;
           xmtgen := (xmtgen+1) mod 8;     {increment seq number}
           ylen := xlen;
           ltbsend (xbuf, ylen);
           end
       else
           begin
           rexmtcnt := rexmtcnt+1;
           ylen := xlen;
           ltbsend (xbuf, ylen);
           end;
       end;
if sch<>done then sch := rltb;
end;


{----------- LTB GENERAL ------------------------------------}


procedure sched;

{purpose: Low level dispatcher for the LTB receiver and transmitter.}

begin
    repeat
         serptr := 0;
         case sch of
             xltb:xmitltb;
             rltb:ltbframer;
             end;
   until sch=done;
end;
             
             
             
procedure ltbinit;

{purpose: Initialize LTB values at startup.}
begin
    { Define radix 41 character set. }
    r41 := '(0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ*+-)';
    xmtgen := 0;
    rcvoob := 0;
    xmtoob := 0;
    rexmtcnt := 0;
    serptr:=0;
    dupseqcnt := 0;
    datasize := MAXDATASZ;
    if loopbk then
        sch := xltb
    else
        sch := rltb;
end;


{-------------------- PPS TRANSMIT  --------------------------}



procedure ppsinit;

{purpose:Initialize PPS tables at startup.}

var 
  i:integer;
begin
    for i:= 0 to XPPSTBLSZ do
        begin
        with xppstbl[i] do
            begin
            active := FALSE;
            ppsnum := i;
            end;
        end;
    for i:= 0 to RPPSTBLSZ do
        begin
        rppstbl[i].active := FALSE;
        end;
    pollpps:=0;
end;



procedure ppsopen (src, dest:integer; var ppsno:bytesz);

{purpose: Open a new xmit PPS, enter the source and the destination process
          numbers in the xmit PPS table. The number of the PPS that is opened
          is returned to the caller.
}
begin
   ppsno := 0;
   while xppstbl[ppsno].active and (ppsno<>XPPSTBLSZ) do
        ppsno := ppsno+1;
   if ppsno = XPPSTBLSZ then
      begin
      writeln; writeln('PPS xmit table full');
      end
   else
      begin
      with xppstbl[ppsno] do
          begin
          active := TRUE;
          srcproc := src;
          destproc := dest;
          pseq := 0;
          fstblk := TRUE;
          lstblk := FALSE;
          if ppsmon then
             begin
             writeln; writeln ('Opening xmit PPS ',ppsno,' source ',src,
                                ' destination ',dest);
             end;
          end;
     end;
end;



procedure ppsclose (ppsno:bytesz);

{purpose: Close the specified xmit PPS number. 
          Note: One more transmission (last block) will occur on this stream.
}
begin
    if xppstbl[ppsno].active = FALSE then
        begin
        if ppsmon then
            begin
            writeln; writeln ('Request to close inactive xmit PPS ',ppsno);
            end
        end
    else
        begin
        xppstbl[ppsno].lstblk := TRUE;
        if ppsmon then
            begin
            writeln; writeln ('Closing xmit PPS ',ppsno);
            end;
        end;
end;


procedure mkppshdr (var xbuf:ltbarray; var xlen:integer;
                    dbuf:datarray; dlen:integer; ppsno:integer);

{purpose: Build the PPS header.}

var
   i,len:integer;
begin
   with xppstbl[ppsno] do
       begin
       if ppsmon then
           begin
           writeln; 
           write ('Sending PPS ',ppsno,' seq no ',pseq);
           if fstblk then write(' - first block');
           if lstblk then write(' - last block');
           end;
       with  xbuf[xlen], ppsh do
          begin
          fst := fstblk;    
          lst := lstblk;
          fil := 0; {zero filler}
          seq := pseq;
          end;
       xbuf[xlen+1].ch := chr(ppsno);
       if fstblk then
           begin
           xbuf[xlen+2].ch := chr(dlen+5);
           len:=dlen+5;
           xbuf[xlen+3].ch := chr(srcproc);
           xbuf[xlen+4].ch := chr(destproc);
           xlen := xlen+5;
           fstblk := FALSE;
           end
       else
           begin
           xbuf[xlen+2].ch := chr(dlen+3);
           len:=dlen+3;
           xlen := xlen+3;
           end;
       if ppsmon then writeln (' - length ',len);
       pseq := (pseq +1) mod 8;
       if lstblk then
           begin
           active := FALSE;    
           lstblk := FALSE;
           end;
       end;
   
   for i:=0 to dlen-1 do {move user data to xmit buffer}
       begin
       xbuf[xlen].ch := dbuf[i].ch;
       xlen := xlen+1;
       end;
end;
             


procedure xpps;

{purpose: Poll processes with active xmit PPS's for one with something
          to send.
}

var
   dbuf:datarray;
   orgxlen,dlen:integer;
   ppstat:pps;
   ppsno:bytesz;
begin
    orgxlen := xlen;
    dlen :=0;
    ppsno:= pollpps;    {Continue from where last poll + 1}
    repeat  {poll sending processes for out going}
       if xppstbl[ppsno].active then
           begin
           ppstat := xppstbl[ppsno];
           with ppstat do
               begin
               case ord(srcproc) of
                   {as you can see dynamic process creation is impossible}
                   CTRL:   ctrlxmit (dbuf, dlen, ppstat);
                   LSTNER: lstnerxmit (dbuf, dlen, ppstat);
                   FTPREC: frecxmit (dbuf, dlen, ppstat);
                   FTPSND: fsndxmit (dbuf, dlen, ppstat);
                   TERM:   termxmit (dbuf, dlen, ppstat);
                   GETFILE:    getxmit  (dbuf, dlen, ppstat);
                   end;
               if (dlen>0) or fstblk or lstblk then
                   mkppshdr (xbuf, xlen, dbuf, dlen, ppsno);
               end;
           end;
       ppsno := (ppsno +1)mod XPPSTBLSZ;
    until (ppsno = pollpps) or (xlen > orgxlen);
    pollpps := ppsno;
end;



{--------- PPS RECEIVER ---------------}

procedure rpps; 

{purpose: Check incomming PPS packets and pass to destination process.}

label
   1;
var
   i:integer; {debug}
   index,ppsno:bytesz;
   ppstat:pps;
begin
   ppsno := rbuf[rstrt+1].bte;
   if ppsmon then
      begin
      writeln; writeln ('Receiving PPS ',ppsno,' length ',rbuf[rstrt+2].bte);
      end;
   index:=0;
   while (index<RPPSTBLSZ) and ((rppstbl[index].ppsnum <> ppsno) or
          (rppstbl[index].active=FALSE))  do index := index+1;
   with rbuf[rstrt].ppsh do
       begin
       if index=RPPSTBLSZ then {not in table}
           begin
           if not fst then 
               begin
               writeln;
               writeln ('PPS ERROR - received packet on inactive PPS number ',ppsno);
               goto 1;
               end
           else {add new pps to table}
               begin
               index:=0;
               while (index<RPPSTBLSZ) and rppstbl[index].active do
                    index:=index+1;
               if index=RPPSTBLSZ then
                   begin
                   writeln;writeln('PPS RECEIVE TABLE FULL');
                   goto 1;
                   end
               else
                   begin
                   with rppstbl[index] do
                       begin
                       ppsnum := ppsno;
                       active := TRUE;
                       srcproc := ord(rbuf[rstrt+3].ch);
                       destproc := ord(rbuf[rstrt+4].ch);
                       pseq := 0;
                       if ppsmon then
                          begin
                          writeln; 
                          writeln ('Receiving new PPS ',ppsnum,' source ',
                                    srcproc,' destination ',destproc);
                          end;
                       rstrt := rstrt + 2;
                       end;
                   end;
               end;
           end
       else {found active pps in table}
           begin
           if fst then
              begin
              writeln;
             writeln ('PPS ERROR - RECEIVED UNEXPECTED FIRST BLOCK ON ',ppsno);
              goto 1;
              end;
          end;
          
       {if we get this far this is an active pps}
       with rppstbl[index] do
              begin
              rstrt := rstrt + 3;
              fstblk := fst;
              lstblk := lst;
              if seq <> pseq then
                  begin
                  writeln;
                  writeln ('REC PPS ERROR - unexpected sequence number ',seq);
                  pseq := seq; {for now we simply correct set the number}
                  end
              else
                  pseq := (pseq+1) mod 8;
              if lst then active := FALSE;
              end;
       ppstat := rppstbl[index];
       case ord(ppstat.destproc) of
           CTRL:   ctrlrec ( rbuf, rstrt, rcnt-1, ppstat);
           LSTNER: lstnerrec ( rbuf, rstrt, rcnt-1, ppstat);
           FTPREC: frecrec ( rbuf, rstrt, rcnt-1, ppstat);
           FTPSND: fsndrec ( rbuf, rstrt, rcnt-1, ppstat);
           TERM:   termrec ( rbuf, rstrt, rcnt-1, ppstat);
           GETFILE:    getrec  ( rbuf, rstrt, rcnt-1, ppstat);
           SINK:   sinker (rbuf, rstrt, rcnt-1, ppstat);
           end;
      end;
1:
end;


procedure rppsredirect (ppsno, newdest:bytesz);

{purpose: Redirect all further packets received on the specified PPS stream to
          the specified destination process.
}
var
    index:integer;
begin
   index:=0;
   while (index<RPPSTBLSZ) and ((rppstbl[index].ppsnum <> ppsno) or
          (rppstbl[index].active=FALSE))  do index := index+1;
   if index<>RPPSTBLSZ then
       begin
       with rppstbl[index] do
           begin
           destproc:=newdest;
           if ppsmon then
               begin
               writeln;
 writeln ('PPS REC - Redirecting PPS ',ppsnum,' to destination ',destproc);
               end;
           end;
      end;
end;

{------------------ SINK ----------------------}
{a dummy receiver process to dump unwanted input }
procedure sinker;
begin
end;



{--------------- CONTROL PROCESS ----------------------}

{In version 1.0 this process only sends the system address.}
procedure ctrlinit;
begin
   ppsopen (CTRL, CTRL, ctrlppsno);
end;

procedure ctrlxmit;
var
  i:integer;
  sysname: string[40];
begin
   sysname := SYSTEMNAME;
   if ppstat.fstblk then
      begin
      for i:=1 to length (SYSTEMNAME) do
          dbuf[i-1].ch:=sysname[i];
      dlen:=i-1
      end
end;

procedure ctrlrec;
var
   i:integer;
begin
    for i:=strt to last do
        byteprint (buf[i].ch);
end;

{--------------- FTP SENDER ---------------------------}



procedure fsndinit;

{purpose: Initialize ftp sender at startup.}

begin
    fsndstate:=idle;
    xfiletype:=0;
    xfilesize.intval:=0;
end;



procedure ftpstart;

{purpose: Does setup for file sending when requested locally.}         

var 
  cnt:integer;
begin
    if fsndstate<>idle then
        begin
        {$I-}
        writeln;writeln ('Sender is busy transfering ',xname,' to ',destname);
        write ('Do you wish to abort this transfer ? (Y/N):');
        read (c);
        writeln;
        if c in ['Y','y'] then
            begin {set up conditions that indicate end to sender}
            fsndstate:=extabort;
            fsndcode:=PDN + AF; {abort receiver}
            menuexit := TRUE;
            end;
        end
    else
        begin
        writeln; writeln; write ('Name of file to be sent: ');
        readln (xname);
        writeln; write ('Name of destination file: ');
        readln (destname);
        writeln;
        reset (xfile, xname);
        if IORESULT <> 0 then 
            begin
            writeln ('Unable to open ',xname);
            end
        else
            begin
               fsndstate:=initiate;
               ppsopen (FTPSND, LSTNER, xppsno);
               menuexit := TRUE;
           end;
       end;
    {$I+}
end;



function rmtsndstart;

{purpose: Does setup for file sending when requested from remote.}

var
    i,slash:integer;
begin
   {$I-}
   {$R-}
   if fsndstate<>idle then {already busy}
       rmtsndstart:=FALSE 
   else
       begin
       i:=strt;
       while buf[i].ch<>'/' do i:=i+1;
       slash:=i;
       xname[0]:=chr(slash-strt);  {See Note 1}
       for i:= 0 to slash-strt do
           xname[i+1]:=buf[strt+i].ch;
       destname[0]:=chr(last-slash); {See Note 1}
       for i:=1 to last-slash do
           destname[i]:=buf[slash+i].ch;
       if ftpmon then
           begin
           writeln;writeln ('Remote start opening ',xname,' to ',destname);
           end;
       reset (xfile, xname);
       if IORESULT<>0 then   {counld not open file}
           rmtsndstart:=FALSE 
       else
           begin
           ppsopen (FTPSND, LSTNER, xppsno);
           fsndstate:=initiate;
           rmtsndstart:=TRUE
           end
       end
{$R+}
{$I+}
end;


procedure fsndxmit;

{purpose: Transmits file contents to FTP receiver.}

var
    i, cnt:integer;
    c:char;
    tmpstr:string[41];
begin
    if (fsndstate=terminate) or (fsndstate=extabort) then
        begin
        ppsclose (xppsno);
        close (xfile);
        dbuf[dlen].bte:=fsndcode;
        dlen := 1;
        if fsndstate=extabort then
            fsndstate:=idle
        else
            fsndstate:=ack;
        end;
    
    while (dlen<datasize) and (fsndstate=send) do
       begin
       if xbufptr = BLKSZ then        {get next blk from disk}
           begin
           write ('.');
           if EOF(xfile) then {note: this eof occurred on the previous read}
               begin
               fsndstate:=terminate;
               fsndcode:= PD + AF;
               end
           else
               begin
               {$I-}
               cnt := blockread (xfile, xblk, 1, xfilptr);
               {$I+}
               xfilptr := xfilptr+1;
               if IORESULT <> 0 then
                   begin
                   fsndstate:=terminate;
                   fsndcode:=PDN + AF;
                   writeln; 
                   writeln ('File sender I/O error ',IORESULT,' file ',
                             xname,'...');
                   end
               else
                   xbufptr := 0;
               end
           end
       else
          begin
          dbuf[dlen].ch := xblk[xbufptr];
          if ftpmon then 
              byteprint (dbuf[dlen].ch);
          dlen := dlen+1;
          xbufptr := xbufptr+1;
          end;
      end;
   
   if (fsndstate=initiate) and ppstat.fstblk then
      begin
      writeln;
      write ('Request to transfer ',xname,' to ',destname,'...');
      dbuf[0].bte:= PD + RF;  { please do receive file}
      dbuf[1].bte:= xfiletype; {always 0 in version 1.0}
      dbuf[2].ch:= xfilesize.byteval.lobyte; {in blocks - 0 if not known}
      dbuf[3].ch:= xfilesize.byteval.hibyte; {in blocks - 0 if not known}
      dlen:=3;
      tmpstr:= concat(xname,'/',destname);
      for i:= 1 to length(tmpstr) do
          dbuf[i+dlen].ch:=tmpstr[i];
      dlen:=i+dlen;
      xeof:= FALSE;
      xbufptr := BLKSZ;
      xfilptr:=0;
      fsndstate:=request;
      end 
end;



procedure fsndrec;

{purpose: Receives control information from FTP receiver.}

begin
   case fsndstate of
      request:
               if buf[strt].bte= (IW + RF) then { i will receive file}
                   begin
                   writeln ('accepted');
                   fsndstate:=send;
                   end             
               else
                   begin
                   writeln ('refused');
                   fsndstate:=extabort;
                   end;
     
     ack:
              begin
              if buf[strt].bte= (IW + AF) then { i will accept this file}
                  writeln('accepted')
              else
                  writeln ('refused - code: ',buf[strt].bte);
              fsndstate:=idle
              end;
     
     send:    
              if buf[strt].bte= (IWN + AF)  then
                  begin
                  writeln;
                  writeln ('Transfer of ',xname,' to ',rname,' aborted by receiver.');
                  fsndcode:=PDN + AF;
                  fsndstate:=extabort;
                  end
     end
 end;

{------- LISTNEER ------------}

{ This process acts as a well known process to setup file transfers.}

procedure lstnerrec;

{purpose: Receiver for listener.}

var
    i:integer;
    begin
    {$I-}
    if ppstat.fstblk then
        begin
        if ftpmon then
            begin
            writeln; writeln ('Listener requested to:',buf[strt].bte);
            end;
        if buf[strt].bte= (PD + RF) then { please receive file}
            begin
            ppsopen (LSTNER, ppstat.srcproc, lstnerxpps);
            ppsclose (lstnerxpps);
            strt:=strt+1;
            if frecstart (buf,strt,last) then {FTP receiver ready}
                begin
                lstnreply.bte:= IW + RF;  { i will receive file};
                rppsredirect (ppstat.ppsnum, FTPREC)
                end
            else {receiver not ready}
                begin
                lstnreply.bte := IWN + RF; { i will not receive file}
                rppsredirect (ppstat.ppsnum, SINK) {sink any futher input}
                end
            end
        else
            if buf[strt].bte= (PD + SF) then { please do send file}
                begin
                ppsopen (LSTNER, ppstat.srcproc, lstnerxpps);
                ppsclose (lstnerxpps);
                strt:=strt+1;
                if rmtsndstart(buf, strt, last) then 
                    lstnreply.bte := IW + SF { i will send file}
                else
                    lstnreply.bte := IWN + SF; { i will not send file}
                if ftpmon then
                    begin
                    writeln; 
                    write ('LISTENER - remote request to transfer ');
                    if lstnreply.bte= (IWN + SF) then
                        writeln(' refused')
                    else
                        writeln(' accepted');
                    end;
                end
            else {unknown request}
               if ftpmon then
                   begin
                   writeln;
                   writeln ('LISTENER - Unknown request type ',buf[strt].bte)
                   end;
       end
    else {not first block}
        if ftpmon then
            begin
            writeln;
            writeln ('LISTENER - Not first block on PPS ',ppstat.ppsnum);
            end;
{$I+}
end;



procedure lstnerxmit;

{purpose: Sends listener control responses.}

begin
   dbuf[0].ch := lstnreply.ch;
   dlen:=1;
   if ftpmon then
       begin
       writeln; writeln ('Listener reply:',lstnreply.bte);
       end;
end;



{------- FTP RECEIVER -------------}

procedure frecinit;

{purpose: Initializes FTP receiver at startup.}

begin
    receiving:=FALSE;
end;



function frecstart;

{purpose: Setup receiver for a file transfer.}

var
  slash,i:integer;
begin
    frecstart:=FALSE;
    if not receiving then 
         begin {initialization for receiver }
         rectype:=buf[strt].bte;
         strt:=strt+1;
         recsize.byteval.lobyte:=buf[strt].ch;
         strt:=strt+1;
         recsize.byteval.hibyte:=buf[strt].ch;
         i:=strt+1;
         while buf[i].ch<>'/' do i:=i+1;
         slash:=i;
         {$R-}
         srcname[0]:=chr(slash-strt-1);  {See Note 1}
         {$R+}
         for i:= 1 to slash-strt-1 do
             srcname[i]:=buf[strt+i].ch;
         {$R-}
         rname[0]:=chr(last-slash);  {See Note 1}
         {$R+}
         for i:=1 to last-slash do
             rname[i]:=buf[slash+i].ch;
         writeln('Receiving file ',rname,' from ',srcname,
                 ' type=',rectype,' size (blocks)=',recsize.intval);
         {$I-}
         reset (rfile,rname);
         if IORESULT=0 then {file already exists}
            begin
            writeln ('Local file ',rname,' already exists, transfer aborted.');
            close (rfile);
            end
         else
            begin
            rewrite (rfile, rname);
            if IORESULT<>0 then
               writeln ('Unable to create local file ',rname)
            else
               begin
               rfilptr:=0;
               rbufptr := 0;
               receiving := TRUE;
               frecstart:=TRUE;
               end
           end
    end
{$I+}
end;


procedure frecrec;

{purpose: Receives data sent by FTP sender.}

var
cnt,i:integer;
begin
    {$I-}
    if ppstat.lstblk then  {last block of a file transfer}
       begin
       receiving := FALSE;
       writeln;
       if buf[strt].bte= (PDN + AF) then
           begin
           close (rfile);
           rppsredirect (ppstat.ppsnum, SINK);
           writeln ('Received abort request on transfer of ',rname);
           end
       else
           begin
           close (rfile, lock);
           if IORESULT <> 0 then
              begin
              writeln ('FTP REC - close error ',IORESULT,' on ',rname);
              ppsopen (FTPREC, ppstat.srcproc, frxpps);
              ppsclose (frxpps);
              frreply.bte:=IWN + AF;
              end
           else
              begin
              writeln ('FTP REC - transfered ',rfilptr,' blocks to ',rname);
              ppsopen (FTPREC, ppstat.srcproc, frxpps);
              ppsclose (frxpps);
              frreply.bte:=IW + AF; {i will accept file}
              end
           end
       end;
    
    if ppstat.fstblk then   {the first block of a file transfer}
        begin
        if ftpmon then 
             begin
             writeln;
             writeln ('FTP REC - received unexpected first block from ',
                      ppstat.ppsnum)
             end
       end
    else {not first block}
       if receiving then
          begin
          if ftpmon then
             begin
             writeln;
             writeln ('REC=');
             end;
          i:= strt;
          while (i<=last) and (receiving) do
             begin
             rblk[rbufptr] := buf[i].ch;
             if ftpmon then 
                 byteprint (rblk[rbufptr]);
             i:=i+1;
             rbufptr := rbufptr+1;
             if rbufptr = BLKSZ then
                begin
                write (',');
                cnt := blockwrite (rfile, rblk, 1, rfilptr);
                rfilptr := rfilptr+1;
                rbufptr := 0;
                if IORESULT <> 0 then
                   begin
                   receiving := FALSE;
                   writeln;
                   frreply.bte:=IWN + AF; {i will not accept file}
                   end;
                end;
             end;
        end;
    
{$I+}
end;
    

procedure frecxmit;

{purpose: Sender FTP receiver control messages to FTP sender.}

begin
   dbuf[0].ch := frreply.ch;
   dlen:=1;
end;



{------------ GET - REQUEST A FILE FROM REMOTE ----------------}

{Local process to request a file from remote node.}

procedure getftp;

{purpose: Get name of remote file from user.}

var
    getxpps:bytesz;
    gname,localname:string[20];
begin
    writeln;writeln; write ('Transfer remote file: ');
    readln (gname);
    writeln;
    write ('To local file: ');
    readln (localname);
    writeln;
    write ('Transfer of ',gname,' to ',localname,'...');
    ppsopen (GETFILE, LSTNER, getxpps);
    ppsclose (getxpps);
    getstr:=concat (gname,'/',localname);
    menuexit:=TRUE;
end;


procedure getxmit;

{purpose: Send remote transfer request to remote listener.}

var
    i:integer;
begin
   dbuf[0].bte:= PD + SF; { please  do send file}
   for i:=1 to length(getstr) do
       dbuf[i].ch:=getstr[i];
   dlen:=i;
end;

procedure getrec;
begin
    if buf[strt].bte= (IW + SF) then {i will send file}
        writeln ('initiated')
    else
        writeln ('refused - code: ',buf[strt].bte);
end;



{----------------- TERMINAL PROCESS --------------------------------}

procedure terminit;

{purpose: Initialize terminal process at setup time.}

begin
   kbinterrupt:=FALSE;
   ppsopen (TERM, TERM, termppsno);
end;


procedure termrec;

{purpose: Receive messages from remote terminal process.}

var
   i:integer;
begin
  writeln ;
  for i:=strt to last do
      begin
      write (buf[i].ch);
      end;
  writeln;
end;



procedure termxmit;

{purpose: Send ~erminal communications to remote terminal process.}

var
   c : char;
   chc:packed array[0..0] of char;
begin
   if kbinterrupt then          {user wants wants to talk}
       begin
       kbinterrupt:=FALSE;
       writeln;
       write ('> ');
       write (kbchar);
       dbuf[0].ch := kbchar;
       dlen := dlen+1;
       while (dbuf[dlen-1].ch<>chr(13)) and (dlen<datasize) do
           begin
           unitread (2,chc[0], 1,0,0);
           dbuf[dlen].ch:=chc[0];
           write (dbuf[dlen].ch);
           dlen := dlen +1;
           end;
       end;
end;

{------------ RAW TERMINAL MODE ---------------}

{Process which allows raw data typed on the terminal to be sent over
 the serial line, used for debugging. Also used to allow login to timesharing
 systems.
 }

procedure rawterm;
var 
   c:char;
   termdone:boolean;
   ch:packed array [0..0] of char;
begin
    termdone:=FALSE;
    repeat
        if kbstat then
            begin
            unitread (2,ch[0],1,0,0);
            if ch[0]=chr(ATTENCHAR) then 
               termdone:=TRUE
            else 
               begin
               write(ch[0]);
               putserial(ch[0])
               end
            end;
        if srecstat then
            begin
            c:=serread;
            write (c);   
            end;
   until termdone=TRUE;
end;

{--------------------- MENU ---------------------------}

    
procedure monitor;

{purpose: Allows the user to control tracing for debugging.}

begin
    repeat
        writeln;
        write('Trace LTB ? (Y/N)');
        read(c);
        case c of
        'y','Y': trace := TRUE;
        'n','N': trace :=FALSE;
        end;
    until c in ['y','Y','n','N'];
    repeat
        writeln;
        write('Trace PPS ? (Y/N)');
        read(c);
        case c of
        'y','Y': ppsmon := TRUE;
        'n','N': ppsmon :=FALSE;
        end;
    until c in ['y','Y','n','N'];
    repeat
        writeln;
        write('Trace FTP ? (Y/N)');
        read(c);
        case c of
        'y','Y': ftpmon := TRUE;
        'n','N': ftpmon :=FALSE;
        end;
    until c in ['y','Y','n','N'];
    repeat
        writeln;
        write('Local loopback test ? (Y/N)');
        read(c);
        case c of
        'y','Y': begin
                     ansbrkt:=']'; orgbrkt:='[';
                     loopbk := TRUE;
                 end;
        'n','N': begin
                     ansbrkt:='['; orgbrkt:=']';
                     loopbk := FALSE;
                 end
        end;
    until c in ['y','Y','n','N'];
    writeln; write ('Enter data size: ');
    readln (datasize);
    if (datasize < 8) or (datasize >MAXDATASZ) then datasize := MAXDATASZ;
    writeln;
end;


procedure exiter;

{purpose : Terminates PTP program after warning user if transfers are in progress.}

var
   c:char;
begin
   {$I-}
   if receiving or (fsndstate <> idle) then
      begin
      writeln; 
      write('Currently engaged in file transfer.');
      writeln; write ('Are you sure you want to exit? (Y/N): ');
      read (c);
      if (c='Y') or (c='y') then
          begin
          close (rfile,lock);
          close (xfile);
          hangup;
          exit(ptp);
          end;
      end
   else
      begin
      hangup;
      exit(ptp);
      end;
{$I+}
end;

      
procedure menu;

{purpose: Main menu loop.}

begin
    menuexit := FALSE;
    repeat
        writeln;
        write ('G(et S(end M(onitor R(aw  I(nitialize E(xit: ');
        read (c);
        case c of
            'S','s':ftpstart;
            'E','e':exiter;
            'M','m':monitor;
            'R','r':rawterm;
            'I','i':init;
            'G','g':getftp;
            end;
    until eoln or menuexit;
end;


{------------------- INITIALIZATION  -----------------}

procedure init;

{purpose: Calls individual initialization procedures.}

begin
    ltbinit;
    ppsinit;
    ctrlinit;
    terminit;
    frecinit;
    fsndinit;
    modemInit (mynode);
end;
    
begin    {main}
    writeln;
    writeln ('Pascal Transfer Program (PTP) Version 1.0 7/24/79');
    writeln;
    trace := FALSE;
    ppsmon := FALSE;
    ftpmon := FALSE;
    loopbk := FALSE;
    ansbrkt := '[';
    orgbrkt := ']';
    repeat
        writeln;
        write('Answer or Originate ? (A/O)');
        read(c);
        case c of
        'a','A': begin
                 mynode := ANS;
                 timeout := ANSTIMEOUT
                 end;
        'o','O': begin
                 mynode := ORG;
                 timeout := ORGTIMEOUT
                 end;
        end;
    until c in ['a','A','o','O'];
    writeln;
    init;
    if mynode = ANS then
        begin
        for i:=0 to 10000 do;           {should really wait for carrier detect}
        endxmit
        end;
   sched;
   hangup;
end.


========================================================================================
DOCUMENT :usus Folder:VOL2A:punch.tape.text
========================================================================================


(* Program Author:   Walter Hess
                     1460 Seven Pines Rd.
                     Schaumberg, IL 60193
                     
                                                        *)
                                                        
(*              RTAPE and PUNCH
               
                    If you have the HEATH Paper Tape System, 
               these two programs will transfer files between 
               the paper tape system and disc files.  I have not 
               used them much but I believe they work OK.*)
               
(*$L SCRVOL:LPUNCH.TEXT*)
PROGRAM PUNCH;
(* VERSION "O"  06/11/79  WIH *)
TYPE
  LSTR = STRING[132];
  POINTER = ^CHAR;

VAR
  PCH,PCHS : POINTER;
  INSTR,FLSTR : LSTR;
  INFIL : TEXT;
  J : INTEGER;

PROCEDURE INITPT (VAR PNT,PNTS : POINTER);
CONST
  PUNCHADD = -146;

TYPE
  REP = (POINTREP,INTREP);
  ALIAST = RECORD
    CASE REP OF
      POINTREP:
        (POINTVAL : POINTER);
      INTREP:
        (INTVAL : INTEGER);
    END; (* CASE *)

VAR
  ALIAS : ALIAST;

BEGIN
  ALIAS.INTVAL := PUNCHADD;
  PNT := ALIAS.POINTVAL;
  ALIAS.INTVAL := PUNCHADD - 2;
  PNTS := ALIAS.POINTVAL;
END;

PROCEDURE WASTE;
VAR
  K : INTEGER;

BEGIN
  REPEAT
    K := ORD(PCHS^);
  UNTIL K = 128;
END;

PROCEDURE PUNCHST (PUSTR : LSTR);
VAR
  J : INTEGER;

BEGIN
  FOR J := 1 TO LENGTH(PUSTR) DO
  BEGIN
    PCH^ := PUSTR[J];
    WRITE(PUSTR[J]);
    WASTE;
  END;
  PCH^ := CHR(13);
  WRITE(CHR(13));
  WASTE;
END;


BEGIN (* MAIN PROGRAM *)
  INITPT(PCH,PCHS);
  WRITELN(' ENTER NAME OF FILE TO BE PUNCHED');
  READLN(FLSTR);
  RESET(INFIL,FLSTR);
  FOR J := 1 TO 100 DO
  BEGIN
    PCH^ := CHR(0);
    WASTE;
  END;
  REPEAT
    READLN(INFIL,INSTR);
    PUNCHST(INSTR);
  UNTIL EOF(INFIL);
  PCH^ := CHR(4);
  WASTE;
  FOR J := 1 TO 100 DO
  BEGIN
    PCH^ := CHR(0);
    WASTE;
  END;
  CLOSE(INFIL)
END.

========================================================================================
DOCUMENT :usus Folder:VOL2A:randombyte.text
========================================================================================

        .FUNC    RANDIT,0
        LD      A,R
        LD      B,0
        LD      C,A
        POP     HL
        PUSH    BC
        JP      (HL)
        .END


========================================================================================
DOCUMENT :usus Folder:VOL2A:read.tape.text
========================================================================================


(* Program Author:   Walter Hess
                     1460 Seven Pines Rd.
                     Schaumberg, IL 60193
                     
                                                        *)
                                                        
(*          RTAPE and PUNCH
               
                    If you have the HEATH Paper Tape System, 
               these two programs will transfer files between 
               the paper tape system and disc files.  I have not 
               used them much but I believe they work OK.*)
               
               
(*$L SCRVOL:LRTAPE.TEXT*)
PROGRAM RTAPE;
(* VERSION "O"  06/12/79  WIH *)
TYPE
  LSTR = STRING[132];
  POINTER = ^CHAR;

VAR
  PCH,PCHS : POINTER;
  INSTR,FLSTR : LSTR;
  OUTFIL : TEXT;
  J : INTEGER;
  CH : CHAR;

PROCEDURE INITR (VAR PNT,PNTS : POINTER);
CONST
  RTAPEADD = -150;

TYPE
  REP = (POINTREP,INTREP);
  ALIAST = RECORD
    CASE REP OF
      POINTREP:
        (POINTVAL : POINTER);
      INTREP:
        (INTVAL : INTEGER);
    END; (* CASE *)

VAR
  ALIAS : ALIAST;

BEGIN
  ALIAS.INTVAL := RTAPEADD;
  PNT := ALIAS.POINTVAL;
  ALIAS.INTVAL := RTAPEADD - 2;
  PNTS := ALIAS.POINTVAL;
END;

PROCEDURE GETCH;
VAR
  K : INTEGER;

BEGIN
  PCHS^ := CHR(1);
  REPEAT
    K := ORD(PCHS^)
  UNTIL K = 128;
  CH := PCH^;
END;

BEGIN (* MAIN PROGRAM *)
  INITR(PCH,PCHS);
  WRITELN(' ENTER NAME OF FILE TO WRITE TO FROM READER');
  READLN(FLSTR);
  REWRITE(OUTFIL,FLSTR);
  GETCH;
  WHILE CH <> CHR(4) DO
  BEGIN
    IF CH <> CHR(0)
      THEN
      BEGIN
        WRITE(OUTFIL,CH);
        WRITE(CH);
      END;
    GETCH;
  END;
  CLOSE(OUTFIL,LOCK);
END.

========================================================================================
DOCUMENT :usus Folder:VOL2A:shellmsort.text
========================================================================================

PROGRAM SORT;
{ SOURCE FILE ASCENDING ORDERSORT }
{ COPYRIGHT 1979 BY BARRY A. COLE
                 3450 SAWTELLE BL#332
                 LOS ANGELES, CA 90066
  THIS MAY BE USED FREELY IF NOT SOLD AND IF THIS
  MESSAGE IS RETAINED IN THE SOURCE. }

  CONST SIZE=400; { MAXIMUM LINES TO BE SORTED}
  VAR FROM,TOFIL: STRING[15];
      SRCFIL,DSTFIL: TEXT;
      SLOT: PACKED ARRAY[1..SIZE] OF STRING[80];
      RECNUM: ARRAY[1..SIZE] OF INTEGER;
      i,gap,j,jg,lines,temp: INTEGER;
      BCHAR: CHAR;
PROCEDURE BLIP;
  BEGIN
  IF BCHAR='X' THEN BCHAR:='O' ELSE BCHAR:='X';
  WRITE(BCHAR,CHR(8));
  END;
procedure chekswap;
  begin
  while j>0 do begin
    jg:=j+gap;
    if SLOT[recnum[j]]<=SLOT[recnum[jg]] then exit(chekswap);
    temp:=recnum[j]; recnum[j]:=recnum[jg]; recnum[jg]:=temp;
    j:=j-gap; end;
  end;

  BEGIN
  lines:=0;
  WRITE('SORT SOURCE FILE? '); READLN(FROM);
  WRITE('SORT DEST. FILE?  '); READLN(TOFIL);
  RESET(SRCFIL,FROM); REWRITE(DSTFIL,TOFIL);
  WRITELN('READING FROM FILE: ',FROM);
  WHILE NOT EOF(SRCFIL) DO BEGIN
    lines:=lines+1; RECNUM[lines]:=lines;
    READLN(SRCFIL,SLOT[lines]); BLIP; END;
  WRITELN(lines,' LINES TO BE SORTED');
  
  gap:=lines;
  while gap>0 do begin
    gap:=gap div 2;
    for i:=gap+1 to lines do begin  j:=i-gap; chekswap; end;
    end;
  
  { FOR I:=0 TO LINES DO BEGIN BLIP;
    FOR J:=I TO LINES DO
      IF SLOT[RECNUM[I]]>SLOT[RECNUM[J]] THEN BEGIN
        temp:=RECNUM[I]; RECNUM[I]:=RECNUM[J];
        RECNUM[J]:=temp; END; END;  }
  WRITELN('SORT OPERATION COMPLETE');
  FOR I:=1 TO lines DO WRITELN(DSTFIL,SLOT[RECNUM[I]]);
  CLOSE(DSTFIL,LOCK);
  WRITELN(TOFIL,' HAS BEEN UPDATED');
  END.


========================================================================================
DOCUMENT :usus Folder:VOL2A:smartremot.text
========================================================================================


(* Program Author:   Walter Hess
                     1460 Seven Pines Rd.
                     Schaumberg, IL 60193
                     
                                                        *)
                                                        
(* SMTTERM
               
                    BEWARE!!!   This program has only been 
               finished (I think) during the last week.  It 
               requires a serial card at addresses 177570 thru
               177576 (octal). the VECTOR address is 270 but is 
               not used as PASCAL has no provision for servicing
               an interrupt from this card.  The resultant RS232 
               port is connected to a coupler for dial-up to the 
               remote computer.
               
                    The biggest problem I had was in writing to 
               a disc file from the remote computer due to the 
               fact that PASCAL stores data for a file in 
               temporary storage someplace and periodically 
               actually writes it to disc.  The period while it 
               is writing to disc is relatively long and since 
               the remote computer keeps sending data, some
               information would be lost.  I solved the problem
               by writing to an array, and when the array is
               nearly full, I send the remote computer an ESC
               "H" which is the command sequence which halts the
               particular remote computer I use (see PROCEDURE
               WARRY).  After a short wait while the remote
               computer stops during which time arriving
               characters are accepted, I write the array to the
               disc file and then tell the remote computer to
               resume by sending an ESC which restarts the 
               remote computer (see PROCEDURE WFILE). The
               particular commands will, of course, be different
               for different computers.
               
                    Another tricky area was the use of "BREAK". 
               If you want to send a "BREAK" to the remote 
               computer, do not use the "BREAK" key as this will 
               locally interrupt PASCAL.  Instead, I simulate a 
               "BREAK" with the top row f5 which does the job 
               nicely.
               
                    The program uses certain of the ESC 
               functions created by the top row of keys as 
               program commands and passes all other ESC 
               sequences to the remote computer.  If the remote 
               computer needs one of the top row sequences, the 
               command structure will have to be modified.  It 
               seems that Heath uses sequences for the top row 
               which are not commonly used elsewhere.*)
               
PROGRAM SMTTERM;
{ VERSION "O"  10/20/79  W.I.H. }

CONST
  ARLEN = 100;

TYPE
  POINTER = ^CHAR;

VAR
  PCH,PCHS,PCHR,PCHRS,CCH,CCHS,CCHR,CCHRS : POINTER;
  TCHAR : PACKED ARRAY[0..1] OF CHAR;
  ARINDEX,CFULL,PRINDEX,COLM,LNCT,LNLINE,LNINCH,LNPAGE,L : INTEGER;
  NFULL,HALT,LESC,FDUP,CMD,PRINTON,RCRDON,PLBKON,TERMINATE : BOOLEAN;
  FILENAME : STRING[30];
  PRARRY : PACKED ARRAY[1..ARLEN] OF STRING[132];
  SSTRING : STRING[1];
  PRFILE : TEXT;
  R : REAL;
  RCH,CH,ESCH : CHAR;

PROCEDURE INITPT;

TYPE
  REP = (POINTREP,INTREP);
  ALIAST = RECORD
    CASE REP OF
      POINTREP:
        (POINTVAL : POINTER);
      INTREP:
        (INTVAL : INTEGER);
    END; { CASE }

VAR
  ALIAS : ALIAST;

BEGIN
  ALIAS.INTVAL := -130;
  CCH := ALIAS.POINTVAL;
  ALIAS.INTVAL := -132;
  CCHS := ALIAS.POINTVAL;
  ALIAS.INTVAL := -134;
  CCHR := ALIAS.POINTVAL;
  ALIAS.INTVAL := -136;
  CCHRS := ALIAS.POINTVAL;
  ALIAS.INTVAL := -178;
  PCH := ALIAS.POINTVAL;
  ALIAS.INTVAL := -180;
  PCHS := ALIAS.POINTVAL;
  ALIAS.INTVAL := -182;
  PCHR := ALIAS.POINTVAL;
  ALIAS.INTVAL := -184;
  PCHRS := ALIAS.POINTVAL;
END;

PROCEDURE WASTE;
VAR
  K : INTEGER;

BEGIN
  REPEAT
    K := ORD(PCHS^);
  UNTIL K = 128;
END; {Waste}

PROCEDURE COMM(CH : CHAR);

VAR
  L : INTEGER;
  
BEGIN
  REPEAT
    L := ORD(CCHS^);
  UNTIL L = 128;
  CCH^ := CH
END; {Comm}

PROCEDURE CARRAY;

VAR
  J : INTEGER;

BEGIN
  FOR J := 2 TO ARLEN DO
    PRARRY[J] := '';
END; {Carray}

PROCEDURE WARRY;

BEGIN
  IF ORD(CH) > 127
    THEN CH := CHR(ORD(CH) - 128);
  IF CH = CHR(10)
    THEN CH := CHR(127);
  IF (CH = CHR(13))
    THEN
      BEGIN
        PRINDEX := 1;
        ARINDEX := ARINDEX + 1;
        IF ARINDEX = ARLEN - 3
          THEN
            BEGIN
              NFULL := TRUE;
              COMM(ESCH);COMM('H');
            END;
      END
    ELSE
      BEGIN
        IF CH <> CHR(127)
          THEN
            BEGIN
              SSTRING[1] := CH;
              INSERT(SSTRING,PRARRY[ARINDEX],PRINDEX);
              PRINDEX := PRINDEX + 1;
            END;
      END;
END; {Warry}

PROCEDURE WFILE;

VAR
  K,J : INTEGER;

BEGIN
  K := 1;
  IF LENGTH(PRARRY[1]) = 0
    THEN K := 2;
  FOR J := K TO ARINDEX - 1 DO
    WRITELN(PRFILE,PRARRY[J]);
  IF PRINDEX > 1
    THEN
      PRARRY[1] := PRARRY[ARINDEX]
    ELSE
      PRARRY[1] := '';
  ARINDEX := 1;
  CARRAY;
  NFULL := FALSE;
  COMM(ESCH);
END; {Wfile}

PROCEDURE PRINT (PRTCHR : CHAR);

BEGIN
  IF PRTCHR = CHR(13)
    THEN PRTCHR := CHR(10);
  WASTE;PCH^ := PRTCHR;
END; {Print}

PROCEDURE PRINTER;

BEGIN
  WRITE(ESCH,'Y8 ',ESCH,'l','Enter printer characters per line ');
  WRITE('80, 96 or 132)  ');
  PCH^ := ESCH;WASTE;PCH^ := CHR(117);WASTE;
  REPEAT
    READLN(LNLINE);
    IF LNLINE = 80
    THEN
      BEGIN
        PCH^ := CHR(1);WASTE;
      END
    ELSE
      IF LNLINE = 96
      THEN
        BEGIN
          PCH^ := CHR(20);WASTE;
        END
      ELSE
        IF LNLINE = 132
        THEN
          BEGIN
            PCH^ := CHR(36);WASTE;
          END;
    UNTIL (LNLINE = 80) OR (LNLINE = 96) OR (LNLINE = 132);
    WRITE(ESCH,'Y8 ',ESCH,'l','Enter lines per inch (6 or 8)  ');
    PCH^ := ESCH;WASTE;
    REPEAT
      READLN(LNINCH);
      IF LNINCH = 6
      THEN
        BEGIN
          PCH^ := CHR(120);WASTE;
        END
      ELSE
        IF LNINCH = 8
        THEN
          BEGIN
            PCH^ := CHR(121);WASTE;
          END;
    UNTIL (LNINCH = 6) OR (LNINCH = 8);
END; {Printer}

PROCEDURE COMMAND;

VAR
  GCHAR : BOOLEAN;

  PROCEDURE DISPLAY;
  
  BEGIN
    WRITE(ESCH,'Y8 ',ESCH,'l',ESCH,'F^',ESCH,'G');
    IF CMD
      THEN WRITE(ESCH,'p');
    WRITE('BLUE Cmd',ESCH,'q',ESCH,'F^',ESCH,'G');
    IF PLBKON
      THEN WRITE(ESCH,'p');
    WRITE('RED Playback',ESCH,'q',ESCH,'F^',ESCH,'G');
    IF RCRDON
      THEN WRITE(ESCH,'p');
    WRITE('GREY Record',ESCH,'q',ESCH,'F^',ESCH,'G');
    IF NOT FDUP
      THEN WRITE(ESCH,'p');
    WRITE('f1 Half Duplex',ESCH,'q',ESCH,'F^',ESCH,'G');
    IF PRINTON
      THEN WRITE(ESCH,'p');
    WRITE('f2 Print',ESCH,'q',ESCH,'F^',ESCH,'G','f3 Terminate',
                                              ESCH,'F^',ESCH,'G');
  END; {Display}
  
  PROCEDURE RCORD;
  
  VAR
    TRYAGAIN : BOOLEAN;

  BEGIN
    {$I-}
    REPEAT
      WRITE(ESCH,'Y8 ',ESCH,'l','Enter File Name (.TEXT Assumed)');
      WRITE(' Or CR to Terminate  ');
      READLN(FILENAME);
      IF LENGTH(FILENAME) = 0
        THEN
          BEGIN
            RCRDON := FALSE;
            EXIT(RCORD);
          END;
      FILENAME := CONCAT(FILENAME,'.TEXT');
      RESET(PRFILE,FILENAME);
      IF IORESULT = 0
        THEN
          BEGIN
            CLOSE(PRFILE);
            WRITE(ESCH,'Y8 ',ESCH,'l','File exists, do you want to ');
            WRITE('replace it (Y or N)   ');
            REPEAT
              READ(CH);
            UNTIL (CH = 'Y') OR (CH = 'N') OR (CH = 'y') OR (CH = 'n');
            IF (CH = 'N') OR (CH = 'n')
              THEN TRYAGAIN := TRUE
              ELSE TRYAGAIN := FALSE;
          END
        ELSE TRYAGAIN := FALSE;
      IF NOT TRYAGAIN
        THEN REWRITE(PRFILE,FILENAME);
    UNTIL (IORESULT = 0) AND (NOT TRYAGAIN);
    {$I+}
    WRITE(ESCH,'k');
    END; {Rcord}
    
    PROCEDURE PLAYBACK;
  
    VAR
      J : INTEGER;
  
    BEGIN
      {$I-}
      REPEAT
        WRITE(ESCH,'Y8 ',ESCH,'l','Enter File Name (.TEXT Assumed)');
        WRITE(' Or CR to Terminate  ');
        READLN(FILENAME);
        FILENAME := CONCAT(FILENAME,'.TEXT');
        IF LENGTH(FILENAME) = 0
          THEN
            BEGIN
              PLBKON := FALSE;
              EXIT(PLAYBACK);
            END;
        RESET(PRFILE,FILENAME);
      UNTIL IORESULT = 0;
      {$I+}
      WRITE(ESCH,'k');
      COMM(ESCH);COMM('E');COMM(CHR(17));
      WHILE NOT EOF(PRFILE) DO
        BEGIN
          READ(PRFILE,RCH);
          COMM(RCH);
          WRITE(RCH);
          IF EOLN(PRFILE)
            THEN
              BEGIN
                COMM(CHR(13));
                WRITE(CHR(13));
                READ(PRFILE,RCH);
              END;
        END; {While}
        IF ORD(CCHRS^) = 128
          THEN IF ORD(CCHR^) = 7
            THEN FOR J := 1 TO 1000 DO
              R := 6.2*164.83*9.5/17.84;
        PLBKON := FALSE;
        WRITE(ESCH,'j');
        CLOSE(PRFILE);
        COMM(ESCH);COMM('E');COMM(CHR(19));
      END; {Playback}
    
BEGIN {Command}
  WRITE(ESCH,'x5',ESCH,'j');
  CMD := TRUE;
  DISPLAY;
  REPEAT
    GCHAR := FALSE;
    REPEAT
      READ(CH);
      IF CH = ESCH
        THEN
          BEGIN
            GCHAR := TRUE;
            READ(CH);
          END
        ELSE WRITE(CHR(7));
    UNTIL GCHAR AND (CH IN ['P'..'U']);
    CASE CH OF
      'P' : CMD := FALSE;
      'Q' : IF PLBKON
            THEN PLBKON := FALSE
            ELSE
              BEGIN
                PLBKON := TRUE;
                DISPLAY;
                PLAYBACK;
              END;
      'R' : IF RCRDON
              THEN
                BEGIN
                  RCRDON := FALSE;
                  WFILE;
                  CLOSE(PRFILE,LOCK);
                END
              ELSE
               BEGIN
                 RCRDON := TRUE;
                 PRINDEX := 1;
                 ARINDEX := 1;
                 CARRAY;
                 NFULL := FALSE;
                 PRARRY[1] := '';
                 RCORD;
               END;
      'S' : IF FDUP = TRUE
              THEN FDUP := FALSE
              ELSE FDUP := TRUE;
      'T' : IF PRINTON
              THEN
                BEGIN
                  PRINT(CHR(12));
                  PRINTON := FALSE
                END
              ELSE
                BEGIN
                  PRINTON := TRUE;
                  PRINTER;
                END;
      'U' : TERMINATE := TRUE;
    END; {Case}
    DISPLAY;
  UNTIL (NOT CMD) OR TERMINATE;
  WRITE(ESCH,'y5',ESCH,'k');
END; {Command}

BEGIN { Smtterm }
  
  WRITELN;
  WRITELN(CHR(7),' ** NOTE **  f5 SENDS A "BREAK".  ENTER SPACE TO CONTINUE');
  READ(CH);
  ESCH := CHR(27);
  WRITE(ESCH,'x1');
  SSTRING := ' ';
  CFULL := 0;
  INITPT;
  NFULL := FALSE;TERMINATE := FALSE; HALT := FALSE;
  FDUP := TRUE;CMD := FALSE;PRINTON := FALSE;RCRDON := FALSE;PLBKON := FALSE;
  WRITE(ESCH,'y6');
  COMMAND;
  REPEAT
    UNITREAD(2,TCHAR[0],1,,1);
    WHILE UNITBUSY(2) DO
      BEGIN
        L := ORD(CCHRS^);
        IF NFULL THEN CFULL := CFULL + 1;
        IF L = -32640
          THEN
            BEGIN
              CH := CCHR^;
              WRITE(CH);
              IF PRINTON
                THEN PRINT(CH);
              IF RCRDON
                THEN WARRY;
            END;
        IF CFULL = 5000
          THEN 
            BEGIN
              WFILE;
              CFULL := 0;
            END;
      END; {While}
    IF LESC
      THEN
        BEGIN
          LESC := FALSE;
          IF TCHAR[0] = 'P'
            THEN COMMAND
            ELSE
              BEGIN
                IF TCHAR[0] = 'W'
                  THEN
                    BEGIN
                      CCHS^ := CHR(1);
                      FOR L := 1 TO 10 DO
                        R := 6.2*164.83*9.5/17.84;
                      CCHS^ := CHR(0);
                    END
                  ELSE
                    BEGIN
                      COMM(ESCH);COMM(TCHAR[0]);
                      IF TCHAR[0] = 'H'
                        THEN HALT := TRUE;
                    END;
              END;
        END
      ELSE
        IF (TCHAR[0] = ESCH) AND (NOT HALT)
          THEN LESC := TRUE
          ELSE
            BEGIN
              COMM(TCHAR[0]);
              IF TCHAR[0] = ESCH
                THEN HALT := FALSE
                ELSE IF NOT FDUP
                  THEN WRITE(TCHAR[0]);
            END;
  UNTIL TERMINATE;
  WRITE(ESCH,'k');
  WRITE(ESCH,'z');
END. {Smtterm}


========================================================================================
DOCUMENT :usus Folder:VOL2A:timing.doc.text
========================================================================================


     COMMENTS ON FLOPPY DISK TIMING RE THE 512-BYTE SECTORED DISK

     A friend remarked recently that the only reason many of the disk i/o 
drivers have worked so well is that they drive systems like CP/M, where 
intersystem timing differences have been overwhelmed by having to wait for 
every sixth sector to come by on the disk.

     The distribution UCSD system, though faster than CP/M, still respects the 
timing needs of many (but not most) disk drives and controllers.  My old 
Micromation controller (quite similar to the single-density Discus) did all 
its CRC calculations in SOFTWARE (!?!?) and could not read 128-byte sectors 
faster than one in four, and even then was unreliable.  Because it could not 
keep up with the every-other-sector reading of the UCSD system, I had to wait 
for a disk revolution per sector, slowing the system down unmanageably (45 
seconds to boot up!).

     Even when one is equipped with a decent LSI-based disk controller, there 
are subtle timing constraints that are rarely taken into account in the disk
i/o software I have seen, but will cause trouble if they are not respected in
a high-performance system like the one on these two disks.  The problem is 
that different drives and different controllers have different timing 
constraints, so our software may not run unaltered on all systems:

     1)  When you change disk drives, your system requires a head-settling 
time of approximately 35 milliseconds.

     2)  Track-to-track accesses must be followed by settling time on the 
order of 10 to 15 milliseconds, higher if more distance is gone.

     3)  The number of sectors you can pack onto a disk track depends on how 
closely your disk drives revolve at 360 RPM's.  There is a specified tolerance 
of 2%, meaning that if your disk is formatted when running slightly slow and 
written to when going slightly fast, you can wipe out addresses or data on a 
successive sector unless there is an adequate intersector gap (see the recent 
article in Byte magazine on this subject).  So, although many disk drives will 
run happily with nine 512-byte sectors per track, others will occasionally 
clobber the disk, and require the increased intersector gap afforded by eight 
sectors per track.

     The practical application of the above data is as follows:  the 512-byte 
programs listed in 512.DOC.TEXT have been tested on a number of systems and 
seem to run well.  A number of delay loops have been included, particularly in 
the SETDSK (change to new disk drive) and SETTRK (move the head) routines.  
These delays may or may not be adequate for your system.  You may require the 
additional delay when changing tracks of a track-to-track offset.  You can 
achieve this by altering the disk access routines in PBIOS to start accessing 
the next track at sector number (TrackNumber MOD 8), or format your disks with 
DFOCO so that the PHYSICAL sector number is offset by 1 (though see the notes 
in 512.DOC about the funny way you must tell DFOCO to do this).  The way to 
find out how your system responds to the timing presently in the 512-byte 
system is to USE it.  Try doing a bad-block scan of a newly formatted 512-byte 
disk, and see if your drives step at 6 tracks a second.  If there is 
hesitation, you'll have to fiddle with sector offsets.


========================================================================================
DOCUMENT :usus Folder:VOL2A:tvi912c.gotoxy
========================================================================================



(* This is a GOTOXY procedure for the TelVideo 912 CRT.  Program
   Author is Paul Gilliam, P. O. Box 2202, Pullman, WA 99163.  *)
   
PROGRAM DUMMY;   
  PROCEDURE MYGOTOXY(X,Y: INTEGER); { for tvi 912c }
    VAR 
      P : PACKED ARRAY [0..3] OF CHAR;  
    BEGIN
      IF X < 0 THEN X := 0;
      IF X > 79 THEN X := 79;
      IF Y < 0 THEN Y := 0;
      IF Y > 23 THEN Y := 23;
      P[0] := CHR(27);
      P[1] := '=';
      P[2] := CHR(Y+32);
      P[3] := CHR(X+32);
      UNITWRITE(2,P,4);
    END  { MYGOTOXY };
  BEGIN  END.


========================================================================================
DOCUMENT :usus Folder:VOL2A:update.doc.text
========================================================================================

                                                                   30 March 1980


        AN UPDATE ON THE PRESENT STATUS OF THE UCSD PASCAL USERS' GROUP

A Visit with SofTech.

     A recent development of the UCSD Pascal Users' Group is my recent visit
with Al Irvin and Bruce Sherman at SofTech Microsystems, the primary licensee
of UCSD Pascal.  They responded to my inquiry with great enthusiasm, and I
will summarize our discussion and its results.

     As you have probably already learned, in early 1979 Bowles' group at UCSD
was notified that it would have to discontinue the software distribution
business because of the threat to the nonprofit standing of the University of
California system caused by the financial success of UCSD Pascal.  Months of
deliberations followed to determine which course would be the fairest to all
yet protect the hardware independence of the UCSD Pascal system.  Ultimately,
an established East coast software firm, SofTech, created a San Diego
subsidiary, SofTech Microsystems, which became the primary UCSD Pascal
licensee.  Its job is specifically to distribute UCSD Pascal as widely as
possible, while improving it and offering the vigorous user support Bowles'
students could not provide.  (In addition, a number of other firms obtained
OEM licenses which are still in effect; the best known is Apple computers.) 

     Many users have written to UCSD and SofTech asking for a newsletter,
regional meetings, and possibly a job bulletin board.  There were many
volunteers.  As a result, SofTech has been planning to sponsor the birth of a
users group with a meeting in San Diego this summer. Once it is formed, they
will turn over its management to volunteers not associated with UCSD or
SofTech. 

     A number of users have begun sharing UCSD Pascal software and have
indicated an interest in forming a UCSD Pascal library.  In order to utilize
their contributions, SofTech drafted a proposal for a users library that would
be contributed to by a number of software "editors," who would compile and
submit disk volumes of quality software not previously included in the
library, along with adequate documentation and estimation of the quality of
the software contents.  These volumes would be forwarded to one or more
central distribution points.  To partially compensate the editors for their
time, they would receive a small payment per disk sold, with the understanding
that users would be encouraged to copy and distribute the users group disks
for free, and that the editors would receive no payment for disks not sold.
kctual payment of editing fee would be on a quarterly basis.

     Since the software sharing system organized by Datamed Research is
similar to what SofTech was planning to develop, we have agreed to cooperate
with each other as much as possible.  To avoid confusion with a UCSD Pascal
Users' Group that would publish a newsletter, hold meetings, etc., the present
sharing of software will be called the UCSD Pascal Users' Group Library, and I
have taken the role of interim librarian.  I like their proposal for a system
of editors a great deal.  To avoid duplication, however, someone must
coordinate the library centrally.  For example, I have already seen four
copies of the Pascal prettyprinters floating around.  I have presented a
proposal for the way editors may interface with the group in POLICY.DOC.TEXT
elsewhere on this volume.

The Multitude of Floppies.

     There are a multitude of disk formats that now run UCSD Pascal.  For two
years, the system utilized virtually exclusively one 8-inch, single-density
format on a number of different machines.  Now, with the rise of UCSD Pascal
on the Apple, the TRS-80 Mod I, the North Star, the Microengine (yes, the
disks are close but not compatible), and a host of other drives (e.g., the
Micropolis, and also I've heard of it running on a Helios hard-sector floppy)
with more to come, it may seem impossible to support all these different 
disk drives.  Certainly, the job is too large for one person, but there are 
signs of help on the way.

     Western Digital is quite interested in supporting their system directly,
and you can get routines from them that will move data from a UCSD disk to a
Microengine disk and vice versa, all on a Microengine system.  I have received
offers of help from several users with dual systems of varying types. Because
so little RAM is available for the system, the TRS-80 Mod I has a fatal flaw:
only small to mid-sized programs will compile, and it is almost useless.
Because it requires a lot of memory to compile a UNIT, this facility is not
available. (Hot tip -- if you want to make a bundle, figure out a way to
replace the Level II BASIC ROM card with a card that holds the UCSD Z-80
interpreter in ROM, preferably switch-selectable with the BASIC card.) This
leaves the Apple as the other major UCSD system that requires support. Indeed,
I've received quite a number of inquiries from Apple users in the past two
weeks since the announcement of the Users' Group.

     SofTech has agreed to download programs from master 8- inch floppies to
the Apple and TRS-80 and possibly other, 5- 1/4 inch disk systems.  They are
concerned, however, about how expensive it is for them to just process an
order.  So we're looking for some other means of distributing Apple Pascal
programs.

     In other words, HELP!!! Those of you who have a dual- disk Apple system
and would like to earn a small fee ($2) per disk volume shipped, please get in
touch.  If you are nearby, I can supply you with raw materials (disks and
cartons).

Other Pascals Supported.

     In addition to UCSD Pascal, the users group software library will also 
support Pascal M, Pascal/Z, and Pascal/MT, the other major Pascals available 
that run under CP/M.  Other CP/M-compatible Pascals may be added as they 
become available.  Please contact Datamed Research if you would like to 
contribute software that runs under these systems.  However, because of time 
limitations, we cannot convert UCSD Pascal programs to the other systems; we
will supply UCSD Pascal library software on CP/M disks for you to complete
your own conversions.  (As it turns out, the syntax of Pascal M is virtually
identical to that of UCSD, and the other systems lack primarily GET, PUT,
variant records, and compatibility with nonstandard extensions.  So with
Pascal/Z or /MT, your major problem is file i/o.  Also, if the program is
large, you'll have to find a way to fit it in memory.)

Other Activities of DATAMED RESEARCH

     As a certified Pascal fanatic, I also plan to become a major retailer of
proprietary Pascal utilities and application software.  In addition, I am
interested in selling other Pascal systems as well as UCSD.  Please contact me
if you have Pascal software that you would like to offer for sale to the
computing community.

     In addition, Datamed Research has announced a call for software related 
to health care for its new disk-based software journal, SOFTDOC, to be 
published quarterly beginning in June.  Contact me directly for further 
information.


     Sincerely,

Jim Gagne, President
DATAMED RESEARCH
1433 Roscomare Road
Los Angeles, CA 90024


========================================================================================
DOCUMENT :usus Folder:VOL2A:vol.2b.doc.text
========================================================================================


     DOCUMENTATION FOR THE FILES ON VOLUME 2B: (nominally) CP/M FORMAT

     I packed the CP/M format disk with the maximum number of files that would 
fit, so documentation resides in this file and elsewhere on this disk as noted 
below.

     
     BOOTER.ASM
     DFOCO.ASM
     PGEN.ASM
     MACRO.LIB
     SAMPLEIO.ASM These programs are all documented within 512.DOC.TEXT,
elsewhere on this disk.  They form the CP/M portion of the 512-byte BIOS al-
terations for the UCSD system and require CP/M software (principally the
Digital Research macroassembler) to be assembled (unless modified).  Specific 
documentation regarding DFOCO is contained in DFOCO.DOC.TEXT on this disk.

     UCSD2CPM.MAC
     UCSD2CPM.COM This assembly-language program translates UCSD-format
textfiles to the CP/M format.  It runs under CP/M.  It is written for the
Microsoft assembler with Zilog memnomics, and will run on a Z-80 only, I
believe, though it should not be hard to modify for an 8080 if you so desire. 
One bug:  the utility sometimes can't find UCSD files even though you typed 
the filename correctly.  To overcome this problem, keep typing the correct 
name until the program finds the file.

     
     I have filled up the rest of the disk with my favorite CP/M utilities,
including some quite helpful for disk maintenance in a UCSD system:

     CAT.COM
     CAT.SUB
     FMAP.COM
     UCAT.COM These utilities form Ward Christensen's CP/M disk cataloging
package from the CP/M Users' Group, Volume 25, and available in source form
from me or them.  To use, insert a dummy filename on each disk of the format  
"-xxxxxxx.nnn", where "xxxxxxx" is any name relevant to the purpose of
that disk (one to seven alphanumeric characters) and "nnn" is the unique
serial or volume number of that disk (e.g., 001, 010, 289, etc.).  The hyphen
in front of the disk name ensures that it comes first in an alphabetical
listing of directory entries, and is required for the cataloging program to
function.  Next, create a file with your favorite CP/M editor called
"MAST.CAT", and include within this file a list of all files you do NOT wish
listed in the master catalog (such as ED.COM, ASM.COM, and other fairly
universal files) in the following format: each filename must be on a separate
line in alphabetic order.  The first name is preceeded by a left parenthesis,
and the last followed by a right parenthesis, in the following manner:

(ASM.COM
ED.COM
STAT.COM)

     Next pick a disk which will contain your master catalog, MAST.CAT, and 
add the dummy directory entry "-xxxxxxx.nnn" to each disk as noted above.  To 
add the directory data on a disk to the catalog, first make a file of the 
directory data by typing "FMAP <diskletter>: F", where diskletter is one of
"A" through "D".  Then type "UCAT" to merge the "NAMES.SUB" file created by
FMAP with the catalog file.  You can follow this procedure each time a disk
is created or significantly changed, since UCAT automatically deletes catalog
entries not present on the updated directory file and adds any new entries it
finds.  To delete an entire volume, create a "NAMES.SUB" file consisting only
of the volume name you wish to delete (in the usual "-xxxxxxx.nnn" format)
and run UCAT.

     Finally, to use the catalog, there is CAT.COM, which is invoked like the
DIR command in the CP/M distribution system (same types of wildcard
references) except that there is another pair of parameters, the volume name
and number: CAT <filename>.<filetype> <diskname>.<disknumber> <return> (note
that the hyphen in front of the diskname is DELETED once it's within the
catalog).  So typical commands would be: 

CAT <return> --> list entire catalog; 
CAT *.ASM --> list all ASM files on all disks; 
CAT *.* *.002 --> list all the files on volume 002; 
CAT A*.* --> list all files starting with "A"; 
CAT *.ASM UCSD.* --> list all .ASM files on disks with volumename UCSD.

     For those of us with a large number of CP/M disks, this VERY much helps
to locate files.  As you may imagine, I would be quippled tink if someone
would write a similar program for the UCSD system (without, I would hope, the
necessity to write a separate file of filenames before combining a disk
directory's contents with the master file).


     CLEAN.COM  This utility is a super-PIP, allowing rapid copying of one or 
more files from one disk to another.  It is simple and self-documenting.

     
     D.COM  This program replaces CP/M's DIR, providing an alphabetized 
display of all the files on a CP/M disk.  File size is displayed, as well as 
the remaining number of bytes of room on a disk.  The display is in three 
columns for the viewing of up to 57 files of a disk on the screen at one time.
In addition to typing just "D <return>" when at the CP/M command level, you 
can type "D <diskname>: <return)", where <diskname> consists of one of the
letters A through D, to see the contents of a disk other than the one
currently logged.  If you have a terminal smaller than 80 x 24, you will have
to send a blank disk with return postage to Sam Singer (address in the DFOCO
listing) or get the CP/M Users Group volume #24, which contains the source
(named XDIR). Earlier versions of D, however, add up the remaining room on
the disk incorrectly and report one more Kbyte then really exists.

     NOTE:  We BADLY need a utility of this sort in the UCSD system, which 
would allow us to read the contents of a disk directory WITHOUT invoking the 
filer and fitting one or two columns of filenames on a screen at once, all in 
alphabetical order.  If you take on this one, write the directory-reading 
portion of the utility in such a manner that it is generally usable.

     
     DUMP.ASM  This is Sam's disk dumping utility, allowing you access to hex 
and ASCII listings (in a format like DDT's D command) of files, tracks, 
sectors, and the CP/M logical groups.  The Map facility gives you a picture of 
disk usage by viewing the occupied groups (CP/M's way of organizing disk 
data).  If you ignore the CP/M features, this program will work just fine for
UCSD- format disks.  Note that it works only with 3740-compatible disks
(single density, each track with 26 sectors of 128 bytes); you'll have to put
up with UCSD's Patch utility to fix 512-byte sectored disks.  This is a nice
utility, but I prefer my program:

     
     SPAT.ASM  This is heavily modified from the version published in the 
first CP/M Users Group and is designed specifically to write to a 16 x 64
memory-mapped video terminal.  If you want to use it with a conventional 
terminal (i.e., accessed via I/O ports), you'll have to write the display to a
buffer at the end of the program, then write out the buffer to your terminal
via the CONSLOUT vector in the BIOS jump table.  In addition, some means of
GOTOXY should be included to obtain data entry instead of the direct screen
entry utilized when data is requested.  Look at the code carefully before you
try to assemble it; there are hardware-specific features (such as an ASCII
formfeed character to clear the screen) that are moderately well documented. 
VDMLC is the memory address of the terminal; VDMPG is the number of 256-byte 
pages within the terminal memory.

     SPAT has a number of nice features.  It works with a single 128-byte 
sector at a time, displaying the hex and ASCII data separately and laid out so 
you can see what data is where within the sector.  Fixes are easily made, and 
there is a STATUS byte at the top of the screen, so you can check out the 1771-
type status word directly from the chip.  I've added direct access to the CP/M 
logical units of "Group" (the series of 8 logically contiguous 128-byte
sectors which makes up the logical unit of disk storage) and "Fraction" (my
name for the relative logical sector within a group, ranging from 0 to 7). 
If you type "M", the screen fills up with the contents of the entire group
written in ASCII, speeding your access to troubled source or other
textfiles.  I find SPAT of enormous use in fixing disk problems ranging from 
restoring an erroneously erased directory entry (change the first byte of the
entry from E5 hex to 00), to marking bad sectors as a file GARBAGE.BAD within 
the directory (first, discover the logical Group number corresponding to the 
physical sector you have found to be bad, then create the directory entry and
stick the correct group number therein), to actually repairing a damaged 
sector.  NOTE WELL:  if you are a beginner to CP/M, GET HELP before fooling 
around with a disk directory, as you can REALLY make a MESS!!!  This brief 
description does not constitute adequate instructions in how to proceed.


========================================================================================
DOCUMENT :usus Folder:VOL2A:volume.2.text
========================================================================================


DOCUMENTATION OF THE FILES IN VOL 2: MACHINE-SPECIFIC PROGRAMS AND MISCELLANY

     This disk contains the documentation of Volume 2B (normally CP/M format)
in the files:

VOL.2B.DOC.TEXT 
DFOCO.DOC.TEXT.

     A.  Terminal and printer drivers and documentation.  I have not tried any 
of them.  The following files may help you if you have one of the listed
devices:

H19.GOTOXY      (Change the name to something.TEXT so you can edit & compile.)
PE1100.GOTOXY   (ditto; terminal is Perkin Elmer Model 1100 [Fox]) 
TVI912.GOTOXY   (ditto) 
HAZEL.MISCINFO  (Don't forget to change the name to SYSTEM.MISCINFO.) 
H19.MISCINFO    (ditto) 
H19.DOC.TEXT 
H14.DRIVER.TEXT (Lists files on the Heath printer at full speed.) 
PUNCH.TAPE.TEXT (UCSD files to Heath tape.)
READ.TAPE.TEXT  (Heath tape to UCSD.).


     B.  512-byte disk sectoring routines for Z-80's running with a Western 
Digital-based floppy controller.  This system is the one I use, and is the 
reason for the separate CP/M volume.  See the Volume 2B documentation noted 
above, and also:

512.DOC.TEXT
TIMING.DOC.TEXT
CPMIO.DOC.TEXT.


     C.  Interfacing CP/M with UCSD disks:
     
BOOTASM.TEXT
MOVRAM.TEXT     (BOOTASM is written in Pascal and uses MOVRAM as an assembly-
                 language EXTERNAL file.  You can use the UCSD assembler to 
                 create CP/M-compatible software, then move it to 100H and 
                 save it on a CP/M disk.)

BOOTCPM.TEXT    (Before, you could boot up Pascal from CP/M.  Now, you can get
                 at CP/M from Pascal, if you'd ever want to.)

UCSD2CPM.MAC
UCSD2CPM.COM    (These files are on the CP/M disk and allow you to transfer
                 files from UCSD format to CP/M.  See VOL.2B.DOC.)
                 
     
     D.  Two more modem drivers:

PTP.TEXT
PTP.DOC.TEXT
DCHAYES.IO.TEXT
ACOUSTIC.TEXT
KBSTAT.TEXT     (These files form the Pascal Transfer Program, which will drive
                 either a DC Hayes or an acoustic modem.  It looks well written,
                 and I haven't tried it.  If you don't have an 8080, you should
                 still have no problem getting this to run, in contrast to the
                 work required with the modem drivers in Volume 1.  KBSTAT is
                 yet another keyboard status routine; we MUST standardize these
                 before I go nutz.  Let me know how you like this.)
SMARTREMOT.TEXT (This claims to turn your machine into a smart terminal.  Again,
                 I haven't tried it; let me know.)


     E.  Miscellany:

NEW.GOTOXY.TEXT (A good idea for an expanded GOTOXY that uses codes, e.g.,
                 GOTOXY (-1, -1) to drive CRT functions like CLEARSCREEN.
                 The point is that if we all agree on the codes, we can put
                 the drivers in SYSTEM.PASCAL and forget about having to include
                 them in our applications programs.)

PRIME1.TEXT     (Two prime number generators written in Pascal.)
PRIME2.TEXT

HEXOUT.TEXT     (A Pascal program to write integers in hexadecimal format.)

PERUSE.PG.TEXT  (This little thing allows you to peruse a textfile one page at
                 a time on your CRT.  It needs work:  reading and writing 
                 strings in UCSD Pascal is hopelessly slow, unless you utilize
                 a blockread approach and hunt for ASCII carriage returns in
                 the resulting character array on your own.  Also, the file 
                 opening routine is crummy and could use something like GETFILE
                 in my CRT.I.O.TEXT in the last volume.  Finally, I always seem
                 to skip past the page I want when checking out files; it would
                 be nice to be able to back up one page.  Anyone?)
                 
DELETE.LF.TEXT  (This quickie deletes extraneous linefeed characters in text-
                 files transferred from other computers.  I was going to com-
                 plain about this one, too, but rewrote it instead.  It's about
                 5 to 10 times faster with blockread/write.)

LINECOUNTR.TEXT (Ever wanted to count the lines of a text or source file?  I
                 rewrote this one, too.)

RANDOMBYTE.TEXT (A quick assembly-language routine to load the contents of the
                 R register of a Z-80 into a Pascal program; good to initialize
                 a random-number generator.  This would be nice to include in
                 our products so we don't always have to start games, "Type a
                 number."  A good alternative if you have a clock is to load
                 the lowest byte of the TIME function.  We'll have to make this
                 universal; see UNIVERSAL.TEXT, coming up in Volume 3.) 

SHELLMSORT.TEXT (This little routine sorts a text file list alphabetically,
                 using the Shell-Metzner sorting algorithm.  Each entry is 
                 assumed to start on a new line.  Not well documented, but it 
                 is so short and cute.  Only problem is that damn string READLN
                 and WRITELN again; the program runs slowly.  I decided to leave
                 in Barry's BLIP procedure so you can see one man's way of fol-
                 lowing the progress of his program; it flips a spot on the 
                 screen from one character to another.)

WRITER.TEXT 
WRITER.DOC.TEXT (WRITER is a very nice little text printer that is well menu 
                 driven.  It needs little documentation, as a HELP command is
                 actually built in!!  I am impressed.)
                 

     F.  More about the UCSD Pascal Users' Group Library.

UPDATE.DOC.TEXT (Tells you what's been going on with the UCSD Pascal Users'
                 Group.)
POLICY.DOC.TEXT (Most recent formulation of how the Library works, how to order
                 disks, how to become an editor, etc.)

     
                              ACKNOWLEDGEMENTS   

     The following folks wrote or gathered most of the software on this disk:

     Sam Singer, 17226 Bonita, Perris, CA 92370.  As far as I'm concerned, Sam 
is one of the best assembly-language programmers I know.  His contributions to 
the CP/M Users Group (contained on Volume 2B) are the best in that group to 
date.  He's worked on the 512-byte sector system (first authored and gotten 
running by George Bolthoff) to extend its scope to double-density/sided and
utilize more controllers than the single-density Tarbell.

     Barry Cole, Sawtelle Blvd., West Los Angeles, California

     Jim McCord, 330 Vereda Leyenda, Goleta, California 93017.  (VERY 
interested in UCSD Pascal on PDP-11 hardware; started an LSI-11 UCSD Pascal 
Users' Group.)

     The Pascal Advancement Society Library, c/o Joe Sharp, Palo Alto, 
California.



========================================================================================
DOCUMENT :usus Folder:VOL2A:writer.doc.text
========================================================================================

                        WRITER

     Writer is a program which is designed to read a given   
file and print it, along with a few optional organization
and clarification aids. It is not to be considered a for-
matter, but it is designed to be an improvement over an or-
dinary printout.
     
     The options available are Date, Margins, Pagenumbers,
Doublespacing, Instructions, and a List of Printfiles. A  
prompt line will explain all commands, and if they are not
understood, command H ( Help ) will explain them furthur, along
with all defaults. Up to 9 files are allowed, and when the 
user is satisfied with the current values of the parameters
a carrige return will begin the printing.

     NOTE: ALL PARAMETERS WILL BE DEFAULTED WITH THE EX-
CEPTION OF DATE AND FILENAME, AND AT ALL TIMES WHILE WAITING
FOR A COMMAND A LIST OF PARAMETERS AND THEIR DEFAULTES WILL
BE DISPLAYED.

     The easiest way to run this program is to type 'F',
followed by one to nine filenames, followed by two carrige
returns.

========================================================================================
DOCUMENT :usus Folder:VOL2A:writer.text
========================================================================================

PROGRAM WRT;
  
  VAR
    FILES : ARRAY [ 1..9 ] OF STRING ;
    GOTFILES : BOOLEAN ;
    FILENAME : STRING ; 
    DATE : STRING ; 
    DOUBLESPACE : CHAR ;
    COMMAND : CHAR ;
    NUMBERS : CHAR ;
    TOPORBOTTOM : CHAR ;
    PAPERSIZE : INTEGER ;
    LEFTMARGIN : INTEGER ;
    TOPMARGIN : INTEGER ;
    BOTTOMMARGIN : INTEGER ;
    NUMFILES : INTEGER ;
    NUMPRINTS : INTEGER ;
    ENDLINES : INTEGER ;
     
     { * * * * * * * * * * }

PROCEDURE WRTPAGE ( PRINTFILE : STRING ) ;

  VAR
    INP : TEXT ;
    CH : CHAR ;
    PR : FILE OF CHAR;
    LINE : STRING ;
    DONE : BOOLEAN ;
    MARGINLINES : INTEGER ;
    PAGENUMBER : INTEGER ;
    EXTRALINES : INTEGER ;
    FILLERLINES : INTEGER ;
    MARGINSPACES : INTEGER ;
    LINESLEFT : INTEGER ;
    LINESUSED : INTEGER ;
    PROMPTER : CHAR ;
    
     { ------------------- }
  
BEGIN
  
  WRITELN ( 'Printing...' ) ;
  REWRITE (PR,'PRINTER : ');
  RESET ( INP, PRINTFILE ) ;
  PAGE ( PR ) ;
  PAGENUMBER := 0 ;
  DONE := FALSE ;
  
  WHILE NOT EOF (INP) DO
    BEGIN
      PAGENUMBER := PAGENUMBER + 1 ;
      WRITELN ( PR ) ;
      IF ( NUMBERS = 'Y' ) AND ( TOPORBOTTOM = 'T' ) THEN
        BEGIN
          WRITELN ( PR , '-' : 36 , PAGENUMBER , '-' ) ;
        END ;
    IF PAGENUMBER = 1 THEN
      BEGIN
WRITELN ( PR , DATE : 67 ) ;
WRITELN ( PR , PRINTFILE : 42 ) ;

IF TOPORBOTTOM = 'T' THEN LINESUSED := TOPMARGIN + 4
  ELSE LINESUSED := TOPMARGIN + 3 ;
      END { IF }  
        ELSE 
IF TOPORBOTTOM = 'T' THEN LINESUSED := TOPMARGIN + 2
          ELSE
        LINESUSED := TOPMARGIN + 1 ;
    FOR MARGINLINES := 1 TO TOPMARGIN DO
      WRITELN (PR) ;
     
     LINESLEFT := PAPERSIZE - LINESUSED ;
     { WRITELN ( LINESUSED ) ;
     WRITELN ( LINESLEFT ) ;
     WRITELN ( ENDLINES ) ;
     READ ( KEYBOARD , PROMPTER ) ; }
     WHILE ( LINESLEFT > ENDLINES ) AND ( NOT DONE ) DO
       BEGIN
         FOR MARGINSPACES := 1 TO LEFTMARGIN DO
           WRITE ( PR , ' ' ) ;
        
         READLN ( INP, LINE ) ;  WRITELN ( PR, LINE ) ;
         
         IF DOUBLESPACE = 'Y' THEN 
           BEGIN
             WRITELN (PR) ;
             LINESLEFT := LINESLEFT - 2 ;
           END
         ELSE
           LINESLEFT := LINESLEFT - 1 ;
         
         IF EOF ( INP ) THEN DONE := TRUE ;
      END { WHILE } ;
    
    FOR MARGINLINES := 1 TO BOTTOMMARGIN DO
      WRITELN ( PR ) ;
    IF EOF ( INP ) THEN
      BEGIN
        EXTRALINES := ( LINESLEFT - ENDLINES ) ;
        FOR FILLERLINES := 1 TO EXTRALINES DO 
        WRITELN ( PR ) ;
      END ;
    IF ( NUMBERS = 'Y' ) AND ( TOPORBOTTOM = 'B' ) THEN
      BEGIN
        WRITELN ( PR , '-' : 36 , PAGENUMBER , '-' ) ;
      END ;
    
    { PAGE ( PR ) ; }
    
     { ------------------- }
    
  END ;
  CLOSE (INP) ;
END { WRTPAGE } ;

     { * * * * * * * * * * }

PROCEDURE HELPINSTR ;
  
  VAR
    PROMPTER : CHAR ;
    FILLERLINES : INTEGER ;
  
  BEGIN
    PAGE ( OUTPUT ) ;
      WRITELN ;
      WRITELN ( 'INSTRUCTIONS:' ) ;
      WRITELN ( 'TO USE ANY OF THE FOLLOWING COMMANDS,' ) ;
      WRITELN ( 'SIMPLY ENTER THE FIRST LETTER OF THAT' ) ;
 WRITELN ( 'COMMAND, AND THE REST IS SELF-EXPLANATORY.' ) ;
      WRITELN ( 'WHEN YOU ARE READY TO BEGIN PRINTING,' ) ;
      WRITELN ( 'SIMPLY TYPE A CARRIAGE RETURN' ) ;
    FOR FILLERLINES := 1 TO 8 DO
      WRITELN ;
      WRITE ( '( < CR > to continue ) ' ) ;
    READLN ( KEYBOARD , PROMPTER ) ;
    PAGE ( OUTPUT ) ;
  END { HELPINSTR } ;

     { * * * * * * * * * * }

PROCEDURE HELPCMNDS ;
  
  VAR
    PROMPTER : CHAR ;
    FILLERLINES : INTEGER ;
  
  BEGIN
    WRITELN ;
    WRITELN ( 'COMMANDS:' ) ;
      WRITELN ( 'D : DATE' ) ;
      WRITELN ( 'F : FILENAME ( UP TO 9 )' ) ;
      WRITELN ( 'H : HELP' ) ;
      WRITELN ( 'L : LIST OF PRINTFILES' ) ;
      WRITELN ( 'M : MARGINS ( LEFT, TOP, BOTTOM' ) ;
 WRITELN ( 'N : PAGENUMBERS ( TOP OR BOTTOM OF PAGE ) ' ) ;
      WRITELN ( 'P : PAPERSIZE ( NUMBER OF LINES )' ) ;
      WRITELN ( 'S : DOUBLSPACING' ) ;
    FOR FILLERLINES := 1 TO 5 DO
      WRITELN ;
      WRITE ( '( < CR > to continue ) ' ) ;
  END { HELPCMNDS } ;

     { * * * * * * * * * * }

PROCEDURE HELPDFLTS ;
  
  VAR
    PROMPTER : CHAR ;
    FILLERLINES : INTEGER ;
  
  BEGIN
    READLN ( KEYBOARD , PROMPTER ) ;
    PAGE ( OUTPUT ) ;
      WRITELN ;
      WRITE ( 'REMEMBER - THE FOLLOWING FUNCTIONS ARE ' ) ;
      WRITELN ( 'AUTOMATICALLY SET:' ) ;
      WRITELN ( 'LEFT MARGIN:10' ) ;
      WRITELN ( 'TOP MARGIN:4' ) ;
      WRITELN ( 'BOTTOM MARGIN:4' ) ;
      WRITELN ( 'PAGENUMBERS:YES ( TOP OF PAGE ) ' ) ;
      WRITELN ( 'PAPERSIZE:66 LINES' ) ;
      WRITELN ( 'DOUBLESPACES:YES' ) ;
    FOR FILLERLINES := 1 TO 7 DO
      WRITELN ;
      WRITE ( '( < CR > to continue ) ' ) ;
    READLN ( KEYBOARD , PROMPTER ) ;
    PAGE ( OUTPUT ) ;
  
  END { HELPDFLTS } ;

     { * * * * * * * * * * }
                      
PROCEDURE MARGINS ;

  VAR
    MARGINTYPE : CHAR ;
  
  BEGIN
    REPEAT
      BEGIN
        WRITE ( 'MARGINS: L(eft, T(op, B(ottom ' ) ;  
        WRITELN ( '( < CR > to leave ) ' ) ;
        READ ( KEYBOARD , MARGINTYPE ) ;
          
          CASE MARGINTYPE OF
            'L' : BEGIN WRITE ( 'left margin?' ) ;  
                  READLN ( INPUT , LEFTMARGIN ) ; END ; 
            'T' : BEGIN WRITE ( 'top margin?' ) ;
                  READLN ( INPUT , TOPMARGIN ) ; END ; 
            'B' : BEGIN WRITE ( 'bottom margin?' ) ;
                  READLN ( INPUT , BOTTOMMARGIN ) ; END ;
          END { CASE } ;
        
        PAGE ( OUTPUT ) ;
      END { REPEAT } ;
    UNTIL MARGINTYPE = ' ' ;
  END { MARGINS } ;

     { * * * * * * * * * * }

PROCEDURE HELPMARGINS ;

  BEGIN
    
    IF COMMAND = 'M' THEN
      MARGINS
        ELSE
          BEGIN
            HELPINSTR ;
            HELPCMNDS ;
            HELPDFLTS ;
          END { IF } ;

  END { HELPMARGINS } ;

     { * * * * * * * * * * }

PROCEDURE READFILENAME ;

  VAR
    COUNTER : INTEGER ;
    STILLREADING : BOOLEAN ;
    
  BEGIN 
    GOTFILES := TRUE ;
    COUNTER := 1 ;    STILLREADING := TRUE ;
    WHILE ( COUNTER < 10 ) AND ( STILLREADING = TRUE ) DO 
      BEGIN
        
        WRITE ( 'FILENAME / CR : ' ) ;
        READLN ( FILENAME ) ;
    
        IF FILENAME <> '' THEN 
          BEGIN
            FILES [ COUNTER ] := FILENAME ;
            NUMFILES := COUNTER ;
            COUNTER := COUNTER + 1 ;
          END { IF }
        ELSE
          STILLREADING := FALSE ;
      END { WHILE } ;
  END { READFILENAME } ;
     
     { * * * * * * * * * * }
     
PROCEDURE CARRYOUT ;
  
  VAR
    NEWDATE , NEWFILE : STRING ;
    PROMPTER : CHAR ;
    LIST : INTEGER ;
  
  BEGIN 
    CASE COMMAND OF
          
      'D' : BEGIN WRITE ( 'date today?' ) ; 
              READLN ( NEWDATE ) ; 
              IF NEWDATE <> '' THEN DATE := NEWDATE ;
            END ;
      'F' : READFILENAME ;
      'H' : HELPMARGINS ;
      'L' : BEGIN WRITELN ( '( < CR > to continue ) ' ) ;
              FOR LIST := 1 TO NUMFILES DO
              WRITELN ( FILES [ LIST ] ) ;
              READ ( KEYBOARD , PROMPTER ) ;
            END ;
      'M' : HELPMARGINS ;
      'N' : REPEAT 
              BEGIN PAGE ( OUTPUT ) ; 
              WRITE ( 'do you want pagenumbers?' ) ;
              READ ( KEYBOARD , NUMBERS ) ; 
              PAGE ( OUTPUT ) ;
              IF NUMBERS = 'Y' THEN
                BEGIN
                  WRITE ( 'T(op or B(ottom?' ) ;
                  READ ( KEYBOARD , TOPORBOTTOM ) ; 
                END
              END ;
            UNTIL ( NUMBERS = 'Y' ) OR ( NUMBERS = 'N' ) ;
      'P' : BEGIN WRITE ( 'what is your papersize? ' ) ;
              READLN ( INPUT , PAPERSIZE ) ; END ;
      'S' : REPEAT BEGIN PAGE ( OUTPUT ) ;
              WRITE ( 'do you want doublespaces?' ) ; 
              READ ( KEYBOARD , DOUBLESPACE ) ; END ;
       UNTIL ( DOUBLESPACE = 'Y' ) OR ( DOUBLESPACE = 'N' ) ;

    END { CASE } ;
  END { CARRYOUT } ;
     
     { * * * * * * * * * * }
     
PROCEDURE SETVARS ;
  
  VAR
    NUMSETS : INTEGER ;
  
  BEGIN
    GOTFILES := FALSE ;
    LEFTMARGIN := 10 ;
    TOPMARGIN := 4 ;
    BOTTOMMARGIN := 4 ;
    NUMBERS := 'Y' ;
    DOUBLESPACE := 'N' ;
    PAPERSIZE := 66 ;
    DATE := ' ' ;
    TOPORBOTTOM := 'T' ;
    NUMFILES := 0 ;
    
    FOR NUMSETS := 1 TO 9 DO
      FILES [ NUMSETS ] := ' ' ;
  
  END ;
     
     { * * * * * * * * * * }

PROCEDURE INITIALIZE ;
  VAR
    TORB : STRING ;
    INTROSPACES : INTEGER ;
    DELAY , DELAYARG : INTEGER ;
    ASTERISKS : INTEGER ;
  
  BEGIN
    PAGE ( OUTPUT ) ;
    
    FOR INTROSPACES := 1 TO 4 DO
      WRITELN ;
    FOR ASTERISKS := 1 TO 63 DO
      WRITE ( '*' ) ;
    WRITELN ;
    WRITELN ;
    WRITELN ( '               WELCOME TO WRITER VER.I.' ) ;
    WRITELN ;
    FOR ASTERISKS := 1 TO 63 DO
      WRITE ( '*' ) ;
      
    FOR DELAY := 1 TO 2000 DO 
      BEGIN
        DELAYARG := 0 ;
        DELAYARG := DELAYARG + 1 ;
      END ;
    
    SETVARS ;
    
    PAGE ( OUTPUT ) ;
    REPEAT
      WRITE ( 'WRITER: D(ate, F(ilename, H(elp, ' ) ;
      WRITELN ( 'L(ist, M(argins, N(umbers, ' ) ;
      WRITELN ( 'P(apersize, S(pacing ( < CR > to leave )' ) ;
        { DATE, FILENAME, HELP, LIST, MARGINS,
        NUMBERS, PAPERSIZE, SPACING }
      WRITELN ;
      
      IF TOPORBOTTOM = 'T' THEN TORB := 'TOP'
        ELSE TORB := 'BOTTOM' ;
      
      WRITELN ( 'number of files:' , NUMFILES ) ;
      WRITELN ( 'date:' , DATE ) ; 
      WRITELN ( 'left margin:' , LEFTMARGIN ) ;
      WRITELN ( 'top margin:' , TOPMARGIN ) ;
      WRITELN ( 'bottom margin:' , BOTTOMMARGIN ) ;
      WRITELN ( 'doublespaces:' , DOUBLESPACE ) ;
      WRITE ( 'pagenumbers:' , NUMBERS ) ;
      IF NUMBERS = 'Y' THEN
        WRITELN ( ' ( ' , TORB , ' OF PAGE )' )
      ELSE
        WRITELN ;
      WRITELN ( 'papersize:' , PAPERSIZE ) ;
      
      READ ( KEYBOARD , COMMAND ) ;
        PAGE ( OUTPUT ) ;
      CARRYOUT ;
        PAGE ( OUTPUT ) ;
    UNTIL COMMAND = ' ' ;
    
    IF TOPORBOTTOM = 'T' THEN 
      ENDLINES := BOTTOMMARGIN
        ELSE 
          ENDLINES := BOTTOMMARGIN + 3 ;
     
     
END { INITIALIZE } ;
     
     { * * * * * * * * * * }

BEGIN
  
  INITIALIZE ;
  
  IF GOTFILES = FALSE THEN READFILENAME ; 
  
  FOR NUMPRINTS := 1 TO NUMFILES DO
    WRTPAGE ( FILES [ NUMPRINTS ] ) ;

END.

========================================================================================
DOCUMENT :usus Folder:VOLUK03:ada.code
========================================================================================

< binary file -- not listed >

========================================================================================
DOCUMENT :usus Folder:VOLUK03:ada.text
========================================================================================

(*$L PRINTER:*)
(*$S+*)
{$G+}
program asc;
USES (*$U FILECHECK.CODE*) FILECHECK;

{$I #5:types.text}

   procedure er_error_message (error_number   : er_errornumber_range;
                               error_type     : er_error_type;
                               error_position : so_position;
                               error_symbol   : lu_sym_descriptor);
   forward;
(*       SPECIFIES AN ERROR MESSAGE*)
   function  er_num_of_errors : integer;
   forward;
(*    RETURNS THE ACTUAL NUMBER OF ERRORS*)
   function  er_number_of_warnings : integer;
   forward;
(*    RETURNS THE ACTUAL NUMBER OF WARNINGS*)
   procedure er_init;
   forward;
(*    TO INITIALIZE THE COUNTERS*)
(*END ERROR_MESSAGE_HANDLER;*)
   procedure co_int_to_string (int       :  integer;
                               base      :  co_base_type;
                               leading0  :  boolean;
                               last_char :  integer;
                         var   str       :  string);
      forward;
      (* INT IS CONVERTED TO STRING REPRESENTATION TO   BASE BASE*)
      (* IT IS IN STR(STR'FIRST..LAST_CHAR) WITH LEADING ZEROS OR*)
      (* BLANKS (LEADING0). IF IT DOES NOT FIT IT IS LEFT TRUNCATED.*)
      (* IF INT<0, THEN "-" IS IN FRONT OF THE DIGITS*)
   procedure co_its_left (int            :  integer;
                          base           :  co_base_type;
                    var   outp_last_char :  integer;
                    var   str            :  string);
      forward;
      (* INT IS CONVERTED TO STRING REPRESENTATION TO BASE BASE.*)
      (* THE DIGITS ARE LEFT ADJUSTED IN STR(STR'FIRST..LAST_CHAR)*)
      (* IF INT<0 THEN "-" IS IN FRONT OF THE DIGITS.*)
      (* ONLY NECESSARY PART OF STR IS USED*)
   procedure co_string_to_int (buffer    :  string;
                               firstc,
                               lastc     :  integer;
                               base      :  integer;
                          var  outp_too_large :  boolean;
                          var  outp_int       :  integer);
      forward;
      (* THE DIGITS] IN BUFFER(FIRSTC..LASTC) ARE CONVERTED TO*)
      (* BINARY VALUE WITH BASE BASE. TOO_LARGE INDICATES WHETHER AN*)
      (* OVERFLOW HAS OCCURED; THEN INT=MAX_INT.*)
      (* IN EVERY CASE ALL DIGITS ARE TESTED, THAT THEY ARE CORRECT.*)
      (* LASTC < FIRSTC IS ALLOWED, THEN INT=0.*)
(*END CONVERSION;*)
   procedure st_init; forward;
      (* INITIALIZATION: MUST BE CALLED BEFORE USE*)
      (* SETS THE SYMBOL TABLE EMPTY. CAN BE CALLED AT EVERY STAGE.*)
(*---------------------------------------------------------------*)
(* CODING: STRING --> ST_SYMBOL*)
(*---------------------------------------------------------------*)
   function  st_get_sub_code (str    :  string;
                              firstc,
                              lastc  :  integer;
                              enter  :  boolean) : st_symbol;
      forward;
      (* IF SYMBOL STR(FIRSTC..LASTC) IS ALREADY ENTERED THEN*)
      (*                                             RETURN ITS CODE*)
      (* ELSIF ENTER THEN INSERT STR(FIRSTC..LASTC)*)
      (* ELSE RETURN ST_NIL*)
   function  st_get_code (str : st_literal; l : integer) : st_symbol;
      forward;
      (* ST_GET_SUB_CODE( STR, STR'FIRST, STR'LAST, TRUE);*)
   function  st_get_char_code (chr  : char) : st_symbol;
      forward;
      (* ST_GET_CODE( (1=> CHR));    NO 1-CHARACTER STRINGS*)
(*---------------------------------------------------------------*)
(* RECODING: ST_SYMBOL  -->  STRING*)
(*---------------------------------------------------------------*)
   procedure st_get_string (code               : st_symbol;
                           var  str            : string;
                           var  outp_last_char : integer);
         forward;
      (* RETURN STR(STR'FIRST .. OUTP_LAST_CHAR) OF SYMBOL "CODE"*)
(*END SYMBOL_TABLE;*)
    (* procedure lu_init; forward; ---> removed since segment procedure *)
(*---------------------------------------------------------------*)
(*  LEXICAL UNITS FOR ERROR HANDLING*)
(*---------------------------------------------------------------*)
   (* procedure lu_error_symbol (lex_unit :    lu_lexical_unit;*)
                              (* var result :  lu_sym_descriptor);*)
   (* forward; MADE INTO SEG PROCEDURE *)
(*---------------------------------------------------------------*)
(* LEXICAL UNITS AS STRINGS*)
(*---------------------------------------------------------------*)
   procedure lu_str_of (symbol         : lu_sym_descriptor;
                      var  str            : string;
                      var  outp_last_char : integer);
      (* RETURNS THE STRING REPRESENTATION*)
   forward;
(*END LEXICAL_UNITS;*)
   (* procedure la_init; forward; ----> removed since segment procedure *)
      (* INITIALIZATION: MUST BE CALLED BEFORE LA_NEXT_SYM*)
   procedure la_next_sym (var outp_sym : lu_sym_descriptor;
                          var outp_pos    : so_position); forward;
      (* DELIVERS IN OUTP_SYMBOL THE NEXT LEXICAL UNIT*)
      (* OUTP_POS IS THE POSITION OF THE FIRST CHARACTER OF THE UNIT*)
(*END LEXICAL_ANALYZER;*)
{$I #5:luerror.text}
{$I #5:luinit.text}
{$I #5:lainit.text}
{$I #5:parser.text}
{$I #5:coint.text}
{$I #5:stget.text}
{$I #5:lanext.text}
   procedure so_init;
   begin
      so_nil_position.sourceline := 0;
      so_nil_position.column     := 1;
   end;
   procedure st_init ;
(*-------------------------------------------------------------------*)
(*                                                                  -*)
(*    DESCRIPTION: SYMTAB_ENTRIES ARE DELETED. SYMTAB_STRINGS IS SET-*)
(*    ------------ TO STB_EMPTY. ST_NIL BECOMES "<IDENT>".          -*)
(*                                                                  -*)
(*-------------------------------------------------------------------*)
   var loop_i : st_symbol;
   begin
      for loop_i := 1 to st_sym_ubound do
         stb_s_tab_entries [loop_i].textb := stb_empty;
    (*END LOOP;*)
      stb_number_char := stb_empty;
      stb_texttable_full := false; stb_hashtable_full := false;
      stb_s_tab_entries [st_nil] :=
           stb_s_tab_entries [ st_get_code ('<IDENT>  ',7)];
   end;  (*ST_INIT;*)
(*-------------------------------------------------------------------*)
   procedure lu_str_of; (* (SYMBOL         : LU_SYMBOL_DESCRIPTOR;
                          VAR  STR            : STRING;
                          VAR  OUTP_LAST_CHAR : INTEGER);  *)
(*-------------------------------------------------------------------*)
(*                                                                  -*)
(*    DESCRIPTION: RETURNS THE EXTERNAL STRING OF THE LEXICAL UNIT  -*)
(*    ------------                                                  -*)
(*-------------------------------------------------------------------*)
VAR
   DISCRIM : LU_SELECTOR;
   SHIFT : INTEGER;
   I, J, K, L : INTEGER;
  BEGIN
     DISCRIM :=SYMBOL.DISCRIM;
     CASE DISCRIM OF
     LU_ID :                                     BEGIN
          ST_GET_STRING (SYMBOL.IDCODE, STR, L);
          IF SYMBOL.SYM = LU_CHARACTER_SYM THEN BEGIN
             STR [SFIRST + 1] := STR[SFIRST];
             STR [SFIRST] := '''';
             STR [SFIRST + 2] := '''';
             OUTP_LAST_CHAR := SFIRST + 2;      END
          ELSE IF SYMBOL.SYM = LU_STRING_SYM THEN BEGIN
             SHIFT := 1;
             FOR I := L DOWNTO SFIRST DO  BEGIN
                STR [I + 1] := STR[I];
                IF STR[I] = '"' THEN      BEGIN
                   FOR J:= L + SHIFT DOWNTO I + 2 DO
                      STR[J+1] := STR[J];
                   STR[I+2] := '"';
                   SHIFT :=SHIFT + 1;     END;
             END;(*LOOP*)
             STR[SFIRST] := '"';
             OUT_PLAST_CHAR := L + SHIFT + 1;
             STR[OUTP_LAST_CHAR] := '"';    END
          ELSE
             OUTP_LAST_CHAR := L;                 END;

              lu_int :                                     begin
            str [sfirst] := '0';
            outp_last_char := sfirst;                      end;
              lu_real :                                    begin
            str [sfirst]   := '0';
            str [sfirst+1] := '.';
            str [sfirst+2] := '0';
            outp_last_char := sfirst+2;                    end;
              lu_other :                                  begin
            outp_last_char := sfirst + 1;
            case symbol.sym of
                    lu_dot_sym :                           begin
                  str [sfirst] := '.';
                  outp_last_char := sfirst;                end;
                    lu_interval_sym :                      begin
                  str [sfirst] := '.';
                  str [sfirst + 1] := '.';                 end;
                    lu_left_label_sym :                    begin
                  str [sfirst] := '<';
                  str [sfirst + 1] := '<';                 end;
                    lu_box_sym :                           begin
                  str [sfirst] := '<';
                  str [sfirst + 1] := '>';                 end;
                    lu_lpar_sym :                          begin
                  str [sfirst] := '(';
                  outp_last_char := sfirst;                end;
                    lu_separator_sym :                     begin
                  str [sfirst] := '!';
                  outp_last_char := sfirst;                end;
                    lu_rpar_sym :                          begin
                  str [sfirst] := ')';
                  outp_last_char := sfirst;                end;
                    lu_semicolon_sym :                     begin
                  str [sfirst] := ';';
                  outp_last_char := sfirst;                end;
                    lu_comma_sym :                         begin
                  str [sfirst] := ',';
                  outp_last_char := sfirst;                end;
                    lu_right_label_sym :                   begin
                  str [sfirst] := '>';
                  str [sfirst + 1] := '>';                 end;
                    lu_colon_sym :                         begin
                  str [sfirst] := ':';
                  outp_last_char := sfirst;                end;
                    lu_assign_sym :                        begin
                  str [sfirst] := ':';
                  str [sfirst + 1] := '=';                 end;
                    lu_quote_sym :                         begin
                  str [sfirst] := '''';
                  outp_last_char := sfirst;                end;
                    lu_arrow_sym :                         begin
                  str [sfirst] := '=';
                  str [sfirst + 1] := '>';                 end;
       lu_identifier_sym , lu_integer_sym    , lu_real_sym  ,
       lu_character_sym  , lu_string_sym,
       lu_eof_sym   ,
       lu_abort_sym , lu_accept_sym, lu_access_sym, lu_all_sym   ,
       lu_and_sym   , lu_array_sym , lu_at_sym    , lu_begin_sym ,
       lu_body_sym  , lu_case_sym  , lu_constant_sym   ,
       lu_declare_sym    , lu_delay_sym , lu_delta_sym , lu_digits_sym,
       lu_do_sym    , lu_else_sym  , lu_elsif_sym , lu_end_sym   ,
       lu_entry_sym , lu_exception_sym  , lu_exit_sym  , lu_for_sym   ,
       lu_function_sym   , lu_generic_sym    , lu_goto_sym  ,
       lu_if_sym    , lu_in_sym    , lu_is_sym    , lu_limited_sym    ,
       lu_loop_sym  , lu_mod_sym   , lu_new_sym   , lu_not_sym   ,
       lu_null_sym  , lu_of_sym    , lu_or_sym    , lu_others_sym,
       lu_out_sym   , lu_package_sym    , lu_pragma_sym,
       lu_private_sym    , lu_procedure_sym  , lu_raise_sym ,
       lu_range_sym , lu_record_sym, lu_rem_sym   , lu_renames_sym    ,
       lu_return_sym, lu_reverse_sym    , lu_salect_sym,
       lu_seperate_sym   , lu_subtype_sym    , lu_task_sym  ,
       lu_terminate_sym  , lu_then_sym  , lu_type_sym  , lu_use_sym   ,
       lu_when_sym  , lu_while_sym , lu_with_sym  , lu_xor_sym   ,
       lu_minus_sym ,  lu_less_sym  ,
        lu_less_equal_sym ,
        lu_plus_sym   ,
       lu_catenation_sym , lu_multiply_sym   , lu_exponentiation_sym  ,
       lu_divide_sym,
       lu_not_equal_sym  , lu_greater_sym    ,
       lu_greator_equal_sym   ,
       lu_equal_sym :
                                                           begin
                  str [sfirst] := 'e';
                  str [sfirst + 1] := 'o';
                  str [sfirst + 2] := 'f';
                  outp_last_char := sfirst + 2;            end;
          (*END CASE;*)
                                                           end;   end;
    (*END CASE;*)
                                                           end;
   end;    (* LU_STRING_OF;*)
(*-------------------------------------------------------------------*)
   procedure er_init;
   begin
     errors_count := 0;
     warnings_count := 0;
     error_no := 0;
     erb_last_pos := so_nil_position;
   end;
(*-------------------------------------------------------------------*)
   procedure er_error_message;(*(ERROR_NUMBER   : ER_ERRORNUMBER_RANGE;
                                 ERROR_TYPE     : ER_ERROR_TYPE;
                                 ERROR_POSITION : SO_POSITION;
                                 ERROR_SYMBOL   : LU_SYMBOL_DESCRIPTOR);*)
(*-------------------------------------------------------------------*)
(*    DESCRIPTION: PUTS THE MESSAGE DIRECTLY TO THE LISTING.        -*)
(*    ------------                                                  -*)
(*       ERROR_NO STARTS FROM 0. ERRORS WITH ERROR_TYPE HAVING THE  -*)
(*       VALUE ER_SYMBOL_INSERTED OR ER_RESET_POSITION ARE NOT      -*)
(*       COUNTED AS ERRORS                                          -*)
(*-------------------------------------------------------------------*)
   var
       str : so_symbol_string;
       l, i : integer;
   begin
     if (error_type <> er_reset_position) or
        (error_position.sourceline <> erb_last_pos.sourceline) or
        (error_position.column     <> erb_last_pos.column)
     then begin  (* RESET AT SAME POSITION IS IGNORED *)
        if error_type <> er_sym_inserted then begin
           if error_type = er_reset_position then
              l := error_position.column + 3
           else
              l := error_position.column + 4;
           for i := sfirst to l do
              write ( '-' );
           write ( '!' );
        end (*IF*);
        if error_type = er_syntax_error then begin
           erb_last_pos := error_position;
           writeln ('syntax error')
        end else if error_type = er_sym_inserted then begin
                               (* ONLY MESSAGE ABOUT INSERTED SYMBOL*)
           write ('symbol inserted: ');
           lu_str_of (error_symbol, str, l);
           for i := sfirst to l do
              write ( str [i]);
           writeln;
        end else if error_type = er_reset_position then
           writeln ('symbols ignored up to here')
        else
           if error_number = 1400 then
              writeln ('symbol table overflow')
           else if error_number = 1401 then
              writeln ('text table overflow')
           else if error_number = 1500 then
              writeln ('character not allowed here')
           else if error_number = 1501 then
              writeln ('(extended) digits expected')
           else if error_number = 1502 then
              writeln ('sharp or colon expected')
           else if error_number = 1503 then
              writeln ('string must end with line"')
           else if error_number = 1504 then
              writeln ('illegal insertion of underscore')
           else if error_number = 1505 then
              writeln ('adjacent identifiers/numbers must be separated')
           else if error_number = 1508 then
              writeln ( 'base not within 2..16')
           else if error_number = 1601 then
              writeln ( 'illegal exponent value')
           else if error_number = 1509 then
              writeln ( 'digit too large for base')
           else if error_number = 5097 then
              writeln ( 'inconsistent parser tables')
           else if error_number = 5099 then
              writeln ( 'parser stack overflow')
           else
              writeln ( 'compiler error: unknown error');
     end (*IF*);
     if error_type = er_warning then        (* COUNT THE ERRORS*)
        warnings_count := warnings_count + 1
     else if (error_type <> er_sym_inserted) and
             (error_type <> er_reset_position) then
             errors_count := errors_count + 1;
      error_no := error_no + 1;
   end;  (* ER_ERROR_MESSAGE;*)
(*-------------------------------------------------------------------*)
   function  er_num_of_errors; (*     RETURN INTEGER IS*)
   begin
      er_num_of_errors := errors_count;
   end;  (* ER_NUMBER_OF_ERRORS;*)
(*-------------------------------------------------------------------*)
   function  er_number_of_warnings;  (*   RETURN INTEGER IS*)
   begin
      er_number_of_warnings := warnings_count;
   end ; (* ER_NUMBER_OF_WARNINGS;*)
(*END ERROR_MESSAGE_HANDLER;*)




begin
   morefiles:=false;
 repeat
   write   ( '*********************');
   write ('*** START ADA SYNTAX CHECKER ***');
   writeln ( '********************');
   writeln ; writeln ;
   so_init;
   er_init;
   st_init;
   lu_init;
   la_init;
   CHECKINPUTMODE;
   parser;
   writeln; writeln; writeln;
   writeln ( er_num_of_errors:5, ' errors reported.');
   writeln;
   write   ( '********************');
   write   ( '*** END ADA SYNTAX CHECKER ***');
   writeln ( '********************');
   writeln; writeln; writeln;
   writeLN('Do you want to check any other Ada Files? --> type Y/N ');
   repeat
     read(reply);
     if reply ='Y' then morefiles:=true
      else if reply ='N' then morefiles:=false
      else write('Invalid Reply....Type again --> Y/N ');
   until reply in ['N','Y'];
 until MOREFILES=false;
end.
 


========================================================================================
DOCUMENT :usus Folder:VOLUK03:adadoc.text
========================================================================================


            DOCUMENTATION FOR THE SYNTAX CHECKER
                     BY EDGAR DE SOUZA
                     SWURCC MICRO UNIT

_1.  _O_b_j_e_c_t_i_v_e_s

SWURCC initially obtained a copy of the Ada Syntax  Checker,
with  the  intention  that  we  would  distribute the Syntax
Checker to the U.K Universities.

In our opinion (after several months) we realised  that  not
many  micro  units  in the UK Universities wanted the Syntax
Checker in its original form, since it  could  only  run  on
machines  with vast amounts of main memory (i.e mainframes).
Therefore it was decided that the Syntax Checker  should  be
modified  to  run  on smaller machines which would be easily
accessible to the majority of UK Universities. As the  Micro
Unit  at SWURCC had a Onyx microcomputer running the popular
Unix Operating System, we decided on trying to get the  Syn-
tax Checker running on this machine.

When this was achieved, Ali Tabatabai had completed his pro-
ject  on  getting the UCSD Operating System to run on top of
the Unix Operating System. Therefore it was  agreed  that  I
should  try  running  the Syntax Checker under UCSD with the
aim of allowing Universities with their 8 bit micros to  use
the Checker. On completing this task I transfered the Syntax
Checker to the Apple microcomputer thus putting  the  syntax
checker on two five and a quarter inch floppy disks.  It was
decided that a copy of these floppies should be made  avail-
able  to  the  USUS library, enabling all UCSD users to have
access to this software.

2. The Ada Syntax Checker running under the Unix Operating
System on the Onyx Microcomputer.
NB- In order to run the checker I had  to  insure  that  the
parser  tables  had  to be converted from a text file into a
file of integer. I did this by writing a short  pascal  pro-
gram named "gendat.text". This program converts
 'textdat.text' into  'tabdat.t'.  Once  the  parser  tables
(i.e. the file tabdat.t) consisting of 19486 numbers was set
up I managed to run the program. (Note  to  run  the  syntax
checker, the file ada.code must be executed).

At this stage it  must  be  noted  that  Ada  programs  were
entered  via  the  keyboard and the checked Ada program with
error messages was written to a file.  I  modified  this  by
redirecting  the  error messages to the console so one could
immediately see the errors as the program was being checked.

I then tried running the syntax checker (which  was  written
in  standard  Pascal) on the UCSD operating system which was
running on top of Unix. The firstproblem I  encountered  was
the  size of the UCSD stack (64K). It was impossible for the
whole syntax checker to be run, but it was possible  to  run
the checker with a bigger stack under Ali's UCSD implementa-
tion which had a stack size of 68K.  However  this  did  not
achieve  the  objective  of  running the syntax checker on a
standard UCSD machine, although it was useful in the initial
stages  of  modifying  the checker for the UCSD system.  The
way I finally overcame this problem was by setting  up  seg-
ment procedures. Initially I tried cutting down some ineffi-
cient text of the program, these changes are as follows:
 (a) new_symbol in procedure lu_error_symbol
 (b) new_current_char in procedure la_next_sym etc.

Finally I created the following segment procedures:
  (a) segment  procedure  parser  -  which  initializes  the
parser  tables  and  does  the  actual syntax checking using
these parser tables.
  (b) segment procedure  lu_init  -  which  initializes  the
reserved word table
  (c) segment procedure  la_init  -  which  initializes  the
character set
  (d) segment procedure lu_error_symbol - which is used  for
error output

The reason for choosing the above is:

     (a) I had to choose procedure parser (even though it is
     heavily  used)  since  it  is the biggest procedure and
     space had to be created to load the next two initializ-
     ing procedures.

     (b)+(c) In the case of the init's (la-init and lu_init)
     they  are only used at the beginning for initialisation
     and never againn.

     (d) In the case of lu_error_symbol this procedure  will
     only be used if errors are encountered.

In order to set up these segments I had to split the file up
into  logical units in Unix before passing them over to UCSD
as the UCSD editor has a maximum limit of about 20K  and  my
program  was  about  64K.  I wrote two simple shell programs
which facilitated the import and export of Unix files to and
from UCSD.

I split the program up into the above segment procedures, as
well as the other files listed below:
  (1) st_get.text
  (2) la_next.text
  (3) co_int.text

(NB- all these three files are used in the input part of the
syntax  checker, validating the input and passing it over to
the parser).

  (4)  types.text  -  This  file  contains  all  the  global
declarations of constants, types and varables.

On inspection of my program it  can  be  seen  that  I  have
included 7 files in the main program entitled "asc" found in
the file "ada.text". Each file included in the program has a
compiler  directive  put  in  front  of  the filename, which
informs the compiler that the source from an  external  file
must  be  compiled and the code must be added to the code of
the program. The compiler directive and the filename must be
enclosed within a comment i.e. (*$I filename *).

On creating the  above  segment  procedures  and  using  the
included  files, I managed to run the program on UCSD (which
was running on the Onyx). One point to notice  is  that  all
the  text  for  the segment procedures must occur before any
other text from the program or  other  ordinary  procedures.
Also  if  any ordinary procedures are used by a segment pro-
cedure the ordinary procedure must be declared FORWARD.

_4.  _T_h_e _A_d_a _S_y_n_t_a_x _C_h_e_c_k_e_r _r_u_n_n_i_n_g _u_n_d_e_r _U_C_S_D _o_n  _t_h_e  _A_p_p_l_e
_M_i_c_r_o_c_o_m_p_u_t_e_r

My final goal was to transport  this  program  over  to  the
Apple  running UCSD Version 2.1. I managed to get the syntax
checker over after several file transfers. I  then  modified
the  checker to accept more than one file of input, (via the
keyboard only) thus avoiding the  overhead  of  loading  the
parser tables each time a program was checked.

I then included a printer unit named filecheck which allowed
input  from a file possible as well as input from the termi-
nal. In order to achieve this last goal  (usually  a  simple
task   in   'UCSD'   Pascal).   I   had  to  create  a  unit
'Filecheck.text' The reason being is that I  needed  to  use
the UCSD 'string' intrinsic which in the program was defined
as a packed array of char in standard Pascal.

With the presence of the unit filecheck in  the  Ada  syntax
checker,  the  unit must now be compiled and the code linked
to the code of the main program.

The checker running under UCSD successfully checks the  test
Ada program named "adatest.text" which contains all the con-
structs of the Ada language. This program  is  part  of  the
original  distribution.   If the checker is working properly
no errors should be found. I have also checked another short
Ada program of my own, it is entitled "dial.text".

One final point to note under the present  UCSD  version  of
the  checker  is that the end of file (eof) character is the
'$', this can be changed to suit your system. Also when typ-
ing  in from the keybaord the '$' character must be typed in
after the Ada program is typed in.

========================================================================================
DOCUMENT :usus Folder:VOLUK03:adatest.text
========================================================================================

 1 ) ,
1 ) * ( 1 in ID ( 1
.. 1 => 1 ) , 1 ) ** (
1 and 1 and 1 ,
1 ) ) ; use ID ( ID ' ( 1
, 1 ) ) ( 1 or 1 or
1 , ID ( 1 xor 1 xor
1 ) range ( 1 and then 1 and
then 1 , 1 ) + ( 1 or else
1 or else 1 , 1 ) *
1 .. 1 => 1 ) ; procedure
ID is ID : ID ; for ID use
1 ; procedure ID ( ID : ID ) is
begin null ; end ; generic package ID is ID : constant
ID ; use ID ; ID : constant array ( ID
range <> ) of ID := 1 ; end ; begin accept
ID ; << ID >> if 1 then pragma
ID ; ID := 1 ; elsif 1
then exit ; return ; end if ; exception when ID => return
1 ; goto ID ; end ID ;
pragma ID ( 1 , 1 ) ; procedure
ID ;
pragma ID ( ID => 1 ) ; procedure
ID ;
package ID is end ;
package body ID is end ;
separate ( ID ) package body ID is end ;
generic procedure ID ;
procedure ID is new ID ;
function ID is new ID ;
function ID return ID ;
procedure ID ( ID : ID ) ;
procedure ID ( ID : ID ; ID :
ID ) ;
procedure ID ( ID , ID : ID ) ;
procedure ID ( ID : in ID ) ;
procedure ID ( ID : out ID ) ;
procedure ID ( ID : in out ID ) ;
procedure ID ( ID , ID , ID :
ID ) ;
function "**" return ID ;
generic ID : ID ; procedure ID ;
generic type ID is private ; procedure ID ;
generic with procedure ID ; procedure ID ;
generic with procedure ID is ID ; procedure ID
;
generic with procedure ID is <> ; procedure ID ;
generic type ID ( ID : ID ) is private ;
procedure ID ;
generic type ID ( ID : ID ; ID :
ID ) is private ; procedure ID ;
generic type ID ( ID , ID : ID ) is
private ; procedure ID ;
generic type ID is ( <> ) ; procedure ID ;
generic type ID is range <> ; procedure ID ;
generic type ID is delta <> ; procedure ID ;
generic type ID is digits <> ; procedure ID ;
generic type ID is array ( ID ) of ID ;
procedure ID ;
generic type ID is access ID ; procedure ID ;
generic type ID is array ( ID range <> , ID
range <> ) of ID ; procedure ID ;
generic type ID is array ( ID , ID ) of
ID ; procedure ID ;
generic type ID is array ( 1 .. 1
) of ID ; procedure ID ;
generic type ID is limited private ; procedure ID ;
generic with function ID return ID is ID ;
procedure ID ;
procedure ID is for ID use 1 ; begin
null ; end ;
procedure ID is procedure ID is separate ; begin null
; end ;
procedure ID is ID , ID : constant ID
; begin null ; end ;
procedure ID is ID , ID : constant array (
ID ) of ID ; begin null ; end ;
procedure ID is ID : constant := 1 ;
begin null ; end ;
procedure ID is ID , ID : constant :=
1 ; begin null ; end ;
procedure ID is type ID is private ; begin null ; end
;
procedure ID is type ID ; begin null ; end ;
procedure ID is subtype ID is ID ; begin null
; end ;
procedure ID is procedure ID ; begin null ; end ;
procedure ID is package ID is end ; begin null ; end ;
procedure ID is task ID ; begin null ; end ;
procedure ID is ID : exception ; begin null ; end ;
procedure ID is ID , ID : exception ; begin
null ; end ;
procedure ID is ID : ID renames ID ;
begin null ; end ;
procedure ID is ID : exception renames ID ;
begin null ; end ;
procedure ID is package ID renames ID ; begin
null ; end ;
procedure ID is task ID renames ID ; begin
null ; end ;
procedure ID is procedure ID renames ID ;
begin null ; end ;
procedure ID is pragma ID ; begin null ; end ;
procedure ID is ID : array ( ID ) of
ID ; begin null ; end ;
procedure ID is ID , ID : array ( ID )
of ID ; begin null ; end ;
procedure ID is type ID is ( ID ) ; begin null
; end ;
procedure ID is type ID is range 1 ..
1 ; begin null ; end ;
procedure ID is type ID is digits 1 ;
begin null ; end ;
procedure ID is type ID is array ( ID ) of
ID ; begin null ; end ;
procedure ID is type ID is record end record ; begin
null ; end ;
procedure ID is type ID is access ID ; begin
null ; end ;
procedure ID is type ID is new ID ; begin null
; end ;
procedure ID is type ID is ( ID , ID )
; begin null ; end ;
procedure ID is type ID is ( 'A' ) ;
begin null ; end ;
procedure ID is type ID is record null ; end record ;
begin null ; end ;
procedure ID is type ID is record ID :
ID ; end record ; begin null ; end ;
procedure ID is type ID is record case ID is
end case ; end record ; begin null ; end ;
procedure ID is type ID is record case ID is
when 1 => end case ; end record ; begin null ; end ;
procedure ID is package ID is new ID ; begin
null ; end ;
procedure ID is package ID is private end ; begin null
; end ;
procedure ID is package ID is private for ID
use 1 ; end ; begin null ; end ;
procedure ID is package ID is private for ID
use record end record ; end ; begin null ; end ;
procedure ID is package ID is private for ID
use at 1 ; end ; begin null ; end ;
procedure ID is package ID is private for ID
use record at mod 1 ; end record ; end ; begin null ;
end ;
procedure ID is package ID is private for ID
use record ID at 1 range 1 ..
1 ; end record ; end ; begin null ; end ;
procedure ID is package ID is private for ID
use 1 ; pragma ID ; end ; begin null ; end ;
procedure ID is package ID is private for ID
use 1 ; for ID use 1 ; end ; begin
null ; end ;
procedure ID is package ID is end ID ; begin
null ; end ;
procedure ID is task type ID ; begin null ; end ;
procedure ID is task ID is end ; begin null ; end ;
procedure ID is task ID is entry ID ; end ;
begin null ; end ;
procedure ID is task ID is entry ID (
ID ) ; end ; begin null ; end ;
procedure ID is for ID use 1 ; task
ID ; begin null ; end ;
procedure ID is for ID use 1 ; procedure
ID is separate ; begin null ; end ;
procedure ID is for ID use 1 ; task body
ID is begin null ; end ; begin null ; end ;
procedure ID is for ID use 1 ; package
body ID is begin null ; end ; begin null ; end ;
procedure ID is for ID use 1 ; package
body ID is begin ID ; end ; begin null ; end ;
procedure ID is for ID use 1 ; package
body ID is begin delay 1 ; end ; begin null ;
end ;
procedure ID is for ID use 1 ; package
body ID is begin abort ID ; end ; begin null ; end ;
procedure ID is for ID use 1 ; package
body ID is begin raise ; end ; begin null ; end ;
procedure ID is for ID use 1 ; package
body ID is begin ID ' ( 1 ) ; end ;
begin null ; end ;
procedure ID is for ID use 1 ; package
body ID is begin exit ID ; end ; begin null ; end ;
procedure ID is for ID use 1 ; package
body ID is begin exit when 1 ; end ; begin null
; end ;
procedure ID is for ID use 1 ; package
body ID is begin case 1 is end case ; end ;
begin null ; end ;
procedure ID is for ID use 1 ; package
body ID is begin loop null ; end loop ; end ; begin null ; end
;
procedure ID is for ID use 1 ; package
body ID is begin ID : loop null ; end loop ID
; end ; begin null ; end ;
procedure ID is for ID use 1 ; package
body ID is begin begin null ; end ; end ; begin null ; end ;
procedure ID is for ID use 1 ; package
body ID is begin ID : begin null ; end ID ;
end ; begin null ; end ;
procedure ID is for ID use 1 ; package
body ID is begin select terminate ; end select ; end ; begin
null ; end ;
procedure ID is for ID use 1 ; package
body ID is begin select ID ; else null ; end select ;
end ; begin null ; end ;
procedure ID is for ID use 1 ; package
body ID is begin select ID ; or delay 1
; end select ; end ; begin null ; end ;
procedure ID is for ID use 1 ; package
body ID is begin if 1 then null ; else null ;
end if ; end ; begin null ; end ;
procedure ID is for ID use 1 ; package
body ID is begin case 1 is when 1
=> null ; end case ; end ; begin null ; end ;
procedure ID is for ID use 1 ; package
body ID is begin for ID in ID loop null ; end
loop ; end ; begin null ; end ;
procedure ID is for ID use 1 ; package
body ID is begin for ID in reverse ID loop
null ; end loop ; end ; begin null ; end ;
procedure ID is for ID use 1 ; package
body ID is begin while 1 loop null ; end loop ;
end ; begin null ; end ;
procedure ID is for ID use 1 ; package
body ID is begin declare begin null ; end ; end ; begin null ;
end ;
procedure ID is for ID use 1 ; package
body ID is begin begin null ; exception when ID !
ID => null ; end ; end ; begin null ; end ;
procedure ID is for ID use 1 ; package
body ID is begin begin null ; exception when others => null ;
end ; end ; begin null ; end ;
procedure ID is for ID use 1 ; package
body ID is begin accept ID do null ; end ; end ; begin
null ; end ;
procedure ID is for ID use 1 ; package
body ID is begin accept "**" ; end ; begin null ;
end ;
procedure ID is for ID use 1 ; package
body ID is begin accept ID . ID ; end ; begin
null ; end ;
procedure ID is for ID use 1 ; package
body ID is begin accept ID . "**" ; end ;
begin null ; end ;
procedure ID is for ID use 1 ; package
body ID is begin accept ID ( 1 ) ; end ;
begin null ; end ;
procedure ID is for ID use 1 ; package
body ID is begin select when 1 => terminate ;
end select ; end ; begin null ; end ;
procedure ID is for ID use 1 ; package
body ID is begin select accept ID ; end select ; end ;
begin null ; end ;
procedure ID is for ID use 1 ; package
body ID is begin select delay 1 ; end select ;
end ; begin null ; end ;
procedure ID is for ID use 1 ; package
body ID is begin select accept ID ; null ; end select
; end ; begin null ; end ;
procedure ID is for ID use 1 ; package
body ID is begin select terminate ; or terminate ; end select
; end ; begin null ; end ;
procedure ID is for ID use 1 ; package
body ID is separate ; begin null ; end ;
procedure ID is for ID use 1 ; task body
ID is separate ; begin null ; end ;
procedure ID is for ID use 1 ; task
ID ; pragma ID ; begin null ; end ;
procedure ID is package body ID is end ; begin null ;
end ;
========================================================================================
DOCUMENT :usus Folder:VOLUK03:coint.text
========================================================================================


   procedure co_int_to_string;(* (INT       :  INTEGER;
                                  BASE      :  CO_BASE_TYPE;
                                  LEADING0  :  BOOLEAN;
                                  LAST_CHAR :  INTEGER;
                            VAR   STR       :  STRING); *)
(*-------------------------------------------------------------------*)
(*                                                                  -*)
(* INT IS CONVERTED TO STRING REPRESENTATION TO   BASE BASE         -*)
(* IT IS IN STR(STR'FIRST..LAST_CHAR) WITH LEADING ZEROS OR         -*)
(* BLANKS (LEADING0). IF IT DOES NOT FIT IT IS LEFT TRUNCATED.      -*)
(* IF INT<0 THEN "-" IS IN FRONT OF THE DIGITS.                     -*)
(*                                                                  -*)
(*-------------------------------------------------------------------*)
label 1701;
var
      int1 : integer;
      digit, i : integer;
      c : char;
      minus : boolean;
      loop_j : integer;
   begin  (* CO_INT_TO_STRING*)
      int1 := int;
      minus := false;
      if int1 < 0 then
         minus :=true;
    (*END IF;*)
      i := last_char;
      repeat
         digit := int1 mod base;
         if digit < 0 then
            digit := - digit;
       (*END IF;*)
         if(0 <= digit)and(digit <= 9)then
            str [i] := chr (digit + ord ('0'))
         else
            str [i] := chr (digit - 10 + ord ('A'));
       (*END IF;*)
         int1 := int1 div base;
         i := i - 1;
         if (i < sfirst)or(int1 = 0) then goto 1701;
      until false;
1701 :
      if i >= sfirst then                                  begin
         if leading0 then
            c := '0'
         else
            c := ' ';
       (*END IF;*)
         if minus then                                     begin
            str [i] := '-';
            i := i - 1;                                    end;
       (*END IF;*)
         for loop_j := sfirst to i do
            str [loop_j] := c;                                  end
       (*END LOOP;*)
    (*END IF;*)
   end;   (*   CO_INT_TO_STRING;*)
(*-------------------------------------------------------------------*)
   procedure co_its_left; (* (INT            :  INTEGER;
                              BASE           :  CO_BASE_TYPE;
                        VAR   OUTP_LAST_CHAR :  INTEGER;
                        VAR   STR            :  STRING);   *)
(*-------------------------------------------------------------------*)
(*                                                                  -*)
(* INT IS CONVERTED TO STRING REPRESENTATION TO BASE BASE.          -*)
(* THE DIGITS ARE LEFT ADJUSTED IN STR(STR'FIRST..LAST_CHAR)        -*)
(* IF INT<0 THEN "-" IS IN FRONT OF THE DIGITS.                     -*)
(* ONLY NECESSARY PART OF STR IS USED                               -*)
(*                                                                  -*)
(*-------------------------------------------------------------------*)
   label 1702;
   var
      int1 : integer;
   begin  (* CO_ITS_LEFT*)
      int1 := int;
    (* COMPUTE NUMBER OF DIGITS*)
      if int1 < 0 then
         outp_last_char := sfirst + 1
      else
         outp_last_char := sfirst;
    (*END IF;*)
      repeat
         int1 := int1 div base;
         if int1 = 0 then goto 1702;
         outp_last_char := outp_last_char + 1;
      until false;
1702 :
     (* CALL CO_INT_TO_STRING*)
      co_int_to_string (int, base, false, outp_last_char, str);
   end;   (*   CO_ITS_LEFT;*)
(*-------------------------------------------------------------------*)
   procedure co_string_to_int; (* (BUFFER    :  STRING;
                                   FIRSTC,
                                   LASTC     :  INTEGER;
                                   BASE      :  INTEGER;
                              VAR  OUTP_TOO_LARGE :  BOOLEAN;
                              VAR  OUTP_INT       :  INTEGER); *)
(*-------------------------------------------------------------------*)
(* THE DIGITS] IN BUFFER(FIRSTC..LASTC) ARE CONVERTED TO            -*)
(* BINARY VALUE WITH BASE BASE. TOO_LARGE INDICATES WHETHER AN      -*)
(* OVERFLOW HAS OCCURED; THEN INT=MAX_INT.                          -*)
(* LASTC < FIRSTC IS ALLOWED, THEN INT=0.                           -*)
(*                                                                  -*)
(*-------------------------------------------------------------------*)
   label 1703;
   var
      digit : integer;
      err : boolean;
      loop_i : integer;
   begin  (* CO_STRING_TO_INT*)
      err := false;
      outp_int := 0;  outp_too_large := false;
      for loop_i := firstc to lastc do                     begin
         case buffer [loop_i] of
              '0' , '1' , '2' , '3' , '4' , '5' , '6' , '7' , '8' ,
               '9' :
               digit :=
                  ord (buffer [loop_i]) - ord ('0');
                 'A' , 'B' , 'C' , 'D' , 'E' , 'F' :
               digit :=
                  ord (buffer [loop_i]) - ord ('A') + 10;
                 'G' , 'H' , 'I' , 'J' , 'K' ,  'L' ,  'M'  ,
                 'N' , 'O' , 'P' , 'Q' , 'R' ,  'S' ,  'T'  ,
                 'U' , 'V' , 'W' , 'X' , 'Y' ,  'Z'
                                                        :
               err :=true;
         end;           (*  CASE;*)
         if err or (digit >= base) then                    begin
            er_error_message (1700,
                              er_compiler_error,
                              so_nil_position, lu_no_symbol  );
            goto 1703;                                     end;
       (*END IF;*)
         if outp_int >((max_int - digit) div base)then       begin
            outp_too_large :=true;
            outp_int := max_int;                           end
         else
            outp_int := outp_int * base + digit;
       (*END IF;*)
                                                           end;
    (*END LOOP;*)
1703 :
   end;    (*    CO_STRING_TO_INT;*)
(*-------------------------------------------------------------------*)
(*END CONVERSION; *)


========================================================================================
DOCUMENT :usus Folder:VOLUK03:contents.text
========================================================================================


USUS(UK) SOFTWARE LIBRARY VOLUME 3                    25th August 1982


Contents of this volume                         Edgar De Souza, SWURCC

____________________________________________________
 
 Ada Syntax checker

   
The files on the disk are the following:
COINT.TEXT        14 27-Jan-82
STGET.TEXT        12 27-Jan-82
LUERROR.TEXT      14 27-Jan-82
LAINIT.TEXT        8 27-Jan-82
LUINIT.TEXT       16 27-Jan-82
PARSER.TEXT       40 14-May-82
TYPES.TEXT        18 14-May-82
LANEXT.TEXT       40 14-May-82
ADA.TEXT          34 14-May-82
FILECHECK.TEXT     4 20-May-82
ADADOC.TEXT       20 14-May-82
ADATEST.TEXT      26 14-May-82
CONTENTS.TEXT      4 25-Aug-82
TEXTDAT.TEXT     142 27-Jan-82
DIAL.TEXT          2 14-May-82
ADA.CODE          33 20-May-82
GENDAT.TEXT        4 14-May-82
GENDAT.CODE        2 14-May-82

IN ORDER TO RUN THE CHECKER
PLACE UKVOL3  IN DRIVE 5, AND EXECUTE
THE CODE FILE ADA.CODE.
         
DOCUMENTATION FOR THIS PROGRAM IS ADADOC.TEXT 


========================================================================================
DOCUMENT :usus Folder:VOLUK03:filecheck.text
========================================================================================

UNIT FILECHECK;

INTERFACE 
VAR FILEIN:TEXT;
    FILEINPUT:BOOLEAN;
PROCEDURE CHECKINPUTMODE;

IMPLEMENTATION 
PROCEDURE CHECKINPUTMODE;
VAR 
   INFILE:STRING;
   ERROR:INTEGER;
   MODE:CHAR;
BEGIN
     WRITE('DO YOU WANT TO INPUT FROM A F)ILE OR K)EYBOARD-->TYPE F/K ');
     REPEAT
      READ(MODE); WRITELN;
      IF MODE = 'F' THEN
       BEGIN
           WRITELN('ENTER FILENAME');
           REPEAT
                 READLN(INFILE);
                 (*$I- *)
                 RESET(FILEIN,INFILE);
                 (*$I+ *)
                 ERROR:=IORESULT;
                 IF ERROR <> 0 THEN WRITELN('ERROR IN FILENAME-->TYPE AGAIN');
           UNTIL ERROR=0;
           FILEINPUT:=TRUE;
       END
      ELSE IF MODE = 'K' THEN FILEINPUT:=FALSE
      ELSE WRITELN('FILE NOT FOUND--> TYPE AGAIN F/K ');
     UNTIL MODE IN ['F','K'];
     WRITELN; WRITELN; WRITELN;
END;

END.


========================================================================================
DOCUMENT :usus Folder:VOLUK03:gendat.code
========================================================================================

< binary file -- not listed >

========================================================================================
DOCUMENT :usus Folder:VOLUK03:gendat.text
========================================================================================

PROGRAM GENDAT;
VAR I:INTEGER;
    TABDAT:FILE OF INTEGER;
    TEXTDAT:TEXT;
BEGIN
     WRITELN('START TABDAT GENERATION');
     REWRITE(TABDAT,'#5:TABDAT.T');
     RESET(TEXTDAT,'#5:TEXTDAT.TEXT');
     I:=0;
     READ(TEXTDAT,TABDAT^);
     WHILE NOT EOF(TEXTDAT) DO
      BEGIN
           I:=SUCC(I);
           PUT(TABDAT);
           READ(TEXTDAT,TABDAT^);
      END;
     WRITELN;
     CLOSE(TABDAT,LOCK);
     WRITELN('END TABDAT GENERATION');
     WRITELN('THERE ARE ', I , ' NUMBERS GENERATED');
END.


========================================================================================
DOCUMENT :usus Folder:VOLUK03:lainit.text
========================================================================================


(*END LEXICAL_UNITS;*)
   segment procedure la_init;
(*------------------------------------------------------------------*)
(*                                                                 -*)
(*   DESCRIPTION: INITIALIZATION OF BUFFER                         -*)
(*   ------------                                                  -*)
(*                                                                 -*)
(*   SPECIALITIES: MUST BE CALLED BEFORE FIRST CALL OF LA_NEXT_SYM -*)
(*   -------------                                                 -*)
(*------------------------------------------------------------------*)
const smallest_char_num = 0;    (*ADJUST*)
      biggest_char_num  = 255;  (*ADJUST*)
var   loop_i , chr_type : char;
   begin  (* LA_INIT*)
(* CHAR_TYPE_TABLE INIT*)
   for loop_i := chr(smallest_char_num) to chr(biggest_char_num) do
      char_type_table [loop_i] := non_ada;
      for chr_type := 'A' to 'F' do char_type_table [chr_type] := letter_a_f;
      for chr_type := 'G' to 'Z' do char_type_table [chr_type] := letter_g_z;
      for chr_type := 'a' to 'z' do char_type_table [chr_type] := low_letter;
      for chr_type := '0' to '9' do char_type_table [chr_type] := digit;
      char_type_table [eof_char]  := eofc;
      char_type_table [chr (cr) ] := nwline;
      char_type_table [chr (lf) ] := nwline;
      char_type_table [chr (vt) ] := nwline;
      char_type_table [chr (ff) ] := nwline;
      char_type_table [chr (nul)] := ignore;
      char_type_table [chr (del)] := ignore;
      char_type_table [chr (ht) ] := htab;
      char_type_table ['''']:= quote;
      char_type_table ['"'] := dquote;
      char_type_table ['%'] := dquote;
      char_type_table ['-'] := hyphen;
      char_type_table ['&'] := ampersand;
      char_type_table ['('] := lpar;
      char_type_table [')'] := rpar;
      char_type_table ['*'] := asterisk;
      char_type_table ['+'] := plus;
      char_type_table [','] := comma;
      char_type_table ['.'] := point;
      char_type_table ['/'] := slash;
      char_type_table [':'] := colon;
      char_type_table [';'] := semicolon;
      char_type_table ['<'] := langle;
      char_type_table ['='] := equal;
      char_type_table ['>'] := rangle;
      char_type_table ['|'] := vbar;
      char_type_table ['!'] := vbar;
      char_type_table ['_'] := underscore;
      char_type_table [' '] := blank;
      char_type_table ['#'] := other_graphics;
      char_type_table ['?'] := other_graphics;
      char_type_table ['@'] := other_graphics;
      char_type_table ['['] := other_graphics;
      char_type_table [']'] := other_graphics;
      char_type_table ['~'] := other_graphics;
      char_type_table ['|'] := other_graphics;
      char_type_table ['['] := other_graphics;
(* BUFFER INITIALIZATION*)
      line_no := 0;
      current := sfirst;
      last_char := current;
      current_char := chr (cr) ;
      buffer [current] := chr (cr) ;
      buffer [current + 1] := chr (cr);
      lu_error_symbol (lu_eof_sym, last_symbol);
      last_pos := so_nil_position;
   end;   (*LA_INIT*)


========================================================================================
DOCUMENT :usus Folder:VOLUK03:lanext.text
========================================================================================


(*------------------------------------------------------------------*)
   procedure la_next_sym; (*(VAR OUTP_SYMBOL : LU_SYMBOL_DESCRIPTOR;*)
                          (* VAR OUTP_POS    : SO_POSITION);*)
(*------------------------------------------------------------------*)
(*      OUTP_SYMBOL  : NEXT LEXICAL UNIT                           -*)
(*      OUTP_POS     : POSITION OF THE FIRST CHARACTER OF THE UNIT -*)
(*      EXTRACTS THE NEXT LEXICAL ELEMENT AND ENTERS IT IN THE     -*)
(*      CORRESPONDING TABLE.                                       -*)
(*                                                                 -*)
(*   SPECIALITIES: ENTRY/EXIT INVARIANT: CURRENT IS NEXT CHARACTER -*)
(*   ------------- (SEE ALSO BUFFER)                               -*)
(*------------------------------------------------------------------*)
label 88, 66, 55, 11;
var   sharp_char, string_bracket : char;
      current_type : character_type;
      uflag, error : boolean;
      firstc, pos1, pos2, pos3, exp_last : so_sorcecolumn_range;
      base : integer;
      exp_positive : boolean;
      i_code : st_symbol;
      hstr : so_sorce_string;
      error_pos : so_position;
   procedure new_current_char;
   begin
        current := succ(current);
        current_char := buffer [current];
   end;
   procedure new_sym (new_discrim : lu_selector; new_symbol : lu_lexical_unit;
                            new_idcode : st_symbol);
   begin
        outp_sym.discrim := new_discrim;
        outp_sym.sym     := new_symbol;
        outp_sym.idcode  := new_idcode;
   end;
      procedure sequence (sbase       :  integer;
                          start_shift :  so_sorcecolumn_range;
                     var  outp_shiftp :  so_sorcecolumn_range);
  (* SCANS A SEQUENCE OF (EXTENDED) DIGITS WITH UNDERSCORES*)
  (* SHIFTS THEM TO HSTR TO DELETE THE UNDERSCORES*)
  (*AFTERWARDS THE STRING IS FOUND IN HSTR(START_SHIFT..OUTP_SHIFTP-1)*)
  (* LOW LETTERS ARE REPLACED BY UPPER LETTERS*)
  (* THE DIGITS ARE CHECKED TO BE LESS THAN SBASE*)
  (* AT LEAST ONE DIGIT MUST BE THERE*)
  (* CURRENT IS THE FIRST CHAR OF THE SEQUENCE*)
       label 99;
var      err, uflg : boolean;
         first_time : boolean;
         curr_type : character_type;
         c : char;
      begin
         err := false;
         uflg := false;
         first_time:= true;
         outp_shiftp := start_shift;
         repeat
            curr_type := char_type_table [current_char];
            if curr_type = low_letter then       begin
               c := chr( ord('A') + ord(current_char) - ord('a'));
               curr_type := char_type_table [c]; end
            else
               c := current_char;
          (*END IF;*)
            if (curr_type = digit) or
              ((sbase > 10)and (curr_type = letter_a_f))then  begin
               if     (curr_type = digit) and
                      (ord(c) - ord('0') >= sbase)
                  or  (curr_type = letter_a_f) and
                      (ord(c) - ord('A') +10 >= sbase) then begin
                (* NO CORRECT DIGIT FOR THIS BASE*)
                  error_pos.sourceline := line_no;
                  error_pos.column     := current;
                  er_error_message (1509, er_symbol_error,
                                    error_pos, lu_no_symbol);
                  c := '0';
               end (*IF*);
               hstr [outp_shiftp] := c;
               outp_shiftp := outp_shiftp + 1;
               uflg := false;                               end
     else   if curr_type = underscore then                  begin
               if uflg or first_time then
                  err := true;
             (*END IF;*)
               uflg := true;                                end
            else
               goto 99;
          (*END IF;*)
            first_time := false;
            new_current_char;
         until false;
99 :     if uflg or err then
            er_error_message ( 1504, er_symbol_error,
                               outp_pos, lu_no_symbol  )
    else    if first_time then
            er_error_message (1501, er_symbol_error,
                              outp_pos, lu_no_symbol  );
       (*END IF;*)
      end;            (*   SEQUENCE;*)
(*----------------------------------------------------------*)
      procedure exponent (    expf : so_sorcecolumn_range;
                          var outp_expl : so_sorcecolumn_range;
                          var outp_expp : boolean);
        (* SCANS AN OPTIONAL INTEGER OR REAL EXPONENT*)
        (* SYNTAX: E ([+] ! -)  INTEGER*)
        (* THE EXPONENT DIGITS ARE AFTERWARDS IN HSTR(EXPF..OUTP_EXPL)*)
        (* OUTP_EXPP INDICATES WHETHER THE EXPONENT IS POSITIVE*)
        (* CURRENT MUST BE THE FIRST CHARACTER*)
      begin
         if(current_char = 'E')or(current_char = 'e')then     begin
         (*  SCAN THE EXPONENT*)
            new_current_char;
            outp_expp := current_char <> '-';
            if(current_char = '-')or(current_char = '+')then new_current_char;
          (*END IF;*)
            sequence (10, expf, outp_expl);
            outp_expl := outp_expl - 1;                       end
         else                                                 begin
            outp_expl := expf - 1;
            outp_expp := false;                               end;
       (*END IF;*)
      end;              (*   EXPONENT;*)
(*----------------------------------------------------------*)
   procedure readbuffer ;
   var i,j : integer;
       CHARA : char;
   begin
      last_char := sfirst;
      line_no := line_no + 1;
      if eof (input) then                                  
         buffer [last_char] := eof_char                   
      else                                                 begin
         (* READ (CHRC); *)          (*ADJUST*)   (*OVERREADS EOL CHAR*)
         write (line_no : 4,':');
         IF FILEINPUT THEN 
           BEGIN
                READ(FILEIN,CHARA);
                WRITE(CHARA);
           END
          ELSE read(CHARA);
          while not eoln(input)  do                       begin
            buffer[last_char] := CHARA;
            { adjusted from read(buffer[last_char]); by EDS }
            last_char := last_char + 1;                   END;
            IF FILEINPUT THEN 
              BEGIN
                   READ(FILEIN,CHARA);
                   WRITE(CHARA);
              END
             ELSE read(CHARA);
         last_char := last_char - 1;
      (* DELETE NUL, DEL*)
         for i := sfirst to last_char do                   begin
            if(buffer[i] = chr(nul))or(buffer[i] = chr(del))then begin
               last_char := last_char - 1;
               for j := i to last_char do
                  buffer[j] := buffer[j+1];
                                                           end;
                                                           end;
         last_char := last_char + 1;
         buffer [last_char] := chr (cr);
         buffer [last_char + 1] := chr (cr);                     end;
    (*END IF;*)
      current := sfirst;
      current_char := buffer [current];
   end; (*   READBUFFER;*)
   procedure case_digit;
   begin
            base := 10;
            sequence (10, sfirst, pos1);
            if(current_char = '#')or(current_char = ':')then begin
     (*  BASED NUMBER, COMPUTE BASE *)
               co_string_to_int (hstr, sfirst, pos1-1, 10, error, base);
               if error or (base < 2) or (base > 16) then begin
                  er_error_message (1508, er_symbol_error, outp_pos,
                                    lu_no_symbol);
                  base := 16;
               end (*IF*);
               sharp_char := current_char;
               (*  MUST BE USED THROUGOUT*)
               new_current_char;
               sequence (base, sfirst, pos2);
          (* BASED REAL NUMBER*)
               if current_char = '.' then                  begin
                  new_current_char;
                  sequence (base, pos2+1, pos3);
                  if current_char <> sharp_char then begin (*ERRONEOUS*)
                     er_error_message (1502, er_symbol_error,
                                       outp_pos, lu_no_symbol);  end
                  else       new_current_char;
                (*END IF;*)
                  exponent (pos3 + 1, exp_last, exp_positive);
                  new_sym (lu_real, lu_real_sym, outp_sym.idcode);
                                                           end
          (* BASED INTEGER NUMBER*)
               else                                        begin
                  if current_char <> sharp_char then begin (*ERRONEOUS*)
                     er_error_message (1502, er_symbol_error,
                                       outp_pos, lu_no_symbol); end
                  else                                  
                     new_current_char;
                (*END IF;*)
                  exponent (pos2 + 1, exp_last, exp_positive);
                  new_sym (lu_int, lu_integer_sym, outp_sym.idcode); end;
                                                              end
             (*END IF;*)
            else if(current_char = '.')and
              (char_type_table [buffer [current + 1]] = digit)then begin
            (*  REAL LITERAL*)
               new_current_char;
               sequence (10, pos1+1, pos2);
               exponent (pos2 + 1, exp_last, exp_positive);
               new_sym (lu_real, lu_real_sym, outp_sym.idcode);  end
         (* INTEGER LITERAL*)
            else                                                   begin
               exponent (pos1, exp_last, exp_positive);
              new_sym (lu_int, lu_integer_sym, outp_sym.idcode);
            end (*IF*);
            (* TEST THAT NO IDENTIFIER OR NUMBER FOLLOWS IMMEDIATELY*)
            current_type := char_type_table [current_char];
            if(current_type = letter_a_f)or(current_type = letter_g_z)or
              (current_type = low_letter)or(current_type = digit)then
                                                                   begin
               error_pos.sourceline := outp_pos.sourceline;
               error_pos.column     := current;
               er_error_message (1505, er_symbol_error,
                                 error_pos, lu_no_symbol  );
            end (*IF*);
   end; (* CASE_DIGIT *)
   procedure case_letter;
   label 77;
   begin
              (* UFLAG := FALSE; NOT NECESSARY BECAUSE LETTER ANALYZED*)
               error := false;
               pos1 := sfirst;
               repeat
                  case char_type_table [current_char] of
                     letter_a_f , letter_g_z , digit :
                        uflag := false;
                     low_letter :                     begin
                        current_char := chr( ord('A') +
                                         ord(current_char) - ord('a'));
                        uflag := false;
                                                           end;
                     underscore :                          begin
                        if uflag then
                           error := true;
                      (*END IF;*)
                        uflag := true;                     end;
                     dquote, quote, hyphen, ampersand,
                     lpar, rpar,asterisk, plus, comma,
                     point, slash, colon, semicolon,
                     langle, equal, rangle, vbar, nwline,
                     ignore, blank, htab, eofc, other_graphics,
                     non_ada :
                        goto 77;
                  end;                         (*   CASE;*)
                  hstr [pos1] := current_char;
                  pos1 := pos1 + 1;
                  new_current_char;
               until false;
77 :           if uflag or error then
                  er_error_message (1504, er_symbol_error,
                                    outp_pos, lu_no_symbol  );
             (*END IF;*)
               i_code := st_get_sub_code (hstr, sfirst, pos1-1, false);
               if last_symbol.sym  <> lu_quote_sym then            
               (*  IDENTIFY RESERVED WORDS*)
                 new_sym (lu_id, lu_reserved_word[i_code], i_code)
               else                          (* ATTRIBUTE NAME*)
                 new_sym (lu_id, lu_identifier_sym, i_code);
             (*END IF;*)
   end; (* CASE_LETTER *)
(*-------------------------------------------------------------------*)
   begin  (* LA_NEXT_SYM -----------------------------------*)
      outp_pos.sourceline := line_no;
11 :
         outp_pos.column := current;
         current_type := char_type_table [current_char];
         case current_type of
     digit :                                                 begin
            case_digit; (* INTEGER OR REAL LITERAL*)
            goto 88;                                               end;
(* IDENTIFIER*)
      letter_a_f , letter_g_z , low_letter :            begin
               case_letter;
               goto 88;                                            end;
(* CHARACTER_LITERAL OR QUOTE*)
            quote :                                                begin
               new_current_char;
               if(buffer [current + 1] <> '''')or(last_symbol.sym =
                  lu_identifier_sym)then                           
                  new_sym (lu_other, lu_quote_sym, outp_sym.idcode)
               else                                                begin
                  current_type := char_type_table [current_char];
                  if(current_type = nwline)or(current_type = ignore)or
                    (current_type = htab)or(current_type = non_ada)then
                                                                   begin
                     error_pos.sourceline := outp_pos.sourceline;
                     error_pos.column     := current;
                     er_error_message (1500, er_symbol_error,
                                       error_pos, lu_no_symbol  );
                                                                   end;
                (*END IF;*)
                 new_sym (lu_id, lu_character_sym, st_nil);
                 current := current + 1;
                 new_current_char;                             end;
             (*END IF;*)
               goto 88;
                                                                   end;
(* CHARACTER STRING*)
           dquote :                                          begin
               string_bracket := current_char;
               pos1 := sfirst;
               repeat
                  new_current_char;
                  current_type := char_type_table [current_char];
                  if current_type = nwline then                    begin
                     er_error_message (1503, er_symbol_error,
                                       outp_pos, lu_no_symbol  );
                     goto 66;                                      end
   else              if(current_type = ignore)or(current_type = htab)or
                    (current_type = non_ada)then                   begin
                     error_pos.sourceline := outp_pos.sourceline;
                     error_pos.column     := current;
                     er_error_message (1500, er_symbol_error,
                                       error_pos, lu_no_symbol  );
                                                                   end
   else              if current_char = string_bracket then         begin
                     new_current_char;
                     if current_char <> string_bracket then goto 66;
                                                                   end
   else              if current_char = '"' then           begin
                  (*  MUST BE %-STRING, " IS NOT ALLOWED*)
                     error_pos.sourceline := outp_pos.sourceline;
                     error_pos.column     := current;
                     er_error_message (1500, er_symbol_error,
                                       error_pos, lu_no_symbol  );
                                                                   end;
                (*END IF;*)
                  hstr [pos1] := current_char;
                  pos1 := pos1 + 1;
               until false;
66 :          new_sym (lu_id, lu_string_sym, st_nil);
               goto 88;
                                                                   end;
(* DOT OR INTERVAL*)
           point :                                   begin
               new_current_char;
               if current_char = '.' then                  begin
                  new_current_char;
                 new_sym (lu_other, lu_interval_sym, outp_sym.idcode); end
               else                                        
                 new_sym (lu_other, lu_dot_sym, outp_sym.idcode);
             (*END IF;*)
               goto 88;
                                                           end;
(* LESS OR LESS_EQUAL OR LEFT_LABEL_BRACKET OR BOX*)
           langle :                                  begin
               new_current_char;
               if current_char = '>' then                  
                 new_sym (lu_other, lu_box_sym, outp_sym.idcode)
   else           if current_char = '=' then               
                 new_sym (lu_id, lu_less_equal_sym, lu_cde_less_equal)
   else           if current_char = '<' then               
                 new_sym (lu_other, lu_left_label_sym, outp_sym.idcode)
               else                                        begin
                 new_sym (lu_id, lu_less_sym, lu_code_less);
                  goto 88;                                 end;
             (*END IF;*)
               new_current_char;
               goto 88;                                    end;
(* LEFT PARENTHESIS*)
           lpar :                                    begin
               new_current_char;
              new_sym (lu_other, lu_lpar_sym, outp_sym.idcode);
              goto 88;                                     end;
(* PLUS*)
            plus :                                    begin
               new_current_char;
              new_sym (lu_id, lu_plus_sym, lu_code_plus);
               goto 88;
                                                           end;
(* SEPARATOR*)
            vbar :                                    begin
               new_current_char;
              new_sym (lu_other, lu_separator_sym, outp_sym.idcode);
               goto 88;
                                                           end;
(* MULTIPLY OR EXPONENTIATION*)
           asterisk :                                begin
               new_current_char;
               if current_char = '*' then                  begin
                  new_current_char;
                new_sym (lu_id, lu_exponentiation_sym, lu_code_exponentiation);
                                                                   end
               else                                         
             (*END IF;*)
                 new_sym (lu_id, lu_multiply_sym, lu_code_multiply);
               goto 88;                                    end;
(* RIGHT PARENTHESIS*)
           rpar :                                    begin
               new_current_char;
              new_sym (lu_other, lu_rpar_sym, outp_sym.idcode);
              goto 88;
                                                           end;
(* MINUS OR COMMENT*)
           hyphen :                                  begin
               new_current_char;
               if current_char = '-' then                  begin
                  repeat
                     new_current_char;
                     current_type := char_type_table [current_char];
                     if current_type = nwline then goto 55;
                     if(current_type = ignore)or(current_type = non_ada)
                        then                               begin
                        error_pos.sourceline := outp_pos.sourceline;
                        error_pos.column     := current;
                        er_error_message (1500, er_symbol_error,
                                          error_pos, lu_no_symbol  );
                                                           end;
                   (*END IF;*)
                  until false;
55 :
                                                           end
               else                                        begin
                 new_sym (lu_id, lu_minus_sym, lu_code_minus);
                 goto 88;                                  end;
             (*END IF;*)
                                                           end;
(* DIVIDE OR NOT_EQUAL*)
           slash :                                   begin
               new_current_char;
               if current_char = '=' then                  begin
                  new_current_char;
                 new_sym (lu_id, lu_not_equal_sym, lu_code_not_equal); end
               else
                 new_sym (lu_id, lu_divide_sym, lu_code_divide);
             (*END IF;*)
               goto 88;
                                                           end;
                                                           
(* COMMA*)
           comma :                                   begin
               new_current_char;
              new_sym (lu_other, lu_comma_sym, outp_sym.idcode);
              goto 88;
                                                           end;
(* GREATER OR GREATER_EQUAL OR RIGHT_LABEL_BRACKET*)
           rangle :                                  begin
               new_current_char;
               if current_char = '=' then                  begin
                  new_current_char;
                new_sym (lu_id, lu_greator_equal_sym, lu_cde_greater_equal);end
   else           if current_char = '>' then               begin
                  new_current_char;
                 new_sym (lu_other, lu_right_label_sym, outp_sym.idcode); end
               else                                        
                 new_sym (lu_id, lu_greater_sym, lu_code_greater);
             (*END IF;*)
               goto 88;
                                                           end;
(* COLON OR ASSIGN*)
            colon :                                   begin
               new_current_char;
               if current_char = '=' then                  begin
                  new_current_char;
                 new_sym (lu_other, lu_assign_sym, outp_sym.idcode); end
               else                                        
                 new_sym (lu_other, lu_colon_sym, outp_sym.idcode);
             (*END IF;*)
              goto 88;
                                                           end;
(* ARROW OR EQUAL *)
            EQUAL :                                   BEGIN
               NEW_CURRENT_CHAR;
               IF CURRENT_CHAR = '>' THEN                   BEGIN
                  NEW_CURRENT_CHAR;
                  NEW_SYM (LU_OTHER, LU_ARROW_SYM, OUTP_SYM.IDCODE); END
               ELSE NEW_SYM (LU_ID, LU_EQUAL_SYM, LU_CODE_EQUAL);
               (* END IF;*)
               GOTO 88;                               END;

(* SEMICOLON *)
            SEMICOLON :                               BEGIN
               NEW_CURRENT_CHAR;
               NEW_SYM (LU_OTHER, LU_SEMICOLON_SYM, OUTP_SYM.IDCODE);
               GOTO 88;                               END;

(* CATENATION *)
            AMPERSAND :                               BEGIN
               NEW_CURRENT_CHAR;
               NEW_SYM(LU_ID, LU_CATENATION_SYM, LU_CODE_CATENATION);
               GOTO 88;                               END;

(* NEWLINE CHARACTER (MUST NOT BE EOL) *)
            NWLINE :                                  BEGIN
               IF CURRENT = LAST_CHAR THEN (* IT IS EOL*)   BEGIN
                  READBUFFER;
                  OUTP_POS.SOURCELINE := LINE_NO             END
               ELSE NEW_CURRENT_CHAR;                   END;
              (* END IF;*)
              
            
(* EOFC*)
           eofc :                                     begin
               if(current <> last_char)
                  and(current <> sfirst)(*DELETE THIS LINE IF NO $-EOF*)
               then                                        begin
                  new_current_char;
                  er_error_message (1500, er_symbol_error,
                                    outp_pos, lu_no_symbol); end
               else                                        begin
                 new_sym (lu_other, lu_eof_sym, outp_sym.idcode);
                 goto 88;                                  end;
             (*END IF;*)
                                                           end;
(* BLANK - SKIP*)
            blank , htab , ignore :                   begin
               new_current_char;
                                                           end;
(* OTHERS ARE NOT ALLOWED HERE*)
            underscore , other_graphics , non_ada : begin
               new_current_char;
               er_error_message (1500, er_symbol_error,
                                 outp_pos, lu_no_symbol  );  end;
         end;     (*   CASE;*)
      goto 11;
88 :
(* THE LEXICAL ELEMENT HAS BEEN RECOGNIZED*)
         last_symbol :=outp_sym;
         last_pos := outp_pos;
   end;          (*  LA_NEXT_SYM;*)
(*-------------------------------------------------------------------*)
(*END LEXICAL_ANALYZER; *)


========================================================================================
DOCUMENT :usus Folder:VOLUK03:luerror.text
========================================================================================


   SEGMENT procedure lu_error_symbol (LEX_UNIT :    LU_LEXICAL_UNIT;
                                 VAR RESULT :  LU_SYM_DESCRIPTOR);
(*-------------------------------------------------------------------*)
(*                                                                  -*)
(*    DESCRIPTION: BUILDS AN DESCRIPTOR FOR ERRORNEOUS CASES        -*)
(*    ------------ (E.G. INSERTION BY PARSER).                      -*)
(*                                                                  -*)
(*-------------------------------------------------------------------*)
 label 1401;
 var
      symbol : lu_sym_descriptor;
      code : st_symbol;
      i : integer;
   begin
      case lex_unit of
              lu_identifier_sym :                          begin
            symbol.discrim := lu_id;
            symbol.sym     :=     lu_identifier_sym;
            symbol.idcode  :=    lub_cde_identifier;
                                                           end;
              lu_integer_sym :                             begin
            symbol.discrim := lu_id;
            symbol.sym     :=     lu_identifier_sym;
            symbol.idcode  := lub_code_integer;
                                                           end;
              lu_real_sym :                                begin
            symbol.discrim := lu_id;
            symbol.sym     :=     lu_identifier_sym;
            symbol.idcode  :=     lub_code_real;
                                                           end;
              lu_character_sym :                           begin
            symbol.discrim := lu_id;
            symbol.sym     :=     lu_identifier_sym;
            symbol.idcode  :=     lub_code_character ;
                                                           end;
              lu_string_sym :                              begin;
            symbol.discrim := lu_id;
            symbol.sym     :=     lu_identifier_sym;
            symbol.idcode  :=   lub_code_string ;
                                                           end;
              lu_eof_sym , lu_dot_sym , lu_interval_sym ,
            lu_left_label_sym , lu_box_sym , lu_lpar_sym ,
            lu_separator_sym , lu_rpar_sym , lu_semicolon_sym ,
            lu_comma_sym , lu_right_label_sym , lu_colon_sym ,
            lu_assign_sym , lu_quote_sym , lu_arrow_sym :    begin
            symbol.discrim := lu_other;
            symbol.sym     := lex_unit;
                                                           end;
              lu_minus_sym :                               begin
            symbol.discrim := lu_id;
            symbol.sym     := lu_minus_sym;
            symbol.idcode  :=     lu_code_minus;
                                                           end;
              lu_less_sym :                                begin
            symbol.discrim := lu_id;
            symbol.sym     :=  lu_less_sym;
            symbol.idcode  :=  lu_code_less ;              end;
              lu_less_equal_sym :                          begin
            symbol.discrim := lu_id;
            symbol.sym     := lu_less_equal_sym;
            symbol.idcode  :=      lu_cde_less_equal ;
                                                           end;
              lu_plus_sym  :                               begin
            symbol.discrim := lu_id;
            symbol.sym     :=  lu_plus_sym;
            symbol.idcode  :=  lu_code_plus;               end;
              lu_catenation_sym :                          begin
            symbol.discrim := lu_id;
            symbol.sym     := lu_catenation_sym;
            symbol.idcode   :=     lu_code_catenation;     end;
              lu_multiply_sym :                            begin
            symbol.discrim := lu_id;
            symbol.sym     :=   lu_multiply_sym;
            symbol.idcode  :=  lu_code_multiply ;          end;
              lu_exponentiation_sym :                      begin
            symbol.discrim := lu_id;
            symbol.sym     :=  lu_exponentiation_sym;
            symbol.idcode  :=  lu_code_exponentiation ;    end;
              lu_divide_sym :                              begin
            symbol.discrim := lu_id;
            symbol.sym     :=     lu_divide_sym;
            symbol.idcode  :=     lu_code_divide ;         end;
              lu_not_equal_sym :                           begin
            symbol.discrim := lu_id;
            symbol.sym     :=  lu_not_equal_sym;
            symbol.idcode  :=  lu_code_not_equal ;         end;
              lu_greater_sym :                             begin
            symbol.discrim := lu_id;
            symbol.sym     :=    lu_greater_sym;
            symbol.idcode  :=   lu_code_greater ;          end;
              lu_greator_equal_sym :                       begin
            symbol.discrim := lu_id;
            symbol.sym     :=   lu_greator_equal_sym;
            symbol.idcode  :=   lu_cde_greater_equal ;    end;
              lu_equal_sym :                               begin
            symbol.discrim := lu_id;
            symbol.sym     := lu_equal_sym;
            symbol.idcode  :=      lu_code_equal ;         end;
       lu_abort_sym , lu_accept_sym, lu_access_sym, lu_all_sym   ,
       lu_and_sym   , lu_array_sym , lu_at_sym    , lu_begin_sym ,
       lu_body_sym  , lu_case_sym  , lu_constant_sym   ,
       lu_declare_sym    , lu_delay_sym , lu_delta_sym , lu_digits_sym,
       lu_do_sym    , lu_else_sym  , lu_elsif_sym , lu_end_sym   ,
       lu_entry_sym , lu_exception_sym  , lu_exit_sym  , lu_for_sym   ,
       lu_function_sym   , lu_generic_sym    , lu_goto_sym  ,
       lu_if_sym    , lu_in_sym    , lu_is_sym    , lu_limited_sym    ,
       lu_loop_sym  , lu_mod_sym   , lu_new_sym   , lu_not_sym   ,
       lu_null_sym  , lu_of_sym    , lu_or_sym    , lu_others_sym,
       lu_out_sym   , lu_package_sym    , lu_pragma_sym,
       lu_private_sym    , lu_procedure_sym  , lu_raise_sym ,
       lu_range_sym , lu_record_sym, lu_rem_sym   , lu_renames_sym    ,
       lu_return_sym, lu_reverse_sym    , lu_salect_sym,
       lu_seperate_sym   , lu_subtype_sym    , lu_task_sym  ,
       lu_terminate_sym  , lu_then_sym  , lu_type_sym  , lu_use_sym   ,
       lu_when_sym  , lu_while_sym , lu_with_sym  , lu_xor_sym   :
                                                           begin
            code := lub_cde_identifier;
            for i := 1  to st_sym_ubound do    begin
(*             LOOP*)
               if lu_reserved_word [i] = lex_unit then  begin
                  code := i;
                  goto 1401;
               end; (*  IF;*)
            end;  (* LOOP;*)
1401 :      symbol.discrim := lu_id;
               symbol.sym := lex_unit;
               symbol.idcode := code ;                     end;
      end; (*  CASE;*)
(*    RETURN SYMBOL;*)
      result := symbol;
   end; (*LU_ERROR_SYMBOL;*)


========================================================================================
DOCUMENT :usus Folder:VOLUK03:luinit.text
========================================================================================


(*-------------------------------------------------------------------*)
   segment procedure lu_init;
(*------------------------------------------------------------------*)
(*                                                                 -*)
(*   DESCRIPTION: CODING OF THE STRINGS IN SYMBOL TABLE            -*)
(*   ------------                                                  -*)
(*                                                                 -*)
(*   SPECIALITIES: MUST BE CALLED BEFORE FIRST CALL OF LA_NEXT_SYM -*)
(*   -------------                                                 -*)
(*------------------------------------------------------------------*)
   var i : integer;
      procedure lu_init_part2;
      begin
         lu_reserved_word [st_get_code ('PRIVATE  ', 7)] := lu_private_sym;
         lu_reserved_word [st_get_code ('PROCEDURE', 9)] := lu_procedure_sym;
         lu_reserved_word [st_get_code ('RAISE    ', 5)] := lu_raise_sym;
         lu_reserved_word [st_get_code ('RANGE    ', 5)] := lu_range_sym;
         lu_reserved_word [st_get_code ('RECORD   ', 6)] := lu_record_sym;
         lu_reserved_word [st_get_code ('REM      ', 3)] := lu_rem_sym;
         lu_reserved_word [st_get_code ('RENAMES  ', 7)] := lu_renames_sym;
         lu_reserved_word [st_get_code ('RETURN   ', 6)] := lu_return_sym;
         lu_reserved_word [st_get_code ('REVERSE  ', 7)] := lu_reverse_sym;
         lu_reserved_word [st_get_code ('SELECT   ', 6)] := lu_salect_sym;
         lu_reserved_word [st_get_code ('SEPARATE ', 8)] := lu_seperate_sym;
         lu_reserved_word [st_get_code ('SUBTYPE  ', 7)] := lu_subtype_sym;
         lu_reserved_word [st_get_code ('TASK     ', 4)] := lu_task_sym;
         lu_reserved_word [st_get_code ('TERMINATE', 9)] := lu_terminate_sym;
         lu_reserved_word [st_get_code ('THEN     ', 4)] := lu_then_sym;
         lu_reserved_word [st_get_code ('TYPE     ', 4)] := lu_type_sym;
         lu_reserved_word [st_get_code ('USE      ', 3)] := lu_use_sym;
         lu_reserved_word [st_get_code ('WHEN     ', 4)] := lu_when_sym;
         lu_reserved_word [st_get_code ('WHILE    ', 5)] := lu_while_sym;
         lu_reserved_word [st_get_code ('WITH     ', 4)] := lu_with_sym;
         lu_reserved_word [st_get_code ('XOR      ', 3)] := lu_xor_sym;
(* SYMBOL TABLE CODES FOR OPERATORS*)
      lu_code_minus          := st_get_char_code ('-');
      lu_code_less           := st_get_char_code ('<');
      lu_cde_less_equal     := st_get_code ( '<=       ', 2);
      lu_code_plus           := st_get_char_code ('+');
      lu_code_catenation     := st_get_char_code ('&');
      lu_code_multiply       := st_get_char_code ('*');
      lu_code_exponentiation := st_get_code ( '**       ', 2);
      lu_code_divide         := st_get_char_code ('/');
      lu_code_not_equal      := st_get_code ( '/=       ', 2);
      lu_code_greater        := st_get_char_code ('>');
      lu_cde_greater_equal  := st_get_code ( '>=       ', 2);
      lu_code_equal          := st_get_char_code ('=');
(* ERROR ITEMS INITIALIZATION*)
      lub_cde_identifier := st_nil;    (* IS "<IDENT>"*)
      lub_code_integer    := st_get_code ( '<INTEGER>',  9);
      lub_code_real       := st_get_code ( '<REAL>   ', 6);
      lub_code_string     := lub_cde_identifier;
        (* IF STRING IS INSERTED THEN ALSO IDENTIFIER MAY BE INSERTED*)
      lub_code_character  := st_get_code ( '<CHAR>   ', 6);
      end; (* LU_INIT_PART2 *)

   begin  (* LU_INIT *)
      lu_no_symbol.discrim := lu_id;
      lu_no_symbol.sym     := lu_identifier_sym;
      lu_no_symbol.idcode  :=   st_nil;
      for i := 0 to st_sym_ubound do lu_reserved_word [i] := lu_identifier_sym;
    (*END LOOP;*)
         lu_reserved_word [st_get_code ('ABORT    ', 5)] := lu_abort_sym;
         lu_reserved_word [st_get_code ('ACCEPT   ', 6)] := lu_accept_sym;
         lu_reserved_word [st_get_code ('ACCESS   ', 6)] := lu_access_sym;
         lu_reserved_word [st_get_code ('ALL      ', 3)] := lu_all_sym;
         lu_reserved_word [st_get_code ('AND      ', 3)] := lu_and_sym;
         lu_reserved_word [st_get_code ('ARRAY    ', 5)] := lu_array_sym;
         lu_reserved_word [st_get_code ('AT       ', 2)] := lu_at_sym;
         lu_reserved_word [st_get_code ('BEGIN    ', 5)] := lu_begin_sym;
         lu_reserved_word [st_get_code ('BODY     ', 4)] := lu_body_sym;
         lu_reserved_word [st_get_code ('CASE     ', 4)] := lu_case_sym;
         lu_reserved_word [st_get_code ('CONSTANT ', 8)] := lu_constant_sym;
         lu_reserved_word [st_get_code ('DECLARE  ', 7)]:= lu_declare_sym;
         lu_reserved_word [st_get_code ('DELAY    ', 5)] := lu_delay_sym;
         lu_reserved_word [st_get_code ('DELTA    ', 5)] := lu_delta_sym;
         lu_reserved_word [st_get_code ('DIGITS   ', 6)] := lu_digits_sym;
         lu_reserved_word [st_get_code ('DO       ', 2)] := lu_do_sym;
         lu_reserved_word [st_get_code ('ELSE     ', 4)] := lu_else_sym;
         lu_reserved_word [st_get_code ('ELSIF    ', 5)] := lu_elsif_sym;
         lu_reserved_word [st_get_code ('END      ', 3)] := lu_end_sym;
         lu_reserved_word [st_get_code ('ENTRY    ', 5)] := lu_entry_sym;
         lu_reserved_word [st_get_code ('EXCEPTION', 9)] := lu_exception_sym;
         lu_reserved_word [st_get_code ('EXIT     ', 4)] := lu_exit_sym;
         lu_reserved_word [st_get_code ('FOR      ', 3)] := lu_for_sym;
         lu_reserved_word [st_get_code ('FUNCTION ', 8)] := lu_function_sym;
         lu_reserved_word [st_get_code ('GENERIC  ', 7)] := lu_generic_sym;
         lu_reserved_word [st_get_code ('GOTO     ', 4)] := lu_goto_sym;
         lu_reserved_word [st_get_code ('IF       ', 2)] := lu_if_sym;
         lu_reserved_word [st_get_code ('IN       ', 2)] := lu_in_sym;
         lu_reserved_word [st_get_code ('IS       ', 2)] := lu_is_sym;
         lu_reserved_word [st_get_code ('LIMITED  ', 7)] := lu_limited_sym;
         lu_reserved_word [st_get_code ('LOOP     ', 4)] := lu_loop_sym;
         lu_reserved_word [st_get_code ('MOD      ', 3)] := lu_mod_sym;
         lu_reserved_word [st_get_code ('NEW      ', 3)] := lu_new_sym;
         lu_reserved_word [st_get_code ('NOT      ', 3)] := lu_not_sym;
         lu_reserved_word [st_get_code ('NULL     ', 4)] := lu_null_sym;
         lu_reserved_word [st_get_code ('OF       ', 2)] := lu_of_sym;
         lu_reserved_word [st_get_code ('OR       ', 2)] := lu_or_sym;
         lu_reserved_word [st_get_code ('OTHERS   ', 6)] := lu_others_sym;
         lu_reserved_word [st_get_code ('OUT      ', 3)] := lu_out_sym;
         lu_reserved_word [st_get_code ('PACKAGE  ', 7)] := lu_package_sym;
         lu_reserved_word [st_get_code ('PRAGMA   ', 6)] := lu_pragma_sym;
            lu_init_part2;
   end; (*  LU_INIT;*)
(*-------------------------------------------------------------------*)


========================================================================================
DOCUMENT :usus Folder:VOLUK03:newadatest.text
========================================================================================

--***************************************************************
--
--                SYNTAX TEST FOR REVISED ADA
--
-- The programs are generated from the LALR(1) grammar used in
-- the Ada Syntax Checker. Every rule is applied at least once.
--
--***************************************************************
procedure ID ;
pragma ID ; procedure ID ; pragma ID (
1 ) ; with ID ; with ID (
1 ) , "**" ( ) ' ID .
"**" . all . ID ( 1 ..
1 , ID ( ID digits 1 ) (
1 => ID digits 1 , 1
and 1 ) range + 1 * 1 +
1 ** 1 / 4.5 ** 'A'
.. - null - ( 1 , 1 ) mod ID (
1 or 1 ) ( 1 xor
1 , 1 and then 1 ) ** new
ID ( 1 or else 1 ) (
1 = 1 , 1 in 1
.. 1 ) ! ID ( 1 in ID ) (
ID ' ( 1 ) , ( 1 ) ) range not (
1 => 1 ) & ( 1 ,
1 , 1 ) rem ( 1 =>
1 , 1 ) ** ( 1 /=
1 , 1 ) .. ( 1 <
1 , 1 ) + ( 1 <=
1 , 1 ) * ( 1 >
1 , 1 ) ** ( 1 >=
1 , 1 ) => ( 1 not in
1 .. 1 , 1 ) + (
1 in ID digits 1 , 1
) * ( 1 in ID ( ID range 1
.. 1 ) , 1 ) ** ( 1 in
ID ( ID delta 1 ) , 1 ) =
( 1 in ID ( ID digits 1
range 1 .. 1 ) , 1 ) + (
1 in ID ( others => 1 ) ,
1 ) * ( 1 in ID ( 1
.. 1 => 1 ) , 1 ) ** (
1 and 1 and 1 ,
1 ) ) ; use ID ( ID ' ( 1
, 1 ) ) ( 1 or 1 or
1 , ID ( 1 xor 1 xor
1 ) range ( 1 and then 1 and
then 1 , 1 ) + ( 1 or else
1 or else 1 , 1 ) *
1 .. 1 => 1 ) ; procedure
ID is ID : ID ; for ID use
1 ; procedure ID ( ID : ID ) is
begin null ; end ; generic package ID is ID : constant
ID ; use ID ; ID : constant array ( ID
range <> ) of ID := 1 ; end ; begin accept
ID ; << ID >> if 1 then pragma
ID ; ID := 1 ; elsif 1
then exit ; return ; end if ; exception when ID => return
1 ; goto ID ; end ID ;
pragma ID ( 1 , 1 ) ; procedure
ID ;
pragma ID ( ID => 1 ) ; procedure
ID ;
package ID is end ;
package body ID is end ;
separate ( ID ) package body ID is end ;
generic procedure ID ;
procedure ID is new ID ;
function ID is new ID ;
function ID return ID ;
procedure ID ( ID : ID ) ;
procedure ID ( ID : ID ; ID :
ID ) ;
procedure ID ( ID , ID : ID ) ;
procedure ID ( ID : in ID ) ;
procedure ID ( ID : out ID ) ;
procedure ID ( ID : in out ID ) ;
procedure ID ( ID , ID , ID :
ID ) ;
function "**" return ID ;
generic ID : ID ; procedure ID ;
generic type ID is private ; procedure ID ;
generic with procedure ID ; procedure ID ;
generic with procedure ID is ID ; procedure ID
;
generic with procedure ID is <> ; procedure ID ;
generic type ID ( ID : ID ) is private ;
procedure ID ;
generic type ID ( ID : ID ; ID :
ID ) is private ; procedure ID ;
generic type ID ( ID , ID : ID ) is
private ; procedure ID ;
generic type ID is ( <> ) ; procedure ID ;
generic type ID is range <> ; procedure ID ;
generic type ID is delta <> ; procedure ID ;
generic type ID is digits <> ; procedure ID ;
generic type ID is array ( ID ) of ID ;
procedure ID ;
generic type ID is access ID ; procedure ID ;
generic type ID is array ( ID range <> , ID
range <> ) of ID ; procedure ID ;
generic type ID is array ( ID , ID ) of
ID ; procedure ID ;
generic type ID is array ( 1 .. 1
) of ID ; procedure ID ;
generic type ID is limited private ; procedure ID ;
generic with function ID return ID is ID ;
procedure ID ;
procedure ID is for ID use 1 ; begin
null ; end ;
procedure ID is procedure ID is separate ; begin null
; end ;
procedure ID is ID , ID : constant ID
; begin null ; end ;
procedure ID is ID , ID : constant array (
ID ) of ID ; begin null ; end ;
procedure ID is ID : constant := 1 ;
begin null ; end ;
procedure ID is ID , ID : constant :=
1 ; begin null ; end ;
procedure ID is type ID is private ; begin null ; end
;
procedure ID is type ID ; begin null ; end ;
procedure ID is subtype ID is ID ; begin null
; end ;
procedure ID is procedure ID ; begin null ; end ;
procedure ID is package ID is end ; begin null ; end ;
procedure ID is task ID ; begin null ; end ;
procedure ID is ID : exception ; begin null ; end ;
procedure ID is ID , ID : exception ; begin
null ; end ;
procedure ID is ID : ID renames ID ;
begin null ; end ;
procedure ID is ID : exception renames ID ;
begin null ; end ;
procedure ID is package ID renames ID ; begin
null ; end ;
procedure ID is task ID renames ID ; begin
null ; end ;
procedure ID is procedure ID renames ID ;
begin null ; end ;
procedure ID is pragma ID ; begin null ; end ;
procedure ID is ID : array ( ID ) of
ID ; begin null ; end ;
procedure ID is ID , ID : array ( ID )
of ID ; begin null ; end ;
procedure ID is type ID is ( ID ) ; begin null
; end ;
procedure ID is type ID is range 1 ..
1 ; begin null ; end ;
procedure ID is type ID is digits 1 ;
begin null ; end ;
procedure ID is type ID is array ( ID ) of
ID ; begin null ; end ;
procedure ID is type ID is record end record ; begin
null ; end ;
procedure ID is type ID is access ID ; begin
null ; end ;
procedure ID is type ID is new ID ; begin null
; end ;
procedure ID is type ID is ( ID , ID )
; begin null ; end ;
procedure ID is type ID is ( 'A' ) ;
begin null ; end ;
procedure ID is type ID is record null ; end record ;
begin null ; end ;
procedure ID is type ID is record ID :
ID ; end record ; begin null ; end ;
procedure ID is type ID is record case ID is
end case ; end record ; begin null ; end ;
procedure ID is type ID is record case ID is
when 1 => end case ; end record ; begin null ; end ;
procedure ID is package ID is new ID ; begin
null ; end ;
procedure ID is package ID is private end ; begin null
; end ;
procedure ID is package ID is private for ID
use 1 ; end ; begin null ; end ;
procedure ID is package ID is private for ID
use record end record ; end ; begin null ; end ;
procedure ID is package ID is private for ID
use at 1 ; end ; begin null ; end ;
procedure ID is package ID is private for ID
use record at mod 1 ; end record ; end ; begin null ;
end ;
procedure ID is package ID is private for ID
use record ID at 1 range 1 ..
1 ; end record ; end ; begin null ; end ;
procedure ID is package ID is private for ID
use 1 ; pragma ID ; end ; begin null ; end ;
procedure ID is package ID is private for ID
use 1 ; for ID use 1 ; end ; begin
null ; end ;
procedure ID is package ID is end ID ; begin
null ; end ;
procedure ID is task type ID ; begin null ; end ;
procedure ID is task ID is end ; begin null ; end ;
procedure ID is task ID is entry ID ; end ;
begin null ; end ;
procedure ID is task ID is entry ID (
ID ) ; end ; begin null ; end ;
procedure ID is for ID use 1 ; task
ID ; begin null ; end ;
procedure ID is for ID use 1 ; procedure
ID is separate ; begin null ; end ;
procedure ID is for ID use 1 ; task body
ID is begin null ; end ; begin null ; end ;
procedure ID is for ID use 1 ; package
body ID is begin null ; end ; begin null ; end ;
procedure ID is for ID use 1 ; package
body ID is begin ID ; end ; begin null ; end ;
procedure ID is for ID use 1 ; package
body ID is begin delay 1 ; end ; begin null ;
end ;
procedure ID is for ID use 1 ; package
body ID is begin abort ID ; end ; begin null ; end ;
procedure ID is for ID use 1 ; package
body ID is begin raise ; end ; begin null ; end ;
procedure ID is for ID use 1 ; package
body ID is begin ID ' ( 1 ) ; end ;
begin null ; end ;
procedure ID is for ID use 1 ; package
body ID is begin exit ID ; end ; begin null ; end ;
procedure ID is for ID use 1 ; package
body ID is begin exit when 1 ; end ; begin null
; end ;
procedure ID is for ID use 1 ; package
body ID is begin case 1 is end case ; end ;
begin null ; end ;
procedure ID is for ID use 1 ; package
body ID is begin loop null ; end loop ; end ; begin null ; end
;
procedure ID is for ID use 1 ; package
body ID is begin ID : loop null ; end loop ID
; end ; begin null ; end ;
procedure ID is for ID use 1 ; package
body ID is begin begin null ; end ; end ; begin null ; end ;
procedure ID is for ID use 1 ; package
body ID is begin ID : begin null ; end ID ;
end ; begin null ; end ;
procedure ID is for ID use 1 ; package
body ID is begin select terminate ; end select ; end ; begin
null ; end ;
procedure ID is for ID use 1 ; package
body ID is begin select ID ; else null ; end select ;
end ; begin null ; end ;
procedure ID is for ID use 1 ; package
body ID is begin select ID ; or delay 1
; end select ; end ; begin null ; end ;
procedure ID is for ID use 1 ; package
body ID is begin if 1 then null ; else null ;
end if ; end ; begin null ; end ;
procedure ID is for ID use 1 ; package
body ID is begin case 1 is when 1
=> null ; end case ; end ; begin null ; end ;
procedure ID is for ID use 1 ; package
body ID is begin for ID in ID loop null ; end
loop ; end ; begin null ; end ;
procedure ID is for ID use 1 ; package
body ID is begin for ID in reverse ID loop
null ; end loop ; end ; begin null ; end ;
procedure ID is for ID use 1 ; package
body ID is begin while 1 loop null ; end loop ;
end ; begin null ; end ;
procedure ID is for ID use 1 ; package
body ID is begin declare begin null ; end ; end ; begin null ;
end ;
procedure ID is for ID use 1 ; package
body ID is begin begin null ; exception when ID !
ID => null ; end ; end ; begin null ; end ;
procedure ID is for ID use 1 ; package
body ID is begin begin null ; exception when others => null ;
end ; end ; begin null ; end ;
procedure ID is for ID use 1 ; package
body ID is begin accept ID do null ; end ; end ; begin
null ; end ;
procedure ID is for ID use 1 ; package
body ID is begin accept "**" ; end ; begin null ;
end ;
procedure ID is for ID use 1 ; package
body ID is begin accept ID . ID ; end ; begin
null ; end ;
procedure ID is for ID use 1 ; package
body ID is begin accept ID . "**" ; end ;
begin null ; end ;
procedure ID is for ID use 1 ; package
body ID is begin accept ID ( 1 ) ; end ;
begin null ; end ;
procedure ID is for ID use 1 ; package
body ID is begin select when 1 => terminate ;
end select ; end ; begin null ; end ;
procedure ID is for ID use 1 ; package
body ID is begin select accept ID ; end select ; end ;
begin null ; end ;
procedure ID is for ID use 1 ; package
body ID is begin select delay 1 ; end select ;
end ; begin null ; end ;
procedure ID is for ID use 1 ; package
body ID is begin select accept ID ; null ; end select
; end ; begin null ; end ;
procedure ID is for ID use 1 ; package
body ID is begin select terminate ; or terminate ; end select
; end ; begin null ; end ;
procedure ID is for ID use 1 ; package
body ID is separate ; begin null ; end ;
========================================================================================
DOCUMENT :usus Folder:VOLUK03:parser.text
========================================================================================


(**********************************************************************)
segment procedure parser;
label  1;    (*  PARSER EXIT  *)
const
     stackend     = 100 ;
     startstate   =   1 ;
(**********************************************************************)
(*                GENERATED PARSER CONSTANTS                       *)
(**********************************************************************)
     zemaxbit2         =   63;   (*ADJUST*)  (*MAX SET ELEMENT*)
     zemax2bits        =   64;   (*ADJUST*)  (*MAX SET SIZE*)
     zemaxterminalcode =   93;
     zemaxrslaenge     =   11;
     zemaxprodnrliste  =  180;
     zeanzzst          =  487;
     zemaxfez          =  153;
     zemaxfes          =   77;
     zemaxteintrag     =  196;
     zeanzotzst        =   38;
     zeanzots          =   37;
     zemaxnteintrag    =   62;
     zeanzonzst        =   82;
     zeanzons          =   19;
     zeanznt           =  124;
     zeanzprod         =  345;
     zemaxztv          =  223;
     zemaxznv          =   82;
     zemaxtv           =   37;
     zemaxnv           =   19;
     zetindex          =    1;(*ADJUST*)(*ZEMAXTERMINALCODE/ZEMAXBITS2*)
     zezuindex         =    7;(*ADJUST*) (*ZEANZZST / ZEMAXBITS2*)
     zefindex          =    1;(*ADJUST*) (*ZEMAXFES / ZEMAXBITS2*)
     zezplusn          =    7;
     zezplust          =    5;
     zestopsymbol      =    5;
type
(**********************************************************************)
(*                     PARSER   TYPES                                 *)
(**********************************************************************)
     state         = 1..zeanzzst;
     production    = 1..zeanzprod;
     terminalsymbol= 0..zemaxterminalcode;
     errorsymbol   = 0..zemaxfes;
     errorstate  = 1..zemaxfez;
     nonterminal   = 1..zeanznt;
     prodnrliste   = 0..zemaxprodnrliste; (* 0 == ERROR EXIT *)
     termin_set   = array[0..zetindex] of set of 0..zemaxbit2;
     errorset      = array[0..zefindex] of set of 0..zemaxbit2;
     statesset     = array[0..zezuindex] of set of 0..zemaxbit2;
     ttabtyp       = array[1..zeanzotzst,1..zeanzots] of 0..zemaxteintrag;
     ntabtyp       = array[1..zeanzonzst,1..zeanzons] of 0..zemaxnteintrag;
     ztvtyp        = array[state] of 1..zemaxztv;
     znvtyp        = array[state] of 1..zemaxznv;
     termtermtyp   = array[terminalsymbol] of 0..zemaxtv;
     ntnttyp       = array[nonterminal] of 1..zemaxnv;
     termzutyp     = array[terminalsymbol] of 0..zeanzzst;
     ntzutyp       = array[nonterminal] of 0..zeanzzst;
     termprotyp    = array[terminalsymbol] of 0..zeanzprod;
     ntprotyp      = array[nonterminal] of 0..zeanzprod;
     zupltyp       = array[state] of prodnrliste;
     plprotyp      = array[prodnrliste] of production;
     pronttyp      = array[production] of nonterminal;
     errortyp      = array[errorstate] of errorset;
     prorsltyp     = array[production] of 0..zemaxrslaenge;
     zutermtyp     = array[state] of terminalsymbol;
     zuzplusttyp   = array[state] of 1..zezplust;
     termzplusttyp = array[terminalsymbol] of 1..zezplust;
     zuzplusntyp   = array[state] of 1..zezplusn;
     ntzplusntyp   = array[nonterminal] of 1..zezplusn;
     stackpointer     = 0..stackend;
     parserstack = array [ stackpointer ] of state ;
                         (* PARSERSTACK [ 0 ] = 'dummy' *)
     parseraction = (handleerror,read,reduce,
                     readreduce);
     table_entry = record
                          case action : parseraction of
                            (* HANDLEERROR: *)
                            read:( nextstate : state );
                            reduce,readreduce:
                              ( product_snr : production )
                       end;
     token_type =
        record
           syntaxcode : terminalsymbol;
           pos        : so_position;
           symbol     : lu_sym_descriptor
        end;
(**********************************************************************)
(*             STATE VARIABLES OF THE PARSER                         *)
(**********************************************************************)
var
    stack    : parserstack;
    pointer  : stackpointer;
    entry    : table_entry;
    token    : token_type;
(**********************************************************************)
(*             PARSER TABLES   AND  CONSTANTS                       *)
(**********************************************************************)
    error  : errortyp;
    ztv    : ztvtyp;
    tv     : termtermtyp;
    ttab   : ttabtyp;
    znrtv  : termzutyp;
    pnrtv  : termprotyp;
    ptl    : plprotyp;
    ptla   : zupltyp;
    ft     : zuzplusttyp;
    gt     : termzplusttyp;
    fez    : array[state] of 0..zemaxfez;
    fes    : array[terminalsymbol] of 0..zemaxfes;
    ls         : pronttyp;
    lengthrs   : prorsltyp;
    ntab       : ntabtyp;
    znv        : znvtyp;
    nv         : ntnttyp;
    znrnv      : ntzutyp;
    pnrnv      : ntprotyp;
    fn         : zuzplusntyp;
    gn         : ntzplusntyp;
    fsymbol,
    rsymbol    : zutermtyp;
    semklammer,
    overread   : termin_set;
    emptystateset     : statesset;
(**********************************************************************)
(**********************************************************************)
function is_stopentry (e : table_entry) : boolean;
begin
   is_stopentry := false;
   if e.action = read then
      if e.nextstate = startstate then
         is_stopentry := true;
end;
(**********************************************************************)
function inset(m : termin_set;
                 i : terminalsymbol ): boolean;
begin
  inset:=(i mod zemax2bits) in m[i div zemax2bits];
end; (* VON INSET *)
(**********************************************************************)
function infeset(m : errorset; i : errorsymbol): boolean;
begin
  infeset:=(i mod zemax2bits) in m[i div zemax2bits];
end; (* INFESET *)
(**********************************************************************)
function instateset( m : statesset ; i : state ) : boolean;
begin
  instateset:=(i mod zemax2bits) in m[i div zemax2bits];
end; (* INSTATESET *)
(**********************************************************************)
procedure tostateset( var m : statesset ; i : state );
begin
    m [ i div zemax2bits ] := m [ i div zemax2bits ] +
                                [ i mod zemax2bits ] ;
end; (* TOSTATESET *)
(**********************************************************************)
PROCEDURE TTABLE(   Z:STATE;
                    S:TERMINALSYMBOL;
                VAR E:TABLE_ENTRY);
(* TTABLE DETERMINES THE ACTION, WHICH IS EXECUTED NEXT *)
(* IF THE CURRENT SYMBOL IS A TERMINAL                  *)
VAR
    TET:INTEGER;
BEGIN
  WITH E DO
  IF INFESET(ERROR[FEZ[Z]],FES[S]) THEN
    ACTION:=HANDLEERROR
  ELSE
  BEGIN
    IF FT[Z]<GT[S] THEN TET:=ZTV[Z]
    ELSE
    IF FT[Z]>GT[S] THEN TET:=TV[S]
    ELSE 
       TET:=TTAB[ZTV[Z],TV[S]];
    CASE TET MOD 3 OF
      0: BEGIN
          ACTION:=READ;
          NEXTSTATE:=ZNRTV[S] + (TET DIV 3);
         END;
      1: BEGIN
          ACTION:=READREDUCE;
          PRODUCT_SNR:=PNRTV[S] + (TET DIV 3);
         END;
      2: BEGIN
          ACTION:=REDUCE;
          PRODUCT_SNR:=PTL[PTLA[Z] + (TET DIV 3)];
         END;
    END;
   END;
END; (* TTABLE *)
(*********************************************************************)
PROCEDURE NTABLE( Z:STATE;
                  S:NONTERMINAL;
              VAR E:TABLE_ENTRY);
(* NTABLE DETERMINES THE ACTION WHICH IS EXECUTED NEXT *)
(* IF THE CURRENT SYMBOL IS A NONTERMINAL              *)
VAR
   TET:INTEGER;
BEGIN
  with e do
  begin
    if fn[z]<gn[s] then tet:=znv[z]
    else
    if fn[z]>gn[s] then tet:=nv[s]
    else
       tet:=ntab[znv[z],nv[s]];
    case tet mod 2 of
      0: begin
           action:=read;
           nextstate:=znrnv[s] + (tet div 2);
         end;
      1: begin
           action:=readreduce;
           product_snr:=pnrnv[s] + (tet div 2);
         end;
    end;
  end;
end;  (* NTABLE *)
(**********************************************************************)
(*  INITIALIZATION  OF THE PARSER TABLES AND CONSTANTS *)
(**********************************************************************)
procedure parserinitialization;
var
    z   : 0 .. zezuindex;
(**********************************************************************)
(*  PARSERINITIALIZATION . PARSERREAD *)
(**********************************************************************)
procedure parserread(*TABDAT*);
(**********************************************************************)
(*      FILES :                                                       *)
(*          TABDAT      : FILE OF INTEGER; (INPUT)                    *)
(*             CONTAINS THE PARSER TABLES                             *)
(**********************************************************************)
var
    i,j           : integer;
    emptyterset   : termin_set;
    emptyerrorset : errorset;
(**********************************************************************)
procedure zertest(i : integer);
begin
  if tabdat^ <> i then begin
    er_error_message (5097, er_compiler_error, token.pos,
                      lu_no_symbol);
    exit(parser);   (*******  PARSER  STOP  *******)
  end;
  get(tabdat);
end; (* ZERTEST *)
(**********************************************************************)
procedure zuterset(var t : termin_set; i : terminalsymbol);
var
    j : 0..zetindex;
begin
  j:=i div zemax2bits;
  t[j]:=t[j]+[i mod zemax2bits];
end;  (* ZUTERSET *)
(**********************************************************************)
procedure zufeset(var f : errorset; i : errorsymbol);
var
    j : 0..zefindex;
begin
  j:=i div zemax2bits;
  f[j]:=f[j]+[i mod zemax2bits];
end; (* ZUFESET *)
(**********************************************************************)
procedure parser_2_read;
begin
    zertest( -13);
    for i := 0 to zemaxterminalcode do begin
       tv[i] := tabdat^;    get(tabdat);
       znrtv[i] := tabdat^; get(tabdat);
       pnrtv[i] := tabdat^; get(tabdat);
       gt[i] := tabdat^;    get(tabdat);    
    end;
    zertest(-14);
    for i:=1 to zeanzotzst do
       for j:=1 to zeanzots do begin
          ttab[i,j] := tabdat^; get(tabdat); 
       end;
    zertest( -15);
    reset(tabdat);
end; (* PARSER_2_READ *)

begin  (* PARSERREAD *)
   writeln('Initialising Parser Tables...Takes about 10 minutes');
   for i:=0 to zetindex do emptyterset[i]:=[];
    for i:=0 to zefindex do emptyerrorset[i] := [];
    semklammer:=emptyterset;
    overread:=emptyterset;
    for i := 0 to 4 do zuterset( overread, i);
    zuterset( semklammer,  5);
    zuterset( semklammer,  13);
    zuterset( semklammer,  17);
    zuterset( semklammer,  24);
    zuterset( semklammer,  29);
    zuterset( semklammer,  30);
    zuterset( semklammer,  45);
    zuterset( semklammer,  48);
    zuterset( semklammer,  59);
    reset(tabdat, '#5:tabdat.t' );
    for i:=1 to zeanzzst do begin
       fsymbol[i] := tabdat^; get(tabdat);
       rsymbol[i] := tabdat^; get(tabdat); 
    end;
    zertest( -1 );
    for i:=1 to zeanzonzst do
       for j:=1 to zeanzons do begin
          ntab[i,j] := tabdat^; get(tabdat); 
       end;
    zertest( -2 );
    for i:=1 to zeanzzst do begin
       znv[i] := tabdat^; get(tabdat);
       fn[i] := tabdat^; get(tabdat);  
    end;
    zertest( -3 );
    for i:=1 to zeanznt do begin
       nv[i] := tabdat^;    get(tabdat);
       znrnv[i] := tabdat^; get(tabdat);
       pnrnv[i] := tabdat^; get(tabdat);
       gn[i] := tabdat^;    get(tabdat);    
    end;
    zertest( -4 );
    for i:=1 to zeanzzst do begin
       fez[i] := tabdat^; get(tabdat); 
    end;
    zertest( -5 );
    for i:=0 to zemaxterminalcode do begin
        fes[i] := tabdat^; get(tabdat); 
    end;
    zertest( -6 );
    for i:=1 to zemaxfez do begin
       error[i] := emptyerrorset;
       while tabdat^ <> -8 do begin 
          zufeset(error[i], tabdat^); get(tabdat);
       end;
       get(tabdat);
    end;
    zertest( -9 );
    for i:=1 to zeanzzst do begin
        ptla[i] := tabdat^; get(tabdat); 
    end;
    zertest( -10);
    for i:=0 to zemaxprodnrliste do begin
        ptl[i] := tabdat^; get(tabdat); 
    end;
    zertest( -11);
    for i:=1 to zeanzprod do begin
       ls[i] := tabdat^; get(tabdat);
       lengthrs[i] := tabdat^; get(tabdat); 
    end;
    zertest( -12);
    for i:=1 to zeanzzst do begin
       ztv[i] := tabdat^; get(tabdat);
       ft[i] := tabdat^ ; get(tabdat); 
    end;
    parser_2_read;
end;
begin (* PARSERINITIALIZATION *)
    if not morefiles then parserread;
    for z := 0 to zezuindex do emptystateset [ z ] := [ ];
end (* PARSERINITIALIZATION *) ;
(**********************************************************************)
(*                    SYNTAX ERROR RECOVERY                           *)
(**********************************************************************)
procedure errorhandling ( var stack      : parserstack;
                          var pointer    : stackpointer;
                          var token      : token_type;
                          var entry      : table_entry);
(**********************************************************************)
(*  ERRORHANDLING . SEARCHRESTART                              *)
(**********************************************************************)
procedure searchrestart ;
    var starkestates , schwachestates : statesset ;
        gefunden : boolean ;
        zz       : 0 .. zeanzzst;
        e        : table_entry;
        schwach  : boolean;
(**********************************************************************)
(*  ERRORHANDLING . SEARCHRESTART . REACHABLESTATES  *)
(**********************************************************************)
procedure reachablestates;
    var kel : parserstack;
        peg : stackpointer;
        e   : table_entry;
        t   : terminalsymbol;
        starkephase : boolean ;
begin (* REACHABLESTATES *)
    schwachestates := emptystateset;
    starkestates   := emptystateset ;
    starkephase := true ;
    kel := stack ;
    peg := pointer - 1;
    e . nextstate := stack [ pointer ] ;
    repeat
        if peg = stackend
        then
        begin
          er_error_message (5099, er_comp_restriction,
                            token.pos, lu_no_symbol);
         (*************************)
          exit(parser);  (* PARSER STOP*)
         (*************************)
        end;
        peg := peg + 1; kel [ peg ] := e . nextstate ;
        if instateset ( schwachestates , e . nextstate )
        then t := fsymbol [ e . nextstate ]
        else t := rsymbol [ e . nextstate ] ;
        tostateset ( schwachestates , e . nextstate );
        if starkephase
        then tostateset ( starkestates , e . nextstate );
        ttable ( e . nextstate , t , e );
        if e . action = reduce then
        begin peg := peg - 1; e . action := readreduce end
        else if inset ( semklammer , t ) then starkephase := false;
        while e . action = readreduce do
        begin peg := peg - lengthrs [ e . product_snr ] + 1 ;
              ntable ( kel [ peg ] , ls [ e . product_snr ] , e );
        end;
    until is_stopentry(e);
end (* REACHABLESTATES *) ;
begin (* SEARCHRESTART *) ;
    reachablestates;
    gefunden := false;
    repeat
        if token . syntaxcode = zestopsymbol
        then gefunden := true else
        if not inset ( overread , token . syntaxcode ) then
        begin
            schwach := inset ( semklammer , token . syntaxcode );
            zz := 0;
            repeat
                zz := zz + 1;
                if schwach
                then gefunden := instateset ( schwachestates , zz )
                else gefunden := instateset ( starkestates , zz );
                if gefunden then
                begin
                    ttable ( zz , token . syntaxcode , e );
                    if not ( e . action in [ read , readreduce ] )
                    then gefunden := false;
                end;
            until gefunden or ( zz = zeanzzst );
        end;
        if not gefunden then begin
            la_next_sym (token.symbol, token.pos);
            token.syntaxcode := ord (token.symbol.sym);
        end;
    until gefunden;
   er_error_message (5001, er_reset_position, token . pos, lu_no_symbol);
end (* SEARCHRESTART *) ;
(**********************************************************************)
(*  ERRORHANDLING . REACHRESTART                           *)
(**********************************************************************)
procedure reachrestart;
    var aktivestates : statesset;
        t               : terminalsymbol;
        e               : table_entry;
        fdeskr          : token_type;
        eingefuegt      : boolean;
        peg             : stackpointer;
        l               : lu_lexical_unit;
begin (* REACHRESTART *)
    aktivestates := emptystateset;
    e . nextstate := stack [ pointer ];
    pointer := pointer - 1;
    repeat
        if pointer = stackend
        then
        begin
          er_error_message (5099, er_comp_restriction,
                            token.pos, lu_no_symbol);
         (************************)
          exit(parser);  (* PARSER STOP *)
         (*************************)
        end;
        pointer := pointer + 1; stack [ pointer ] := e . nextstate;
        ttable ( e . nextstate , token . syntaxcode , entry );
        if not ( entry . action in [ read , readreduce ] ) then
        begin
            if instateset ( aktivestates , e . nextstate )
            then t := fsymbol [ e . nextstate ]
            else t := rsymbol [ e . nextstate ];
            tostateset ( aktivestates , e . nextstate );
            ttable ( e . nextstate , t , e );
            if e . action = reduce then
            begin pointer := pointer - 1; e . action := readreduce end
            else
            begin
              fdeskr.pos := token.pos;
              fdeskr.syntaxcode := t;
              l := lu_identifier_sym;
              while ord (l) <> t do begin
                  l := succ (l);
              end;
              lu_error_symbol (l, fdeskr.symbol);
              er_error_message (5002, er_sym_inserted,
                                fdeskr.pos, fdeskr.symbol);
            end;
            while e . action = readreduce do
            begin
                pointer := pointer - lengthrs [ e . product_snr ] + 1;
                ntable(stack[ pointer ], ls[ e . product_snr ], e);
            end;
        end;
    until ( entry . action in [ read , readreduce ] ) or
            is_stopentry(e);
    if is_stopentry(e) then
    begin
        entry := e;
    end;
end (* REACHRESTART *);
(**********************************************************************)
(*                 START ERRORHANDLING                        *)
(**********************************************************************)
begin (* ERRORHANDLING *)
    er_error_message (5000, er_syntax_error, token.pos,lu_no_symbol);
    searchrestart;
    reachrestart;
end (* ERRORHANDLING *) ;
(**********************************************************************)
(*                    START PARSER                            *)
(**********************************************************************)
begin (* PARSER *)
    pointer := 0;
    entry . nextstate := startstate;
    parserinitialization;
    la_next_sym (token.symbol, token.pos);
    token.syntaxcode := ord (token.symbol.sym);
    repeat
        if pointer = stackend then begin
          er_error_message (5099, er_comp_restriction,
                              token.pos, lu_no_symbol);
         (************************)
          goto 1;  (* PARSER STOP*)
         (*************************)
        end;
        pointer := pointer + 1;
        stack [ pointer ] := entry . nextstate;
        ttable ( entry . nextstate , token . syntaxcode , entry );
        if entry . action = handleerror
        then errorhandling ( stack , pointer , token , entry  );
        if entry . action = reduce then
        begin pointer := pointer - 1; entry . action := readreduce end
        else begin
           la_next_sym (token.symbol, token.pos);
           token.syntaxcode := ord (token.symbol.sym);
        end;
        while entry . action = readreduce do
        begin
            pointer := pointer - lengthrs [ entry . product_snr ] + 1;
            ntable( stack[ pointer ], ls[ entry . product_snr ],
                      entry );
        end;
    until is_stopentry(entry);
(**************************************)
  1:   (* PARSER STOP*)
(***************************************)
end (* PARSER *) ;
(**********************************************************************)


========================================================================================
DOCUMENT :usus Folder:VOLUK03:stget.text
========================================================================================


(*-------------------------------------------------------------------*)
   function  st_get_sub_code; (* (STR    :  STRING;
                                  FIRSTC,
                                  LASTC  :  INTEGER;
                                  ENTER  :  BOOLEAN) : ST_SYMBOL; *)
 
(*-------------------------------------------------------------------*)
(*                                                                  -*)
(*    DESCRIPTION: THE STRING IN STR   (FIRSTC..LASTC) IS SEARCHED. -*)
(*    ------------ IF IT IS ALREADY IN THE TABLE THE CODE IS        -*)
(*    RETURNED. OTHERWISE IF ENTER IT IS STORED IN THE TEXTTABLE AND-*)
(*    IN THE HASHTABLE. THE HASHTABLE INDEX IS THE ST_SYMBOL.       -*)
(*    HASH FUNCTION IS THE SUM OF THE FIRST 8 CHARACTER.            -*)
(*    REHASHING IS DONE BY ADD-THE-HASH-REHASH (SEE [GRIES]).       -*)
(*                                       44hhPP                     -*)
(*-------------------------------------------------------------------*)
 label 1410;
 var
      this : stb_s_tab_rec;
      last_char, length, hash : integer;
      epos, ind : st_symbol;
      flag : boolean;
      loop_i, loop_j : integer;
      function  hashval : integer ;
      (* THE HASH FUNCTION IS THE SUM OF THE FIRST 8 CHAR*)
      var   loop_i, sum, e : integer;
      begin
         sum := 0;
         if last_char >= firstc + 8 then
            e := firstc + 7
         else
            e := last_char;
       (*END IF;*)
         for loop_i := firstc to e do
            sum := sum + ord (str [loop_i]);
       (*END LOOP;*)
         sum := sum mod st_sym_ubound;
         if sum = 0 then
            sum := 12;
       (*END IF;*)
         hashval := sum;
      end;          (*   HASHVAL;*)
   begin  (*----------------- ST_GET_SUB_CODE ---------------------- *)
      if lastc < firstc-1 then   (* ADJUST LASTC FOR ALL EMPTY STRINGS*)
         last_char := firstc - 1
      else
         last_char := lastc;
    (*END IF;*)
      hash := hashval;
      epos := hash;
      length := last_char - firstc + 1;
      for loop_i := 1 to st_sym_ubound do               begin
       (*NUMBER OF REHASH POSSIBILITIES*)
         ind := 1 + epos;
         this := stb_s_tab_entries [ind];
         if this.textb = stb_empty then     begin
            if enter then                                  begin
               if stb_str_ubound < stb_number_char + length then
       begin
                  if not stb_texttable_full then (* ALREADY MESSAGED?*)
                                                           begin
                     er_error_message (1401, er_comp_restriction,
                                       so_nil_position, lu_no_symbol  );
                     stb_texttable_full := true;           end;
                (*END IF;*)
                  length := 0;              end;
             (*END IF;*)
               stb_s_tab_entries [ind].textb := stb_number_char + 1;
               stb_s_tab_entries [ind].texte := stb_number_char + length;
               for loop_j := stb_number_char + 1 to stb_number_char + length do
               stb_s_tab_strings [ loop_j ] :=
                     str [firstc + loop_j - (stb_number_char + 1) ];
               stb_number_char := stb_number_char + length;
               st_get_sub_code := ind;  goto 1410;         end
             (*RETURN IND;*)
            else
               st_get_sub_code := st_nil; goto 1410;       
             (*RETURN ST_NIL;*)
                                                           end
          (*END IF;*)
    else    if length = this.texte - this.textb + 1 then     begin
            flag := true;
            for loop_j := firstc to lastc do
                flag := flag and
   (str [loop_j] = stb_s_tab_strings [this.textb + loop_j - firstc]);
            if flag then
   (*  SYMBOL HAS ALREADY BEEN ENTERED*)
                                                   begin
               st_get_sub_code := ind; goto 1410;  end;       end;
             (*RETURN IND;*)
          (*END IF;*)
       (*END IF;*)
   (* LAST ALTERNATIVE REHASH*)
         epos := (epos + hash) mod st_sym_ubound;          end;
    (*END LOOP;*)
(* NOW THE HASH TABLE MUST BE FULL*)
      if not stb_hashtable_full then                         begin
         er_error_message (1400, er_comp_restriction,
                           so_nil_position, lu_no_symbol  );
         stb_hashtable_full := true;                         end;
     (*END IF;*)
      st_get_sub_code := st_nil;  goto 1410;
    (*RETURN ST_NIL;*)
1410 :
   end;  (*  ST_GET_SUB_CODE;*)
(*                                                                  -*)
(*-------------------------------------------------------------------*)
(*------------------------------------------------------------------*)
   function  st_get_code; (*(STR : ST_LITERAL; L : INTEGER):ST_SYMBOL;*)
   var  s : string; i : integer;
   begin
      for i := sfirst to l do
         s[i] := str[i];
      st_get_code := st_get_sub_code (s, sfirst, l, true);
   end; (*  ST_GET_CODE;*)
(*-------------------------------------------------------------------*)
   function  st_get_char_code; (*(CHR  : CHAR) : ST_SYMBOL;*)
   var    str : string ;
   begin
      str [sfirst] := chr;
      st_get_char_code := st_get_sub_code (str, sfirst, sfirst, true);
   end ;    (*    ST_GET_CHAR_CODE;*)
(*---------------------------------------------------------------------------*)
 procedure st_get_string;  (*  (CODE             : ST_STRING;
                               VAR  STR            : STRING;
                               VAR  OUTP_LAST_CHAR : INTEGER); *)
   var   e : stb_s_tab_rec;
       loop_j :integer;
   begin
         e := stb_s_tab_entries [code];
      outp_last_char := e.texte - e.textb + sfirst;
      for loop_j := sfirst to outp_last_char do
      str [loop_j]  := stb_s_tab_strings [e.textb + loop_j - sfirst];
    end;  (*     ST_GET_STRING;*)


========================================================================================
DOCUMENT :usus Folder:VOLUK03:textdat.text
========================================================================================

29 29 5 5 22 22 21 21 82 82
82 82 82 82 54 54 54 54 54 54
22 22 24 24 24 24 24 24 24 24
24 24 24 24 24 24 22 22 22 22
24 24 24 24 24 24 24 24 82 82
82 82 82 82 34 34 82 82 82 82
82 82 82 82 82 82 82 82 82 82
82 82 50 50 82 82 82 82 82 82
10 10 10 10 77 77 70 70 10 10
10 10 4 4 81 81 93 93 93 93
93 93 93 93 93 93 61 61 81 81
82 82 93 93 82 82 82 82 82 82
34 34 61 61 82 82 81 81 81 81
81 81 0 0 24 24 81 81 81 81
81 81 81 81 82 82 82 82 82 82
82 82 81 81 81 81 0 0 82 82
13 13 73 73 57 57 0 0 34 34
50 50 12 12 77 77 36 36 82 82
82 82 81 81 64 64 82 82 82 82
82 82 82 82 10 10 82 82 82 82
82 82 82 82 34 34 82 82 82 82
10 10 82 82 63 63 82 82 10 10
10 10 10 10 81 81 10 10 82 82
77 77 82 82 77 77 29 29 29 29
48 48 85 85 82 82 82 82 82 82
82 82 82 82 82 82 82 82 89 89
89 89 89 89 89 89 24 24 24 24
24 24 24 24 24 24 36 36 36 36
13 13 13 13 24 24 24 24 24 24
24 24 60 60 60 60 22 22 24 24
24 24 22 22 24 24 22 22 82 82
82 82 82 82 82 82 34 34 82 82
82 82 82 82 82 82 82 82 24 24
24 24 13 13 13 13 24 24 13 13
24 24 13 13 24 24 24 24 13 13
13 13 13 13 13 13 54 54 54 54
54 54 54 54 54 54 82 82 81 81
81 81 24 24 81 81 93 93 24 24
81 81 81 81 81 81 10 10 34 34
82 82 81 81 81 81 82 82 82 82
45 45 48 48 49 49 24 24 4 4
4 4 4 4 4 4 82 82 82 82
24 24 82 82 82 82 24 24 82 82
4 4 10 10 10 10 4 4 82 82
82 82 82 82 10 10 10 10 24 24
82 82 82 82 89 89 89 89 82 82
34 34 87 87 33 33 82 82 53 53
34 34 89 89 69 69 82 82 34 34
34 34 82 82 82 82 34 34 53 53
34 34 82 82 34 34 34 34 89 89
34 34 10 10 89 89 82 82 34 34
82 82 4 4 4 4 4 4 4 4
4 4 61 61 75 75 4 4 37 37
4 4 0 0 0 0 0 0 0 0
0 0 0 0 0 0 0 0 0 0
82 82 82 82 4 4 4 4 4 4
4 4 0 0 4 4 73 73 4 4
73 73 4 4 0 0 0 0 0 0
4 4 4 4 4 4 15 15 56 56
0 0 56 56 32 32 82 82 82 82
56 56 82 82 15 15 51 51 51 51
36 36 82 82 82 82 82 82 82 82
0 0 24 24 82 82 82 82 64 64
0 0 4 4 4 4 4 4 4 4
4 4 4 4 4 4 82 82 4 4
4 4 0 0 24 24 0 0 24 24
38 38 57 57 47 47 57 57 47 47
24 24 4 4 0 0 0 0 38 38
38 38 0 0 47 47 0 0 4 4
4 4 4 4 4 4 4 4 4 4
33 33 82 82 82 82 4 4 4 4
7 7 18 18 4 4 4 4 22 22
14 14 0 0 14 14 0 0 0 0
0 0 0 0 0 0 0 0 0 0
0 0 0 0 0 0 82 82 4 4
73 73 4 4 73 73 4 4 82 82
0 0 0 0 4 4 4 4 4 4
4 4 4 4 4 4 4 4 82 82
4 4 4 4 82 82 82 82 82 82
7 7 82 82 82 82 82 82 75 75
0 0 0 0 0 0 14 14 0 0
82 82 0 0 0 0 4 4 4 4
0 0 0 0 0 0 4 4 4 4
43 43 43 43 43 43 4 4 4 4
4 4 48 48 4 4 4 4 4 4
4 4 4 4 4 4 0 0 81 81
82 82 0 0 0 0 3 3 73 73
4 4 4 4 0 0 0 0 81 81
4 4 4 4 4 4 43 43 43 43
4 4 82 82 41 41 41 41 45 45
82 82 22 22 0 0 0 0 29 29
3 3 4 4 4 4 4 4 4 4
4 4 4 4 0 0 0 0 4 4
4 4 4 4 4 4 4 4 13 13
4 4 26 26 0 0 0 0 4 4
4 4 4 4 4 4 0 0 0 0
0 0 0 0 0 0 4 4 4 4
4 4 4 4 -1 0 0 18 3 12
0 3 0 3 3 0 4 60 3 0
0 2 0 4 3 6 3 0 4 7
6 2 7 2 5 6 30 2 5 3
4 3 4 0 0 0 3 0 0 2
0 3 3 0 2 60 5 0 0 2
0 4 0 0 0 0 2 0 4 0
3 0 0 0 62 5 0 0 0 0
0 0 0 0 5 0 0 6 0 3
0 0 0 38 5 0 0 0 3 0
0 3 0 3 20 0 3 0 3 3
0 4 60 5 0 0 2 0 4 0
5 0 3 20 0 8 0 3 3 0
4 60 5 0 0 2 0 4 2 2
5 3 20 5 8 4 9 3 5 4
60 3 7 4 2 3 4 0 8 24
3 0 0 4 3 3 3 0 0 60
3 0 0 2 3 2 0 4 8 4
6 7 8 0 3 2 0 0 38 3
0 0 0 3 2 0 10 3 6 4
3 6 2 7 4 5 4 38 5 5
0 4 3 4 0 12 10 16 8 0
2 2 3 8 3 6 34 3 3 0
4 3 4 2 3 5 3 16 5 8
2 11 3 5 4 10 9 7 4 2
4 4 0 7 18 3 20 0 2 0
3 3 0 4 60 3 0 0 2 0
4 0 0 18 3 6 0 5 0 3
3 0 4 60 3 0 0 2 0 4
0 0 2 3 16 3 4 5 3 3
0 4 44 3 0 0 2 3 4 0
0 20 10 0 0 8 0 3 5 0
0 38 3 0 0 0 3 0 0 0
18 12 0 0 4 0 3 0 0 0
38 3 0 0 0 3 0 0 0 4
5 0 0 0 0 3 3 0 0 60
3 0 0 2 0 0 0 0 6 3
3 0 0 0 3 3 0 4 60 3
0 0 2 0 4 0 0 12 3 2
0 0 0 3 3 0 4 60 3 0
0 2 0 4 0 2 16 3 20 0
0 2 3 3 0 4 60 3 0 0
2 0 4 0 2 22 3 20 0 0
16 3 3 0 4 60 3 0 0 2
0 4 0 0 26 3 10 0 0 0
3 3 0 4 60 3 0 0 2 0
4 0 9 28 3 20 0 0 0 3
3 0 4 60 3 0 0 2 0 4
0 0 14 3 8 0 0 0 3 3
0 4 60 3 0 0 2 0 4 0
0 0 0 4 0 0 0 0 0 0
0 18 0 0 0 0 0 0 0 2
0 3 20 0 0 18 0 3 0 4
60 0 0 0 2 0 4 0 0 0
3 16 5 0 3 0 3 0 4 10
0 0 0 2 0 4 0 0 0 8
0 0 0 0 0 0 0 0 38 0
0 0 0 3 0 0 0 0 3 4
0 0 0 0 3 0 4 60 0 0
0 2 0 4 0 0 0 7 0 0
0 0 0 0 0 0 38 0 0 0
0 3 0 0 0 0 9 0 0 0
0 0 0 0 0 38 0 0 0 0
3 0 0 0 0 11 0 0 0 0
0 0 0 0 38 0 0 0 0 3
0 0 11 0 3 20 0 0 0 0
3 0 4 60 0 0 0 2 0 4
0 13 0 3 20 0 0 0 0 3
0 4 60 0 0 0 2 0 4 0
0 0 0 2 0 0 0 0 0 0
0 18 0 0 0 0 0 0 0 0
0 3 16 2 0 0 0 3 0 4
60 0 0 0 2 0 4 0 0 0
3 16 7 0 0 0 3 0 4 60
0 0 0 2 0 4 0 0 0 2
0 0 0 0 0 0 0 0 38 0
0 0 0 3 0 0 0 0 13 0
0 0 0 0 0 0 0 38 0 0
0 0 3 0 0 2 0 3 20 0
0 14 0 3 0 4 60 0 0 0
2 0 4 0 0 0 18 0 0 0
0 0 0 0 0 38 0 0 0 0
3 0 0 0 0 3 16 5 0 5
0 3 0 4 10 0 0 0 2 0
4 0 15 0 3 20 0 0 0 0
3 0 4 60 0 0 0 2 0 4
0 17 0 3 20 0 0 0 0 3
0 4 60 0 0 0 2 0 4 0
2 0 3 20 0 0 20 0 3 0
4 60 0 0 0 2 0 4 0 0
0 0 4 0 0 0 0 0 0 0
62 0 0 0 0 0 0 0 0 0
3 14 9 2 0 3 3 0 4 56
0 0 0 2 0 4 0 0 0 3
14 9 4 0 3 3 0 4 56 0
0 0 2 0 4 0 0 0 0 3
0 0 0 0 0 0 0 8 0 0
0 0 0 0 0 2 0 3 20 0
0 3 0 3 0 4 60 0 0 0
2 0 4 0 2 0 3 20 0 0
8 0 3 0 4 60 0 0 0 2
0 4 0 2 0 3 20 0 0 5
0 3 0 4 60 0 0 0 2 0
4 0 0 0 0 6 0 0 0 0
0 0 0 62 0 0 0 0 0 0
0 19 0 3 20 0 0 0 0 3
0 4 60 0 0 0 2 0 4 0
21 0 3 20 0 0 0 0 3 0
4 60 0 0 0 2 0 4 0 0
0 3 5 0 0 0 0 3 0 4
60 0 0 0 2 0 4 0 0 0
3 16 5 0 7 3 3 0 4 16
0 0 0 2 0 4 0 2 0 3
18 9 10 22 3 3 0 4 56 2
0 0 2 0 4 0 2 0 3 18
4 8 7 3 3 0 4 52 3 0
0 2 5 4 0 2 0 3 18 9
10 26 3 3 0 4 56 2 0 0
2 0 4 0 2 0 3 20 0 0
9 3 3 0 4 60 0 0 0 2
0 4 0 0 0 0 5 0 0 0
0 0 0 0 8 0 0 0 0 0
0 0 0 0 3 14 9 0 0 5
3 0 4 56 0 0 0 2 0 4
0 0 0 0 0 0 0 0 0 3
0 0 60 0 0 0 3 0 0 0
0 0 3 16 5 0 9 0 3 0
4 10 0 0 0 2 0 4 0 0
0 0 0 0 0 0 5 0 0 0
4 0 0 0 0 0 0 0 2 0
3 18 4 8 7 3 3 0 4 52
5 0 0 2 5 4 0 2 0 3
18 9 6 11 3 3 0 4 56 3
0 0 2 0 4 0 2 0 3 18
9 6 11 3 3 0 4 56 5 0
0 2 0 4 0 2 0 3 20 0
0 9 5 3 0 4 60 0 0 0
2 0 4 0 0 0 14 0 0 0
0 0 6 0 0 38 0 0 0 0
3 0 0 0 0 16 0 0 0 0
0 8 0 0 38 0 0 0 0 3
0 0 2 0 3 20 0 0 6 0
3 0 4 60 0 0 0 2 0 4
0 2 0 3 20 0 0 10 0 3
0 4 60 0 0 0 2 0 4 0
2 0 3 20 0 0 13 0 3 0
4 60 0 0 0 2 0 4 0 2
0 3 20 0 0 12 0 3 0 4
60 0 0 0 2 0 4 0 2 0
3 20 0 0 15 0 3 0 4 60
0 0 0 2 0 4 0 2 0 3
20 0 0 17 0 3 0 4 28 0
0 0 2 7 4 0 2 0 3 20
0 0 24 0 3 0 4 60 0 0
0 2 0 4 0 2 0 3 20 0
0 19 0 3 0 4 60 0 0 0
2 0 4 -2 1 7 2 1 1 7
2 7 3 7 3 7 3 7 3 7
3 7 4 7 3 7 3 7 3 7
3 7 3 7 3 7 3 7 4 7
3 7 3 7 5 7 3 7 6 7
7 7 2 7 12 7 12 7 13 7
2 1 6 1 15 7 3 1 5 1
7 1 9 1 8 7 8 7 13 7
13 7 11 7 3 1 8 7 11 7
12 7 2 1 2 1 9 7 16 7
17 7 18 7 19 7 20 7 3 7
10 7 13 7 13 7 4 7 5 7
6 7 7 7 21 7 15 7 21 7
22 7 23 7 24 7 2 1 23 7
10 7 11 7 26 7 24 7 4 1
8 1 10 1 12 1 14 7 25 7
22 7 27 7 4 1 46 1 6 1
6 1 9 7 31 7 32 7 33 7
10 7 35 7 36 7 10 7 38 7
39 7 39 7 40 7 41 7 11 7
43 7 44 7 11 7 17 7 11 7
46 7 47 7 11 7 49 7 50 7
51 7 2 7 53 7 7 1 55 7
56 7 57 7 58 7 13 7 8 7
5 5 5 3 12 7 13 7 61 7
62 7 63 7 64 7 65 7 66 7
8 7 2 7 18 7 16 7 17 7
12 7 68 7 2 1 70 7 71 7
2 1 4 1 74 7 73 7 74 7
73 7 12 7 75 7 13 7 8 7
2 1 4 1 20 7 79 7 14 7
15 7 82 7 7 7 7 7 7 7
7 7 7 7 7 7 7 7 7 7
7 7 2 7 2 7 11 7 7 7
2 1 7 7 2 1 6 1 8 7
8 7 8 7 2 1 13 7 13 7
11 7 9 7 12 7 11 7 12 7
7 7 7 7 7 7 7 7 7 7
7 7 7 7 7 7 7 7 7 7
7 7 7 7 7 7 7 7 7 7
7 7 7 7 10 7 10 7 2 7
6 1 16 7 17 7 18 7 19 7
7 7 2 1 7 7 7 7 7 7
7 7 7 7 20 7 2 1 2 1
3 7 7 7 7 7 7 7 2 1
2 1 7 7 7 7 7 7 7 7
7 7 10 7 7 7 7 7 7 7
4 1 3 1 2 1 7 7 7 7
2 1 7 7 7 7 13 7 4 1
2 1 7 7 7 7 3 1 4 1
7 7 7 7 7 7 7 7 7 7
13 7 7 7 7 7 4 7 2 1
5 7 6 7 7 7 7 7 7 7
21 7 7 7 15 7 21 7 22 7
23 7 24 7 25 7 7 7 7 7
7 7 7 7 7 7 7 7 2 1
23 7 10 7 11 7 3 3 26 7
7 7 24 7 7 7 1 7 26 7
10 7 12 7 14 7 25 7 22 7
7 7 7 7 7 7 7 7 7 7
2 1 4 1 7 7 7 7 7 7
7 7 7 7 7 7 3 1 6 1
7 7 5 1 7 7 2 1 7 7
7 7 27 7 7 7 48 1 2 1
4 1 6 1 8 1 10 1 20 1
7 7 28 7 29 7 7 7 2 1
2 3 2 1 7 7 2 3 13 7
4 3 5 3 2 1 30 7 4 1
4 3 7 7 7 7 4 1 7 7
9 7 31 7 32 7 36 1 40 1
42 1 54 1 7 7 7 7 7 7
33 7 34 7 2 1 2 1 35 7
36 7 7 7 7 7 7 7 7 7
7 7 7 7 7 7 7 7 2 1
7 7 7 7 7 7 7 7 7 7
37 7 38 7 7 7 39 7 7 7
39 7 7 7 2 1 2 1 12 1
14 1 24 1 26 1 32 1 40 7
41 7 42 7 43 7 44 7 7 7
7 7 7 7 22 3 7 7 7 7
7 7 7 7 7 7 7 7 7 7
7 7 7 7 7 7 16 7 17 7
45 7 46 7 7 7 7 7 7 7
47 7 48 7 49 7 50 7 51 7
52 7 53 7 54 7 2 1 55 7
56 7 57 7 7 7 7 7 58 7
7 7 7 7 7 7 13 7 8 7
7 7 7 7 59 7 60 7 9 7
13 7 61 7 62 7 58 1 63 7
64 7 65 7 66 7 8 7 7 7
7 7 2 7 7 7 18 7 16 7
17 7 5 3 5 1 67 7 68 7
69 7 70 7 71 7 72 7 7 7
7 7 50 1 73 7 74 7 73 7
74 7 2 1 73 7 12 7 2 1
4 1 75 7 76 7 77 7 78 7
5 1 7 7 7 7 19 7 20 7
79 7 80 7 81 7 82 7 -3 2
0 0 2 2 1 0 2 1 2 0
7 4 3 1 7 2 4 1 7 3
10 2 7 6 24 2 7 3 0 4
4 4 27 6 7 3 0 12 7 5
36 14 7 6 0 16 7 6 46 19
7 3 0 19 2 2 47 21 2 7
48 21 7 8 53 21 7 9 66 30
7 13 67 30 7 2 68 30 2 2
69 30 7 2 70 40 2 9 0 40
7 2 71 42 2 10 72 42 7 2
76 44 2 2 77 44 2 7 78 44
7 6 0 44 7 11 0 47 7 11
0 49 7 3 0 51 2 2 80 52
2 6 0 52 7 12 81 54 7 9
0 54 7 13 84 56 7 14 115 56
7 6 116 60 7 4 118 64 2 3
0 64 4 2 120 66 2 15 0 66
7 15 0 68 7 14 121 71 7 15
0 73 7 8 122 75 7 5 123 77
7 7 129 81 7 2 133 81 2 3
134 81 2 3 0 82 2 3 0 83
2 2 135 84 2 7 136 84 7 4
138 84 2 4 140 84 2 7 142 84
7 4 146 85 2 2 148 85 7 7
149 86 7 7 150 86 7 16 152 88
7 5 154 89 7 3 0 89 2 3
0 90 2 7 157 91 7 2 159 91
2 3 0 91 7 5 160 93 7 9
0 93 7 6 164 98 2 3 0 98
4 7 167 100 7 10 170 101 7 4
172 102 2 2 175 102 7 7 176 103
7 3 178 103 2 2 183 104 2 8
184 104 7 2 185 108 2 3 0 108
2 7 186 109 7 3 0 109 2 2
187 111 2 5 0 111 7 2 188 113
2 7 189 113 7 2 190 113 2 2
191 113 2 2 192 113 2 4 0 113
7 17 193 115 7 18 194 116 7 2
196 117 2 14 0 117 7 18 0 119
7 2 197 122 2 3 0 122 2 10
198 123 7 2 199 125 2 17 200 125
7 3 0 125 4 9 0 127 7 2
202 129 2 7 203 129 7 7 204 129
7 7 205 129 7 7 207 129 7 5
208 129 7 7 210 129 7 19 211 129
7 2 213 129 2 10 214 129 7 7
215 130 7 14 0 130 7 12 216 132
7 2 218 132 2 3 0 132 2 7
219 133 7 7 220 133 7 19 222 133
7 7 224 133 7 -4 1 2 3 4
5 5 6 7 7 7 8 9 9 10
10 11 10 11 3 8 11 10 11 11
5 5 5 12 13 13 5 14 14 14
14 15 16 5 5 5 17 17 18 19
20 21 22 23 24 24 24 24 24 25
26 5 27 5 5 5 12 25 5 23
23 23 28 29 30 31 30 23 13 13
13 13 23 23 32 5 33 34 35 36
37 38 39 40 41 42 42 43 44 42
42 42 42 45 46 42 47 42 48 42
42 49 42 50 51 52 53 54 55 53
51 56 5 56 1 1 57 58 5 5
5 5 5 5 5 59 59 59 59 60
61 62 61 61 63 63 64 64 61 61
61 61 65 65 66 66 61 67 10 3
68 68 68 69 12 5 5 70 5 5
71 72 73 64 74 64 75 76 75 75
76 33 33 33 77 78 78 78 77 5
26 79 80 23 24 29 81 82 81 83
12 15 79 23 5 5 84 85 86 28
87 88 88 22 5 89 61 5 5 61
5 87 90 90 22 5 5 5 91 91
29 5 5 59 92 93 12 94 95 69
96 97 59 98 69 12 12 99 15 99
100 12 93 97 12 59 12 101 59 96
12 93 88 88 88 102 87 25 103 87
104 87 105 105 105 105 105 32 32 32
32 5 5 88 87 106 106 36 87 107
87 107 87 105 105 105 87 87 87 108
109 32 109 110 111 111 109 5 108 112
112 63 111 111 113 111 32 29 5 70
114 32 88 88 88 88 88 88 88 5
87 115 116 29 36 29 117 35 118 119
120 80 88 72 73 121 117 122 123 105
87 88 88 88 88 88 95 5 5 88
88 124 125 126 87 127 128 32 129 128
32 128 32 71 32 32 32 32 32 113
87 107 130 107 87 5 131 132 88 88
88 88 88 88 88 133 88 87 5 5
5 134 5 5 5 103 32 135 136 129
135 5 105 105 87 87 32 32 32 137
88 138 138 139 87 87 87 140 88 87
87 88 141 87 32 26 5 87 87 142
107 87 138 32 32 143 138 88 87 139
138 22 93 144 144 145 5 146 32 32
147 142 87 88 138 138 138 87 32 32
88 148 148 88 88 149 150 150 151 151
87 87 87 87 152 32 153 105 105 87
87 87 87 -5 1 2 2 3 4 5
6 7 8 9 10 11 12 13 14 15
16 17 18 19 19 20 21 22 23 24
25 6 26 27 28 6 29 30 31 8
32 33 34 35 36 37 38 39 40 41
42 43 27 6 44 45 46 47 48 49
50 51 52 53 54 55 56 57 58 17
59 60 61 62 63 64 6 65 64 66
61 67 68 46 69 70 71 46 64 72
64 73 64 74 75 76 64 77 -6 0
1 2 3 4 5 6 7 8 9 10
11 12 13 14 15 16 17 18 19 20
21 22 23 24 25 26 29 30 31 32
33 34 35 36 37 38 39 40 43 44
45 46 47 48 49 50 52 53 54 55
56 57 58 60 61 62 63 64 65 66
67 68 69 70 71 72 73 74 75 76
77 -8 0 1 2 3 4 6 7 8
9 10 11 12 13 14 15 16 17 18
19 20 21 22 23 24 25 26 29 30
31 32 33 34 35 36 37 38 39 40
43 44 45 46 47 48 49 50 52 53
54 55 56 57 58 60 61 62 63 64
65 66 67 68 69 70 71 72 73 74
75 76 77 -8 0 2 3 5 8 9
10 11 12 14 16 19 20 22 24 25
27 28 30 31 33 34 35 37 39 40
41 43 44 45 46 47 49 51 52 53
54 55 56 57 58 59 60 61 62 63
64 65 66 67 68 69 70 71 72 73
74 75 76 77 -8 0 1 2 3 4
5 6 7 8 9 10 11 12 13 14
15 16 17 18 19 21 22 23 24 25
26 27 28 29 30 31 32 33 34 35
36 37 38 39 40 41 42 43 44 45
46 47 48 49 50 51 52 53 54 55
56 57 58 59 60 61 63 64 65 67
68 69 70 72 73 74 75 76 77 -8
0 1 2 3 4 5 6 7 8 9
10 11 12 13 14 15 16 17 18 19
20 21 22 23 24 25 26 27 28 29
30 31 32 33 34 35 36 37 38 39
40 41 42 43 44 45 46 47 48 49
50 51 52 53 54 55 56 57 58 59
60 61 62 63 64 65 66 67 68 69
70 72 73 74 75 76 77 -8 0 1
2 3 4 5 6 7 8 9 10 11
12 13 14 15 16 17 18 19 21 22
23 24 25 26 27 28 29 30 31 32
33 34 35 36 37 38 39 40 41 42
43 44 45 46 47 48 49 50 51 52
53 54 55 56 57 58 59 60 61 62
63 64 65 66 67 68 69 70 72 73
74 75 76 77 -8 0 1 2 3 4
5 6 7 8 9 10 11 12 13 14
15 16 17 18 19 20 21 22 23 24
25 26 27 28 29 30 31 32 33 34
35 36 37 38 39 40 41 42 43 44
45 46 47 49 50 51 52 53 54 55
56 57 58 59 60 61 62 63 64 65
66 67 68 69 70 71 72 73 74 75
76 77 -8 0 2 3 5 8 9 10
11 12 14 16 19 20 24 25 27 28
30 31 33 34 35 37 38 39 40 41
43 44 45 46 47 49 51 52 53 54
55 56 57 58 59 60 61 62 63 64
65 66 67 68 69 70 71 72 73 74
75 76 77 -8 0 2 3 5 8 9
10 11 12 14 16 19 20 21 22 24
25 27 28 30 31 33 34 35 37 38
39 40 41 43 44 45 46 47 49 51
52 53 54 55 56 57 59 60 61 62
63 64 65 66 67 68 69 70 71 72
73 74 75 76 77 -8 0 2 3 5
8 9 10 11 12 14 16 19 20 21
22 24 25 27 28 30 31 33 34 35
37 38 39 40 41 43 44 45 46 47
49 51 52 53 54 55 56 57 58 59
60 61 62 63 64 65 66 67 68 69
70 71 72 73 74 75 76 77 -8 0
2 3 5 8 9 10 11 12 14 16
19 20 21 22 24 27 28 30 31 33
34 35 37 38 39 40 41 43 44 45
46 47 49 51 52 53 54 55 56 57
58 59 60 61 62 63 64 65 66 67
68 69 70 71 72 73 74 75 76 77
-8 0 1 2 3 4 5 6 7 8
9 10 11 12 13 14 15 16 17 18
19 20 21 22 23 24 25 26 27 28
29 30 32 33 34 35 36 37 38 39
40 41 42 43 44 45 46 47 48 49
50 51 52 53 54 55 56 57 58 59
60 61 62 63 64 65 66 67 68 69
70 71 72 73 74 75 76 77 -8 0
1 2 3 4 5 6 7 8 9 10
11 12 13 14 15 16 17 18 19 20
21 22 23 24 25 26 27 28 29 30
31 32 33 34 35 36 37 38 39 40
41 42 43 44 45 46 47 48 49 50
51 52 53 54 55 56 57 58 59 60
61 62 63 64 65 66 67 68 69 70
72 73 74 76 77 -8 0 1 2 3
4 5 6 7 8 9 10 11 12 13
14 15 16 17 18 19 20 21 22 23
24 25 26 27 28 29 30 31 32 33
34 35 36 37 38 39 40 41 42 43
44 45 46 47 48 49 50 51 52 53
54 55 56 57 58 59 60 61 62 63
64 65 66 67 68 69 72 73 74 76
77 -8 0 1 2 3 4 5 6 7
8 9 10 11 12 13 14 15 16 17
18 19 20 21 22 23 24 25 26 27
28 29 30 32 33 34 35 36 37 38
39 40 41 42 43 44 45 46 48 49
50 51 52 53 54 55 56 57 58 59
60 61 62 63 64 65 66 67 68 69
70 72 73 74 75 76 77 -8 0 1
2 3 4 5 6 7 8 9 10 11
12 13 14 15 16 17 18 19 20 21
22 23 24 25 26 27 28 29 30 31
32 33 34 35 36 37 38 39 40 41
42 43 45 46 47 48 49 50 51 52
53 54 55 56 57 58 59 60 61 62
63 64 65 66 67 68 69 70 71 72
73 74 75 76 77 -8 0 1 2 3
4 5 6 7 8 9 11 12 13 14
15 16 17 18 19 20 21 22 23 24
25 26 27 28 29 30 33 34 35 36
37 39 40 41 42 43 45 46 48 49
50 51 52 53 54 56 57 58 59 61
62 63 64 65 66 67 68 69 73 74
76 -8 0 1 2 3 4 5 6 7
8 9 10 11 12 13 14 15 16 17
18 19 20 21 22 23 24 25 26 27
28 29 30 31 32 33 34 35 36 37
38 39 40 41 42 43 44 45 46 47
48 49 50 51 52 53 54 55 56 57
58 59 60 61 62 64 65 66 68 69
70 71 72 73 74 75 76 -8 0 1
2 3 4 5 6 7 8 9 10 11
12 13 14 15 16 17 18 19 20 21
22 23 24 25 26 27 28 29 30 31
32 33 34 35 36 37 38 39 40 41
42 43 44 45 46 47 48 49 50 51
52 53 54 55 56 57 58 59 60 61
62 64 65 66 67 68 69 70 71 72
73 74 75 76 77 -8 0 1 2 3
4 5 6 7 8 9 11 12 13 14
15 16 17 18 19 20 21 22 23 24
25 26 27 28 29 31 32 33 34 36
37 39 40 41 42 43 44 45 46 47
48 49 50 51 52 53 54 55 56 57
58 59 61 62 65 66 68 69 71 73
74 75 76 -8 0 1 2 3 4 5
6 7 8 9 11 12 13 14 15 16
17 18 19 20 21 22 23 24 25 26
27 28 29 33 34 36 37 39 40 41
42 43 44 45 46 47 48 49 50 51
52 53 54 56 57 58 59 61 62 63
65 66 67 68 69 73 74 75 76 -8
0 5 6 7 8 9 10 11 12 13
14 15 16 17 18 19 20 21 22 23
24 25 26 27 28 29 30 31 32 33
35 37 38 39 40 41 42 43 44 45
46 47 48 49 50 51 52 53 54 55
56 57 58 59 60 61 62 63 64 65
67 68 69 70 71 72 73 74 75 76
77 -8 0 1 2 3 4 5 6 7
8 9 10 11 12 13 14 15 16 17
18 19 20 21 22 23 24 25 26 27
28 29 30 31 32 33 34 35 36 37
38 39 40 41 42 43 44 45 46 47
48 49 50 51 52 53 54 55 56 57
58 59 60 61 62 63 64 65 66 67
68 69 71 73 74 75 76 77 -8 0
1 2 3 4 5 6 7 8 9 10
11 12 13 14 15 16 17 18 19 20
21 22 23 24 25 26 27 28 29 30
31 32 33 34 35 36 37 38 39 40
41 42 43 44 45 46 47 48 49 50
51 52 53 54 55 56 57 58 59 60
61 62 63 64 65 66 68 69 70 71
72 73 74 75 76 -8 0 1 2 3
4 5 6 7 8 9 10 11 12 13
14 15 16 17 18 19 20 21 22 23
24 25 26 27 28 29 30 31 32 33
34 35 36 37 38 39 40 41 42 43
44 45 46 47 48 49 50 51 52 53
54 56 57 58 59 60 61 62 63 64
65 66 67 68 69 70 71 72 73 74
75 76 77 -8 0 1 2 3 4 5
6 7 8 9 10 11 12 13 14 15
16 17 18 19 20 21 22 23 24 25
26 27 28 29 30 31 32 33 34 35
36 37 38 39 40 41 42 43 44 45
46 47 48 49 50 51 52 53 54 55
56 57 58 59 60 61 62 63 64 65
66 67 68 69 71 72 73 74 75 76
77 -8 0 1 2 3 4 5 6 7
8 9 10 11 12 13 14 15 16 17
18 19 20 21 22 23 24 25 26 27
28 29 30 31 32 33 34 35 36 37
38 39 40 41 42 43 44 45 46 47
48 49 50 51 52 53 54 55 56 57
58 59 60 61 62 63 64 65 66 67
68 69 70 71 72 73 74 75 76 -8
0 2 3 5 6 7 8 9 10 11
12 13 14 15 16 17 18 19 20 21
22 24 25 26 27 28 29 30 31 32
33 34 35 36 37 38 39 40 41 42
43 44 45 46 47 48 49 50 51 52
53 54 55 56 57 58 59 60 61 62
63 64 65 66 67 68 69 70 71 72
73 74 75 76 77 -8 0 1 2 3
4 5 6 7 8 9 10 11 12 13
14 15 16 17 18 19 20 21 22 24
25 26 27 28 29 30 31 32 33 34
35 36 37 38 39 40 41 42 43 44
45 46 47 48 49 50 51 52 53 54
55 56 57 59 60 61 62 63 64 65
66 67 68 69 70 71 72 73 74 75
76 77 -8 0 1 2 3 4 5 6
7 8 9 11 12 13 14 15 16 17
18 19 20 21 22 23 24 25 26 27
28 29 30 33 34 35 36 37 38 39
40 41 42 43 44 45 46 47 48 49
50 51 52 53 54 56 57 58 59 60
61 62 63 64 65 66 67 68 69 73
74 75 76 -8 0 1 2 3 4 5
6 7 8 9 11 12 13 14 15 16
17 18 19 20 21 22 23 24 25 26
27 28 29 30 33 34 35 36 37 39
40 41 42 43 44 45 46 47 48 49
50 51 52 53 54 56 57 58 59 61
62 63 64 65 66 67 68 69 73 74
75 76 -8 0 2 3 4 5 6 7
8 9 10 11 12 13 14 15 16 17
18 19 20 21 22 23 24 25 26 27
28 29 30 31 32 33 34 35 36 37
38 39 40 41 42 43 44 45 46 47
48 49 50 51 52 53 54 55 56 57
58 59 60 61 62 63 64 65 66 67
68 69 70 71 72 73 74 75 76 77
-8 0 1 2 3 4 5 6 7 8
9 10 11 12 14 15 16 17 18 19
20 21 22 24 25 26 29 30 31 32
33 34 35 36 37 38 39 40 43 44
45 46 47 48 49 50 51 52 54 55
56 57 58 59 60 61 62 63 64 65
66 67 68 69 70 71 72 73 74 75
76 77 -8 0 2 3 5 6 7 8
9 10 11 12 13 14 15 16 17 18
19 20 21 22 23 24 25 26 27 28
29 30 31 32 33 34 35 36 37 38
39 40 41 42 43 44 45 46 47 48
49 50 51 52 53 54 55 56 57 58
59 60 61 62 63 64 66 67 68 69
70 71 72 73 74 75 76 77 -8 0
2 3 4 5 6 7 8 9 10 11
12 14 15 16 17 18 19 20 21 22
23 24 25 29 30 31 32 33 34 35
36 37 38 39 40 43 44 45 46 47
48 49 50 54 55 58 59 60 61 62
63 64 65 66 67 68 69 70 71 72
73 74 75 76 77 -8 0 2 3 4
5 6 7 8 9 10 11 12 14 15
16 17 18 19 20 21 22 23 24 25
29 30 31 32 33 34 35 36 37 38
39 40 43 44 45 46 47 48 49 50
51 54 55 58 59 60 61 62 63 64
65 66 67 68 69 70 71 72 73 74
75 76 77 -8 0 1 2 3 4 5
6 7 8 9 10 11 12 13 14 15
16 17 18 19 20 21 22 23 24 25
26 27 28 29 30 32 33 34 35 36
37 38 39 40 41 42 43 44 45 46
47 48 49 50 51 52 53 54 55 56
57 58 59 60 61 63 64 65 67 68
69 70 71 72 73 74 75 77 -8 0
1 2 3 4 5 6 7 8 9 10
11 12 13 14 15 16 17 18 19 20
21 22 23 24 25 26 27 28 29 30
31 32 33 34 35 36 37 38 39 40
41 42 43 45 46 47 48 49 50 51
52 53 54 55 56 57 58 59 60 61
63 64 65 67 68 69 70 71 72 73
74 75 77 -8 0 1 2 3 4 5
6 7 8 9 10 11 13 14 15 16
17 18 19 20 21 22 23 24 25 26
27 28 29 30 31 32 33 34 35 36
37 38 39 40 41 42 43 44 45 46
47 48 49 50 51 52 53 54 55 56
57 58 59 60 61 63 64 65 67 68
69 70 71 72 73 74 75 77 -8 0
1 2 3 4 5 6 7 8 9 10
11 12 13 14 15 16 17 18 19 20
21 22 23 24 25 26 27 28 29 30
31 32 33 34 35 36 37 38 39 40
41 42 43 44 45 46 47 48 49 50
51 52 53 54 55 56 57 58 59 60
61 63 64 65 68 69 70 71 72 73
74 75 -8 0 1 2 3 4 5 6
7 8 9 10 11 12 13 14 15 16
17 18 19 20 21 22 23 24 25 26
27 28 29 30 31 34 35 36 37 38
39 40 41 42 43 45 47 48 49 50
51 52 53 54 55 56 57 58 59 60
64 65 67 71 73 74 75 77 -8 0
1 2 3 4 5 6 7 8 9 10
11 12 13 14 15 16 17 18 19 20
21 22 23 24 25 26 27 28 29 30
31 32 33 34 35 36 37 38 39 40
41 42 43 44 45 46 47 48 49 50
51 52 53 54 55 56 57 58 59 60
61 63 64 65 67 68 69 70 72 73
74 75 77 -8 0 1 2 3 4 5
6 7 8 9 10 11 12 13 14 15
16 17 18 19 20 21 22 23 24 25
26 27 28 29 30 31 32 34 35 36
37 38 39 40 41 42 43 45 47 48
49 50 51 52 53 54 55 56 57 58
59 60 64 65 67 71 73 74 75 77
-8 0 1 2 3 4 5 6 7 8
9 10 11 12 13 14 15 16 17 18
19 20 21 22 23 24 25 26 27 28
29 30 31 32 33 34 35 36 37 38
39 40 41 42 43 44 45 46 47 48
49 50 51 52 53 54 55 56 57 59
60 61 63 64 65 67 68 69 70 72
73 74 75 77 -8 0 1 2 3 4
5 6 7 8 9 11 12 13 14 15
16 17 18 20 21 22 23 24 25 26
27 28 29 31 32 34 36 37 39 40
41 42 43 45 47 48 49 50 51 52
53 54 55 56 57 58 59 63 65 67
71 73 74 75 77 -8 0 1 2 3
4 5 6 7 8 9 10 11 12 13
14 15 16 17 18 19 20 21 22 23
24 25 26 27 28 29 30 31 32 33
34 35 36 37 38 39 40 41 42 43
44 45 46 47 48 49 50 51 52 53
54 55 56 57 58 59 60 61 63 64
65 67 68 69 70 72 73 74 77 -8
0 1 2 3 4 5 6 7 8 9
10 11 12 13 14 15 16 17 18 20
21 22 23 24 25 26 27 28 29 30
31 32 33 34 35 36 37 38 39 40
41 42 43 45 46 48 49 50 51 52
53 54 55 56 57 58 59 60 61 63
64 65 67 68 69 70 72 73 74 77
-8 0 1 2 3 4 5 6 7 8
9 10 11 12 13 14 15 16 17 18
20 21 22 23 24 25 26 27 28 29
30 32 33 34 35 36 37 38 39 40
41 42 43 45 46 48 49 50 51 52
53 54 55 56 57 58 59 60 61 63
64 65 67 68 69 72 73 74 77 -8
0 1 2 3 4 5 6 7 8 9
11 12 13 14 15 16 17 18 20 21
22 23 24 25 26 27 28 29 30 34
35 36 37 39 40 41 42 43 45 47
48 49 50 51 52 53 54 56 57 58
59 64 65 67 73 74 75 -8 0 1
2 3 4 5 6 7 8 9 10 11
12 13 14 15 16 17 18 19 20 21
22 23 24 25 26 27 28 29 30 31
32 33 34 35 36 37 38 39 40 41
42 43 44 45 46 47 48 49 50 51
52 53 54 55 56 58 59 60 61 63
64 65 67 68 69 70 71 72 73 74
75 77 -8 0 1 2 3 4 5 6
7 8 9 10 11 12 13 14 15 16
17 18 19 20 21 22 23 24 25 26
27 28 29 30 31 32 33 34 35 36
37 38 39 40 41 42 43 44 45 46
47 48 49 50 51 52 53 54 55 56
57 58 59 60 61 63 64 65 67 68
69 70 73 74 75 77 -8 0 1 2
3 4 5 6 7 8 9 11 12 13
14 15 16 17 18 20 21 22 23 24
25 26 27 28 29 31 32 34 36 37
39 40 41 42 43 45 47 48 49 50
51 52 53 54 55 56 57 58 59 65
71 73 74 75 -8 0 1 2 3 4
5 6 7 8 9 11 12 13 14 15
16 17 18 19 20 21 22 23 24 25
26 27 28 29 34 36 37 39 40 41
42 43 45 48 49 50 51 52 53 54
56 57 58 59 65 73 74 -8 0 1
2 3 4 5 6 7 8 9 11 12
13  14  15  16  17  18  19  20  21  22
23  24  25  26  27  28  29  31  32  34
36  37  39  40  41  42  43  45  47  48
49  50  51  52  53  54  55  56  57  58
59  65  71  73  74  75  -8  0  1  2
3  4  5  6  7  8  9  10  11  12
13  14  15  16  17  18  19  20  21  22
23  24  25  26  27  28  29  30  31  32
33  34  35  36  37  38  39  40  41  42
43  44  45  46  47  48  49  50  51  52
53  54  55  56  57  58  59  60  61  63
64  65  67  68  69  71  72  73  74  75
77  -8  0  1  2  3  4  5  6  7
8  9  10  11  12  13  14  15  16  17
18  19  20  21  22  23  24  25  26  27
28  29  30  31  32  33  34  35  36  37
38  39  40  41  42  43  44  45  46  47
48  49  50  51  52  53  54  55  56  57
58  59  60  61  62  63  64  65  66  68
69  71  73  74  75  76  -8  0  1  2
3  4  5  6  7  8  9  10  11  12
13  14  15  16  17  18  19  20  21  22
23  24  25  26  29  30  31  32  33  34
35  36  37  38  39  40  42  43  44  45
46  47  48  49  50  52  53  54  55  56
57  58  60  61  62  63  64  65  66  67
68  69  70  71  72  73  74  75  76  77
-8  0  1  2  3  4  5  6  7  8
9  10  11  12  13  14  15  16  17  18
19  20  21  22  23  24  25  26  27  28
29  30  31  32  33  34  35  36  37  38
39  40  41  42  43  44  45  46  47  48
49  50  51  52  53  54  55  56  57  58
59  60  61  62  63  64  65  66  67  68
69  70  71  73  74  75  76  77  -8  0
1  2  3  4  5  6  7  8  9  10
11  12  13  14  15  16  17  18  19  20
21  22  23  24  25  26  27  28  29  30
31  32  33  34  35  36  37  38  39  40
41  42  43  44  45  46  47  48  49  50
51  52  53  54  55  56  57  58  59  60
61  62  63  64  65  66  67  68  69  70
71  73  75  76  77  -8  0  2  3  4
5  6  7  8  9  10  11  12  13  14
16  17  18  19  20  21  22  24  25  26
27  28  29  30  31  32  33  34  35  36
37  38  39  40  41  42  43  44  45  46
47  48  49  50  51  52  53  54  55  56
57  59  60  61  62  63  64  65  66  67
68  69  70  71  72  73  74  75  76  77
-8  0  1  2  3  4  5  6  7  8
9  10  11  12  13  14  15  16  17  18
19  20  21  22  24  25  26  27  28  29
30  31  32  33  34  35  36  37  38  39
40  41  42  43  44  45  46  47  48  49
50  51  52  53  54  55  56  57  58  59
60  61  62  63  64  65  66  67  68  69
70  71  72  73  74  75  76  77  -8  0
1  2  3  4  5  6  7  8  9  10
11  12  13  14  15  16  17  18  19  20
24  25  26  27  28  29  30  31  32  33
34  35  36  37  38  39  40  41  42  43
44  45  46  47  48  49  50  51  52  53
54  55  56  57  58  59  60  61  62  63
64  65  66  67  68  69  70  71  72  73
74  75  76  77  -8  0  1  2  3  4
5  6  7  8  9  10  11  12  13  14
15  16  17  18  19  20  21  22  23  24
25  26  27  28  29  30  31  33  34  35
36  37  38  39  40  41  42  43  44  45
46  47  48  49  50  51  52  53  54  55
56  57  58  59  60  61  62  63  64  65
66  67  68  69  70  71  72  73  74  75
76  77  -8  0  1  2  3  4  5  6
7  8  9  10  11  12  14  15  16  17
18  19  20  21  22  23  24  25  26  27
28  29  30  31  32  33  34  35  36  37
38  39  40  41  42  43  44  45  46  47
48  49  50  51  52  53  54  55  56  57
58  59  60  61  62  63  64  65  66  67
68  69  70  71  72  73  74  75  76  77
-8  0  1  2  3  4  5  6  8  9
10  11  12  13  14  15  16  17  19  20
21  22  23  24  25  26  27  28  29  30
31  32  33  34  35  36  37  38  39  40
41  42  43  44  45  46  47  48  49  50
51  52  53  55  56  57  58  59  60  61
62  63  64  65  66  67  68  69  70  71
72  73  74  75  76  77  -8  0  1  2
3  4  5  6  7  8  9  10  11  12
13  14  15  16  17  18  19  20  22  24
25  26  27  28  29  30  31  32  33  34
35  36  37  39  40  41  42  43  44  45
46  47  48  49  50  51  52  53  54  55
56  57  58  59  60  61  62  63  64  65
66  67  68  69  70  71  72  73  74  75
76  77  -8  0  1  2  3  4  5  6
7  8  9  10  11  12  13  14  15  16
17  18  19  20  22  23  24  25  26  27
28  29  30  31  32  33  34  35  36  37
39  40  41  42  43  44  45  46  47  48
49  50  51  52  53  54  55  56  57  58
59  60  61  62  63  64  65  66  67  68
69  70  71  72  73  74  75  76  77  -8
0  1  2  3  4  5  6  7  8  9
10  11  12  13  14  15  16  17  18  19
20  21  22  23  24  25  26  27  28  29
30  31  32  33  34  35  36  37  38  39
40  41  42  43  44  45  46  47  48  49
50  51  52  53  54  55  56  57  58  59
60  61  62  63  64  65  66  67  68  69
70  73  74  75  76  77  -8  0  1  2
3  4  5  6  7  8  9  10  11  12
13  14  15  16  17  18  19  20  21  22
23  24  25  26  27  28  29  30  32  33
34  35  36  37  38  39  40  41  42  43
44  45  46  47  48  49  50  51  52  53
54  55  56  57  58  59  60  61  62  63
64  65  66  67  68  69  70  72  73  74
75  76  77  -8  0  1  2  3  4  5
6  7  8  9  10  11  12  13  14  15
16  17  18  19  20  21  22  23  24  25
26  27  28  29  30  31  32  33  34  35
36  37  38  39  40  41  42  43  44  45
46  48  49  50  51  52  53  54  55  56
57  58  59  60  61  62  63  64  65  66
67  68  69  70  72  73  74  75  76  77
-8  0  2  3  4  5  6  7  8  9
10  11  12  13  14  15  16  17  18  19
20  21  22  24  25  29  30  31  32  33
34  35  36  37  38  39  40  43  44  45
46  47  48  49  50  51  54  55  58  59
60  61  62  63  64  65  66  67  68  69
70  71  72  73  74  75  76  77  -8  0
2  3  4  5  6  7  8  9  10  11
12  13  14  15  16  17  18  19  20  21
22  24  25  26  29  30  31  32  33  34
35  36  37  38  39  40  44  45  46  47
48  49  50  51  54  55  58  59  60  61
62  63  64  65  66  67  68  69  70  71
72  73  74  75  76  77  -8  0  2  3
4  5  6  7  8  9  10  11  12  14
15  16  17  18  19  20  21  22  24  25
29  30  31  32  33  34  35  36  37  38
39  40  43  44  45  46  47  48  49  50
51  54  55  58  59  60  61  62  63  64
65  66  67  68  69  70  71  72  73  74
75  76  77  -8  0  1  2  3  4  5
6  7  8  9  10  11  12  14  15  16
17  18  19  20  21  22  24  25  26  27
28  29  30  31  32  33  34  35  36  37
38  39  40  41  42  43  44  45  46  47
48  49  50  51  52  53  54  55  56  57
58  59  60  61  62  63  64  65  66  67
68  69  70  71  72  73  74  75  76  77
-8  0  1  2  3  4  5  6  7  8
9  10  11  12  13  14  15  16  17  18
19  20  21  22  24  25  27  28  29  30
31  32  33  34  35  36  37  38  39  40
41  43  44  45  46  47  48  49  50  51
52  53  54  55  56  57  58  59  60  61
62  63  64  65  66  67  68  69  70  71
72  73  74  75  76  77  -8  0  1  2
3  4  5  6  7  8  9  10  11  12
14  15  16  17  18  19  20  21  22  24
25  29  30  31  32  33  34  35  36  37
38  39  40  43  44  45  46  47  48  49
50  51  52  54  55  56  57  58  59  60
61  62  63  64  65  66  67  68  69  70
71  72  73  74  75  76  77  -8  0  1
2  3  4  5  6  7  8  9  10  11
12  13  14  15  16  17  18  19  20  21
22  23  24  25  26  27  28  29  30  32
33  34  35  36  37  38  39  40  41  42
43  44  45  46  47  49  50  51  52  53
54  55  56  57  58  59  60  61  62  63
64  65  67  68  69  70  71  72  73  74
75  76  77  -8  0  1  2  3  4  5
6  7  8  9  10  11  12  13  14  15
16  17  18  19  20  21  22  23  24  25
26  27  28  29  30  31  32  33  34  35
36  37  38  39  40  41  42  43  44  45
46  47  49  50  51  52  53  54  55  56
57  58  59  60  61  62  63  64  65  67
68  69  70  71  72  73  74  75  76  77
-8  0  1  2  3  4  5  6  7  8
9  10  11  12  13  14  15  16  17  18
19  20  21  22  23  24  25  26  27  28
29  30  31  32  33  34  35  36  37  38
39  40  41  42  43  44  45  46  47  48
49  50  51  52  53  54  55  56  57  58
59  60  61  62  63  64  65  66  67  68
69  72  73  74  75  76  77  -8  0  1
2  3  4  5  6  7  8  9  10  11
12  13  14  15  16  17  18  19  20  21
22  25  27  28  29  30  31  32  33  34
35  36  37  38  39  40  41  43  44  45
46  47  48  49  50  51  52  53  54  55
56  57  58  59  60  61  62  63  64  65
66  67  68  69  70  71  72  73  74  75
76  77  -8  0  1  2  3  4  5  6
7  8  9  10  11  12  13  14  15  16
17  18  19  20  21  22  23  24  25  26
27  28  29  30  33  34  35  36  37  39
40  41  42  43  44  45  46  47  48  49
50  51  52  53  54  56  57  58  59  60
61  62  63  64  65  66  67  68  69  73
74  75  76  -8  0  1  2  3  4  5
6  7  8  9  10  11  12  13  14  15
16  17  18  19  20  21  22  23  24  25
26  27  28  29  30  33  34  35  36  37
38  39  40  41  42  43  44  45  46  47
48  49  50  51  52  53  54  56  57  58
59  61  62  63  64  65  66  67  68  69
73  74  75  76  -8  0  1  2  3  4
5  6  7  8  9  11  12  13  14  15
16  17  18  19  20  21  22  23  24  25
26  27  28  29  34  36  37  39  40  41
42  43  45  48  49  50  51  52  53  54
56  57  58  59  62  65  66  73  74  76
-8  0  2  3  4  5  6  7  8  9
10  11  12  13  14  15  16  17  18  19
20  21  22  23  24  25  26  27  28  29
30  31  32  33  34  35  36  37  38  39
40  42  43  44  45  46  47  48  49  50
51  52  53  54  55  57  58  60  61  62
63  64  65  66  67  68  69  70  71  72
73  74  75  76  77  -8  0  2  3  4
5  6  7  8  9  10  11  12  13  14
15  16  17  18  19  20  21  22  23  24
25  26  28  29  30  31  32  33  34  35
36  37  38  39  40  42  43  44  45  46
47  48  49  50  51  52  53  54  55  57
58  60  61  62  63  64  65  66  67  68
69  70  71  72  73  74  75  76  77  -8
0  2  3  5  8  9  10  11  12  14
16  19  20  21  22  23  24  25  27  28
30  31  33  34  35  37  38  39  40  41
42  43  44  45  46  47  49  51  52  53
54  55  56  57  58  59  60  61  62  63
64  65  66  67  68  69  70  71  72  73
74  75  76  77  -8  0  5  6  7  8
9  10  11  12  13  14  15  16  17  18
19  20  21  22  23  24  25  26  27  28
29  30  31  32  33  37  38  39  40  41
42  43  44  45  46  47  48  49  50  51
52  53  54  55  56  57  58  59  60  62
63  64  65  67  68  69  70  71  72  73
74  75  76  77  -8  0  2  3  5  6
7  8  9  10  11  12  13  14  15  16
17  18  19  20  21  22  23  24  25  26
27  28  29  30  31  32  33  34  35  36
37  38  39  40  41  42  43  44  45  46
47  48  49  50  51  52  53  54  55  56
57  58  59  60  61  62  63  64  65  66
67  68  69  70  71  72  73  74  75  76
77  -8  0  1  2  3  4  5  6  7
8  9  10  11  12  13  14  15  16  17
18  19  20  21  22  23  24  25  26  27
28  29  30  31  32  33  34  35  36  37
38  39  40  41  42  43  44  45  46  47
48  49  50  51  52  53  54  55  56  57
59  60  61  62  63  64  65  66  67  68
69  70  72  73  74  75  76  77  -8  0
1  2  3  4  5  6  7  8  9  11
12  13  14  15  16  17  18  19  20  21
22  23  24  25  26  27  28  29  33  34
36  37  39  40  41  42  43  45  46  48
49  50  51  52  53  54  56  57  58  59
62  65  66  69  73  74  76  -8  0  1
2  3  4  5  6  7  8  9  11  12
13  14  15  16  17  18  19  20  21  22
23  24  25  26  27  28  29  34  36  37
39  40  41  42  43  45  48  49  50  51
52  53  54  56  57  58  59  62  65  66
69  73  74  76  -8  0  1  2  3  4
5  6  7  8  9  11  12  13  14  15
16  17  18  19  20  21  22  23  24  25
26  27  28  29  31  32  34  36  37  39
40  41  42  43  45  47  48  49  50  51
52  53  54  55  56  57  58  59  65  67
71  73  75  77  -8  0  1  2  3  4
5  6  7  8  9  10  11  12  13  14
15  16  17  18  19  20  21  22  23  24
25  26  27  28  29  30  31  32  33  34
35  36  37  38  39  40  41  42  43  44
45  46  47  48  49  50  51  52  53  54
55  56  57  58  59  60  61  62  63  64
65  67  68  69  70  72  73  74  75  76
77  -8  0  1  2  3  4  5  6  7
8  9  10  11  12  13  14  15  16  17
18  19  20  21  22  23  24  25  26  27
28  29  30  31  32  33  34  35  36  37
38  39  40  41  42  43  44  45  46  47
48  49  50  51  52  53  54  55  56  57
58  59  60  61  62  63  64  65  66  67
68  69  70  71  72  74  75  76  77  -8
0  1  2  3  4  5  6  7  8  9
10  11  12  13  14  15  16  17  18  19
20  21  22  23  24  25  26  27  28  29
31  32  33  34  35  36  37  38  39  40
41  42  43  44  45  46  47  48  49  50
51  52  53  54  55  56  57  58  59  60
61  62  63  64  65  66  67  68  69  70
71  72  73  74  75  76  77  -8  0  1
2  3  4  5  6  7  8  9  10  11
12  13  14  15  16  17  18  19  20  21
22  23  24  25  26  27  28  29  30  32
33  34  35  36  37  38  39  40  41  42
43  44  45  46  48  49  50  51  52  53
54  55  56  57  58  59  60  61  62  63
64  65  67  68  69  70  72  73  74  75
76  77  -8  0  1  2  3  4  5  6
7  8  9  10  11  12  13  14  15  16
17  18  19  20  21  22  23  24  25  26
27  28  29  30  32  33  34  35  36  37
38  39  40  41  42  43  44  45  46  47
48  49  50  51  52  53  54  55  56  57
58  59  60  61  62  63  64  65  67  68
69  70  71  72  73  74  75  76  77  -8
0  1  2  3  4  5  6  7  8  9
10  11  12  13  14  15  16  17  18  19
20  21  22  23  24  25  26  27  28  29
30  31  32  33  34  35  36  37  38  39
40  41  42  43  44  45  46  47  48  49
50  51  52  53  54  55  56  57  58  59
60  61  63  64  65  67  68  69  70  72
73  77  -8  0  1  2  3  4  5  6
7  8  9  10  11  12  13  14  15  16
17  18  19  20  21  22  23  24  25  26
27  28  29  30  32  33  34  35  36  37
38  39  40  41  42  43  44  45  46  47
48  49  50  51  52  53  54  55  56  57
58  59  60  61  62  63  64  65  67  68
69  70  72  73  74  75  76  77  -8  0
1  2  3  4  5  6  7  8  9  10
11  12  13  14  15  16  17  18  19  20
21  22  23  24  25  26  27  28  29  30
32  33  34  35  36  37  38  39  40  41
42  43  44  45  46  48  49  50  51  52
53  54  55  56  57  58  59  60  61  62
63  64  65  66  67  68  69  70  71  72
73  74  75  76  77  -8  0  1  2  3
4  5  6  7  8  9  11  12  13  14
15  16  17  18  19  20  21  22  23  24
25  26  27  28  29  31  32  34  36  37
39  40  41  42  43  44  45  47  48  49
50  51  52  53  54  55  56  57  58  59
63  65  67  71  73  74  75  -8  0  5
6  7  8  9  10  11  12  13  14  15
16  17  18  19  20  21  22  23  24  25
26  27  28  29  30  31  32  33  37  38
39  40  41  42  43  44  45  46  47  48
49  50  51  52  53  54  56  57  58  59
60  62  63  64  65  67  68  69  70  71
72  73  74  75  76  77  -8  0  1  2
3  4  5  6  7  8  9  10  11  12
13  14  15  16  17  18  19  20  21  22
23  24  25  26  27  28  29  30  31  32
33  34  35  36  37  38  39  40  41  42
43  44  45  46  47  48  49  50  51  52
53  54  55  56  57  58  59  60  61  62
63  64  65  67  68  69  70  71  72  73
74  75  76  77  -8  0  1  2  3  4
5  6  7  8  9  10  11  12  13  14
15  16  17  18  19  20  21  22  23  24
25  26  27  28  29  30  31  32  34  35
36  37  38  39  40  41  42  43  44  45
46  47  48  49  50  51  52  53  54  55
56  57  58  59  60  61  62  63  64  65
66  67  68  69  70  71  72  73  74  75
76  77  -8  0  2  3  5  8  9  10
11  12  14  16  19  20  21  22  23  24
25  27  28  30  31  33  34  35  37  38
39  40  41  43  44  45  46  47  49  51
52  53  54  55  56  57  58  59  60  61
62  63  64  65  66  67  68  69  70  71
72  73  74  75  76  77  -8  0  2  3
5  6  7  8  9  10  12  13  14  15
16  17  18  19  20  21  22  23  24  25
26  27  28  29  30  31  32  33  34  35
36  37  38  39  40  41  42  43  44  45
46  47  48  49  50  51  52  53  54  55
56  57  58  59  60  61  62  63  64  65
66  67  68  69  70  71  72  73  74  76
77  -8  0  1  2  3  4  5  6  7
8  9  10  11  12  13  14  15  16  17
18  19  20  21  22  23  24  25  26  27
28  29  30  31  32  33  34  35  36  37
38  39  40  41  42  43  44  45  46  47
48  49  50  51  52  53  54  55  56  57
58  59  60  61  62  63  64  66  67  68
69  70  71  72  73  74  75  76  77  -8
0  1  2  3  4  5  6  7  8  9
10  11  12  13  14  16  17  18  19  20
21  22  23  24  25  26  27  28  29  30
31  32  33  34  35  36  37  38  39  40
41  42  43  44  45  46  47  48  49  50
51  52  53  54  55  56  57  58  59  60
61  62  63  64  65  66  67  68  69  70
71  72  73  74  75  76  77  -8  0  1
2  3  4  5  6  7  8  9  10  11
12  13  14  15  16  17  18  19  20  21
22  23  24  25  26  27  28  29  30  31
32  33  34  35  36  37  38  39  40  41
42  43  44  45  46  47  48  49  51  52
53  54  55  56  57  58  59  60  61  62
63  64  65  66  67  68  69  70  71  72
73  74  75  76  77  -8  0  1  2  3
4  5  6  7  8  9  10  11  12  13
14  15  16  17  18  19  20  21  22  23
24  25  26  27  28  30  31  32  33  34
35  36  37  38  39  40  41  42  43  44
45  46  47  48  49  50  51  52  53  54
55  56  57  58  59  60  61  62  63  64
65  66  67  68  69  70  71  72  73  74
75  76  77  -8  0  2  3  4  5  6
7  8  9  10  11  12  13  14  15  16
17  18  19  20  21  22  23  24  25  26
27  28  29  30  31  32  33  34  35  36
37  38  39  40  41  42  43  44  45  46
47  48  49  50  51  52  53  54  55  56
57  58  59  60  61  62  63  64  65  66
67  68  69  70  72  73  74  75  76  77
-8  0  1  2  3  4  5  6  7  8
9  10  11  12  13  14  15  16  17  18
19  20  21  22  23  24  25  26  27  28
29  30  31  32  33  34  35  36  37  38
39  40  41  42  43  44  46  47  48  49
50  51  52  53  54  55  56  57  58  59
60  61  62  63  64  65  66  67  68  69
70  71  72  73  74  75  76  77  -8  0
2  3  5  6  7  8  9  10  11  12
13  14  15  16  17  18  19  20  21  22
23  24  25  26  27  28  29  30  31  32
33  34  35  36  37  38  39  40  41  42
43  44  45  46  47  48  49  50  51  52
53  54  55  56  57  58  59  60  61  62
63  64  65  66  67  68  69  70  72  73
74  75  76  77  -8  0  2  3  5  6
7  8  9  10  11  12  13  14  15  16
17  18  19  20  21  22  23  24  25  26
27  28  29  30  31  32  33  34  35  36
37  38  39  40  41  42  43  44  45  46
47  48  49  50  51  52  53  54  55  56
57  59  60  61  62  63  64  65  66  67
68  69  70  72  73  74  75  76  77  -8
0  5  6  7  8  9  10  11  12  13
14  15  16  17  18  19  20  21  22  23
24  25  26  27  28  29  30  31  32  33
37  38  39  40  41  42  43  44  45  46
47  48  50  51  52  53  54  55  56  57
58  59  60  62  63  64  65  67  68  69
70  71  72  73  74  75  76  77  -8  0
2  3  5  6  7  8  9  10  11  12
13  14  15  16  17  18  19  20  21  22
23  24  25  26  27  28  29  30  31  32
33  34  35  36  37  38  39  41  42  43
44  45  46  47  48  49  50  51  52  53
54  55  56  57  58  59  60  61  62  63
64  65  66  67  68  69  70  71  72  73
74  75  76  77  -8  0  1  2  3  4
5  6  7  8  9  10  11  12  13  14
15  16  17  18  19  20  21  22  23  24
25  26  27  28  29  30  31  32  33  35
36  37  38  39  40  41  42  43  44  45
46  47  48  49  50  51  52  53  54  55
56  57  58  59  60  61  62  63  64  65
66  67  68  69  70  71  72  73  74  75
76  77  -8  0  1  2  3  4  5  6
7  9  10  12  13  14  15  16  17  18
20  21  22  23  24  25  26  27  28  29
30  31  32  33  35  36  37  38  39  40
41  42  46  47  48  49  50  51  52  53
54  55  56  57  58  59  60  61  62  63
64  65  67  68  69  70  71  72  73  74
75  76  77  -8  0  2  3  4  5  6
7  8  9  10  11  12  14  15  16  17
18  19  20  21  22  24  25  29  30  31
32  33  34  35  36  37  38  39  40  43
44  45  46  47  48  49  50  54  55  58
59  60  61  62  63  64  65  66  67  68
69  70  71  72  73  74  75  76  77  -8
0  1  2  3  4  5  6  7  9  10
12  13  14  15  16  17  18  20  21  22
23  24  25  26  27  28  29  30  31  32
33  34  35  36  37  38  39  40  41  42
45  46  47  48  49  50  51  52  53  54
55  56  57  58  59  60  61  62  63  64
65  67  68  69  70  71  72  73  74  75
76  77  -8  0  2  3  4  5  6  7
8  9  10  11  12  14  15  16  17  18
19  20  21  22  23  24  25  29  30  31
32  33  35  36  37  38  39  40  43  44
45  46  47  48  49  50  54  55  58  59
60  61  62  63  64  65  66  67  68  69
70  71  72  73  74  75  76  77  -8  0
2  3  4  5  6  7  8  9  10  11
12  13  14  15  16  17  18  19  20  21
22  24  25  26  29  30  31  32  33  35
36  37  38  39  40  44  45  46  47  48
49  50  51  54  55  58  59  60  61  62
63  64  65  66  67  68  69  70  71  72
73  74  75  76  77  -8  0  1  2  3
4  5  6  7  8  9  10  11  12  13
14  15  16  17  18  19  20  21  22  23
24  25  26  27  28  29  30  31  32  33
34  35  36  37  38  39  40  41  42  44
45  46  47  48  49  50  51  52  53  54
55  56  57  58  59  60  61  62  63  64
65  66  67  68  69  70  71  72  73  74
75  76  77  -8  0  1  2  3  4  5
6  8  9  10  11  12  13  14  15  16
17  19  20  21  22  23  24  25  26  27
28  29  30  31  32  33  34  35  36  37
38  39  40  41  42  43  44  45  46  47
48  49  50  51  52  53  55  56  57  59
60  61  62  63  64  65  66  67  68  69
70  71  72  73  74  75  76  77  -8  0
1  2  3  4  5  6  7  8  9  10
11  12  13  14  15  16  17  19  20  21
22  23  24  25  26  27  28  29  30  31
32  33  34  35  36  37  38  39  40  41
42  43  44  45  46  47  48  49  50  51
52  53  54  55  56  57  58  59  60  61
62  63  64  65  66  67  68  69  70  71
72  73  74  75  76  77  -8  0  5  6
7  8  9  10  11  12  13  14  15  16
17  18  19  20  22  23  24  25  26  27
28  29  30  31  32  33  37  38  39  40
41  42  43  44  45  46  47  48  49  50
51  52  53  54  55  56  57  58  59  60
62  63  64  65  67  68  69  70  71  72
73  74  75  76  77  -8  0  1  2  3
4  5  6  7  8  9  10  11  12  13
14  15  16  17  18  19  20  22  23  24
25  26  27  28  29  30  31  32  33  34
35  36  37  38  39  40  41  42  43  44
45  46  47  48  49  50  51  52  53  54
55  56  57  58  59  60  61  62  63  64
65  66  67  68  69  70  71  72  73  74
75  76  77  -8  0  2  3  4  5  6
7  8  9  10  11  12  13  15  16  17
18  19  20  21  22  23  24  25  26  27
28  29  30  31  32  33  34  35  36  37
38  39  40  41  42  43  44  45  46  47
48  49  50  51  52  53  54  55  56  57
58  59  60  61  62  63  64  65  66  67
68  69  70  71  72  73  74  75  76  77
-8  0  1  2  3  4  5  6  7  8
9  10  11  12  13  15  16  17  18  19
20  21  22  23  24  25  26  27  28  29
30  31  32  33  34  35  36  37  38  39
40  41  42  43  44  45  46  47  48  49
50  51  52  53  54  55  56  57  58  59
60  61  62  63  64  65  66  67  68  69
70  71  72  73  74  75  76  77  -8  0
5  6  7  8  9  10  11  12  13  14
15  16  17  18  19  20  21  22  23  24
25  26  27  28  29  30  31  32  33  37
38  39  40  41  42  43  44  45  46  47
48  49  50  51  52  53  54  55  56  57
58  59  60  62  63  64  67  68  69  70
71  72  73  74  75  76  77  -8  0  2
3  4  5  6  7  8  9  10  11  12
13  14  16  17  18  19  20  21  22  24
25  26  27  28  29  30  31  32  33  34
35  37  38  39  40  41  42  43  44  45
46  47  48  49  50  51  52  53  54  55
56  57  58  59  60  61  62  63  64  65
66  67  68  69  70  71  72  73  74  75
76  77  -8  0  2  3  5  6  7  8
9  10  11  13  14  15  16  17  18  19
20  21  22  24  25  26  27  28  29  30
31  32  33  34  35  36  37  38  39  40
41  42  43  44  45  46  47  48  49  50
51  52  53  54  55  56  57  58  59  60
61  62  63  64  65  66  67  68  69  70
71  72  73  74  75  76  77  -8  0  5
6  7  8  9  10  11  12  13  14  15
16  17  18  19  20  21  22  23  24  25
26  27  28  29  30  31  32  33  37  38
39  40  41  42  43  44  45  46  47  48
49  50  51  52  53  54  55  56  57  58
59  60  62  63  64  65  67  68  69  70
72  73  74  75  76  77  -8  0  2  3
5  6  8  9  10  11  12  13  14  15
16  17  19  20  21  22  23  24  25  26
27  28  29  30  31  32  33  34  35  36
37  38  39  40  41  42  43  44  45  46
47  48  49  50  51  52  53  55  56  57
59  60  61  62  63  64  65  66  67  68
69  70  71  72  73  74  75  76  77  -8
0  2  3  4  5  6  7  8  9  10
11  12  13  15  16  17  18  19  20  21
22  23  24  25  26  27  28  29  30  31
32  33  34  35  36  37  38  39  40  41
42  43  44  45  46  47  48  49  50  51
52  53  54  55  57  58  59  60  61  62
63  64  65  66  67  68  69  70  71  72
73  74  75  76  77  -8  0  2  3  4
5  6  7  8  9  10  11  12  13  14
15  16  17  18  19  20  21  22  23  24
25  26  27  28  29  30  31  32  33  34
35  36  37  38  39  40  41  42  43  44
45  46  47  48  49  50  51  52  53  54
55  57  58  59  60  61  62  63  64  65
66  67  68  69  70  71  72  73  74  75
76  77  -8  0  5  6  7  8  9  10
11  13  14  15  16  17  18  19  20  21
22  23  24  25  26  27  28  29  30  31
32  33  37  38  39  40  41  42  43  44
46  47  48  49  50  51  52  53  54  55
56  57  58  59  60  62  63  64  65  67
68  69  70  71  72  73  74  75  76  77
-8  0  5  6  7  8  9  10  11  12
13  14  15  16  17  18  19  20  21  22
23  24  25  26  27  28  29  30  31  32
33  37  38  40  41  42  43  44  45  46
47  48  49  50  51  52  53  54  55  56
57  58  59  60  62  63  64  65  67  68
69  70  71  72  73  74  75  76  77  -8
0  2  3  5  6  7  8  9  10  11
12  13  14  15  16  17  18  19  20  21
22  23  24  25  26  27  28  29  30  31
32  33  34  35  36  37  38  40  41  42
43  44  45  46  47  48  49  50  51  52
53  54  55  56  57  58  59  60  61  62
63  64  65  66  67  68  69  70  71  72
73  74  75  76  77  -8  0  1  2  3
4  5  6  7  8  9  10  11  12  13
14  15  16  17  18  19  20  21  22  23
24  25  26  28  29  30  31  32  33  34
35  36  37  38  39  40  41  42  43  44
45  46  47  48  49  50  51  52  53  54
55  56  57  58  59  60  61  62  63  64
65  66  67  68  69  70  71  72  73  74
75  76  77  -8  0  2  3  5  6  7
8  10  11  12  13  14  15  16  17  18
19  20  21  22  23  24  25  26  27  28
29  30  31  32  33  34  35  36  37  38
39  40  41  42  43  44  45  46  47  48
49  50  51  52  53  54  55  56  57  58
59  60  61  62  63  64  65  66  67  68
69  70  71  72  73  74  75  76  77  -8
0  2  4  5  6  7  8  9  10  11
12  13  14  15  16  17  18  19  20  21
22  23  24  25  26  27  28  29  30  31
32  33  34  35  36  37  38  39  40  41
42  43  44  45  46  47  48  49  50  51
52  53  54  55  56  57  58  59  60  61
62  63  64  65  66  67  68  69  70  71
72  73  74  75  76  77  -8  0  5  6
7  8  9  10  11  12  13  14  15  16
17  18  19  20  21  22  23  24  25  26
27  28  29  30  31  32  33  37  38  40
41  42  43  44  45  46  47  48  49  50
51  52  53  54  55  56  57  58  59  60
62  63  64  65  67  68  69  71  72  73
74  75  76  77  -8  0  1  2  3  4
5  6  7  8  9  10  11  12  13  14
15  16  17  18  19  20  21  22  23  24
25  26  27  28  29  30  31  32  33  34
35  36  38  39  40  41  42  43  44  45
46  47  48  49  50  51  52  53  54  55
56  57  58  59  60  61  62  63  64  65
66  67  68  69  70  71  72  73  74  75
76  77  -8  0  1  2  3  4  5  6
7  8  9  10  11  12  13  14  15  16
17  18  19  20  21  22  23  24  25  26
28  29  30  31  32  33  34  35  36  37
38  39  40  42  43  44  45  46  47  48
49  50  51  52  54  55  56  57  58  59
60  61  62  63  64  65  66  67  68  69
70  71  72  73  74  75  76  77  -8  0
2  3  5  8  9  10  11  12  14  16
19  20  22  23  24  25  27  28  30  31
33  34  35  37  39  40  41  43  44  45
46  47  49  51  52  53  54  55  56  57
58  59  60  61  62  63  64  65  66  67
68  69  70  71  72  73  74  75  76  77
-8  0  1  2  3  4  5  6  7  8
9  10  11  12  13  14  15  16  17  18
19  20  21  22  23  24  25  26  29  30
31  32  33  34  35  36  37  38  39  40
42  43  44  45  46  47  48  49  50  52
53  54  55  56  58  60  61  62  63  64
65  66  67  68  69  70  71  72  73  74
75  76  77  -8  0  2  3  5  6  7
8  9  10  12  13  14  15  16  17  18
19  20  21  22  23  24  25  26  27  28
29  30  31  32  33  34  35  36  37  38
39  40  41  42  43  44  45  46  47  48
49  50  51  52  53  54  55  56  57  58
59  60  61  62  63  64  65  66  67  68
69  70  71  72  73  74  75  76  77  -8
0  1  2  3  4  5  6  7  8  9
10  11  12  14  15  16  18  19  20  21
22  23  24  25  27  28  29  30  31  33
34  35  36  37  38  39  40  41  42  43
44  45  46  47  48  49  50  51  52  53
54  55  56  57  58  59  60  61  62  63
64  65  66  67  68  69  70  71  72  73
74  75  76  77  -8  0  2  3  5  6
7  8  9  10  12  13  14  15  17  18
19  20  21  22  23  24  26  27  28  29
30  31  32  33  34  35  36  37  38  39
40  41  42  43  44  45  46  47  48  49
50  51  52  53  54  55  56  57  58  59
60  61  62  63  64  65  66  67  68  69
70  71  72  73  74  75  76  77  -8  0
2  3  5  6  7  8  9  10  11  12
13  14  15  16  17  18  19  20  21  22
23  24  25  26  27  28  29  31  32  33
34  35  36  37  38  39  41  42  43  44
45  46  47  48  49  50  51  52  53  54
55  56  57  58  59  60  61  62  63  64
65 66 67 68 69 70 71 72 73 74
75 76 77 -8  0  2  3  4  5  6
7  8  9 10 11 12 13 14 15 16
17 18 19 20 21 22 23 24 25 26
27 28 29 30 31 32 33 34 35 36
37 38 39 40 41 42 43 44 45 46
47 48 49 50 51 52 53 54 55 56
57 58 59 60 61 62 63 64 65 67
68 69 70 71 72 73 74 75 76 77
-8  0  2  3  4  5  6  7  8  9
10 11 12 13 14 16 17 18 19 20
21 22 24 25 26 27 28 29 30 31
32 33 34 35 37 38 39 40 41 42
43 44 45 46 47 48 49 50 51 52
53 54 55 56 57 59 60 61 62 63
64 65 66 67 68 69 70 71 72 73
74 75 76 77 -8 -9  0  1  3  5
6  6  6  6  6  6  6  8 10 12
14 15 17 18 20 22 24 26 27 29
31 31 31 31 31 32 33 33 34 35
36 37 38 38 38 38 38 39 40 41
41 43 44 44 44 44 44 44 44 44
44 44 44 44 44 44 44 44 44 44
45 46 47 48 48 49 50 51 51 52
53 54 55 55 55 55 55 56 56 57
58 58 58 58 59 61 61 61 63 64
64 64 64 64 65 65 65 66 66 67
67 67 69 69 69 70 71 72 73 73
74 75 77 77 79 80 81 81 81 81
81 81 81 81 81 81 81 81 81 81
82 82 83 83 83 83 83 83 83 83
83 83 83 83 83 84 85 85 85 87
89 89 89 89 89 89 89 89 89 89
89 90 91 92 92 93 93 94 95 96
96 97 98 99  100  101  102  103  104  105
105  105  105  106  106  106  107  108  109  110
111  111  112  112  112  112  112  112  112  114
114  114  114  114  114  114  115  115  115  115
115  115  115  116  117  117  117  117  117  118
119  119  119  119  119  120  121  121  121  121
122  123  123  123  124  125  125  125  126  127
128  128  128  129  130  130  130  130  131  131
132  132  132  132  132  132  132  132  132  132
132  132  132  133  134  135  136  137  137  137
137  137  137  137  137  137  137  137  138  138
138  138  138  138  139  140  141  141  141  141
141  141  141  141  141  142  143  143  143  143
143  143  143  144  145  146  147  147  148  148
148  149  149  149  149  149  149  149  149  149
149  149  149  150  151  152  153  153  154  154
155  155  156  156  157  158  159  159  160  160
161  161  161  161  161  161  161  161  161  161
161  161  162  162  162  162  162  162  162  162
162  162  162  162  163  163  163  163  163  163
164  164  164  164  164  164  164  165  166  166
166  166  166  166  166  166  166  166  166  166
166  166  167  167  167  167  167  167  167  167
167  167  167  168  169  169  169  169  169  169
169  169  169  169  169  169  169  169  169  169
169  169  169  169  169  169  169  169  169  169
169  169  169  169  169  169  169  169  169  169
169  169  169  170  170  170  170  170  172  172
172  173  173  173  173  173  173  173  173  173
173  173  173  173  173  173  175  175  175  176
177  177  177  177  177  177  177  178  179  180
180  180  180  -10  1  276  277  276  278  279
280  278  281  278  282  278  283  278  284  278
278  285  278  278  285  278  286  278  287  278
285  278  278  285  278  285  288  288  288  288
288  288 12  289  289  290  291  290  291 26
28 26  292  293  294  295  288  288  288  288
296  297  297  298  289  299  299  289  300  299
301  301  301  299  302  299  303  299  299  304
59 58 64  305  306  306  307  308  309  308
278  279  278  279  310  311  312  313  314  314
315  316  296  317  318  280  280  280  280  280
314  319  320  321  322  323  117  324  325  326
327  328  329  330  134  280  331  280  134  331
280  331  332  280  332  134  280  278  278  278
278  278  297  278  278  278  333  333  333  333
334  333  335  336  337  338  297  339  297  297
340  297  297  159  297  278  341  297  336  342
343  341  278  278  280  278  279  344  324  325
345  345  342  278  278  -11 53  1 70  3
122  5  113  7 68  1  102  1 21  3
8  2 68  2 25  6 25  6 70  5
98  2 68  1 21  3 39  3 10  3
10  3 81  2 94  1  115  3  121  2
56  2 97  1 23  1 45  1 48  2
45  3 97  3 23  3 22  3 22  3
92  4 92  4 90  3 90  3 20  4
20  4 91  3 91  3 24  1 24  3
68  1  102  1 33  1 77  1 41  6
41  2 29  1 41  2 29  1 29  1
33  1 77  1 16  1 16  3 12  1
98  2 36  2 68  1 21  3 81  1
38  2 36  1  2  3  2  2 41  2
66  1 41  2 66  1 77  1 15  3
15  3 50  2 66  1 82  1 82  3
101  5  101  5 47  4 47  4  124  5
51  2  117  2  112  3 61  4 60  2
60  2  120  1 42  5 72  2 66  1
77  1  117  1 40  2 66  1 76  2
78  2 72  2 65  1 57  2 76  2
78  2 80  1 56  4 56  5 27  1
27  3 84  2 86  1 86  3 88  1
88  3  123  1  123  3 93  3  5  1
99  1 99  3  9  1 97  1 97  3
103  2 96  1 96  3 68  1  102  1
26  1 26  3 94  1  6  1  6  2
117  2 37  1  4  1  7  1 79  1
4  3 37  3 85  1 49  3 49  3
37  3 94  1 94  1 94  1 85  1
37  1  4  1 79  1  4  3 37  3
37  3  103  1  108  1  108  2 35  6
35  4 35  3 28  4  110  1  119  1
94  1 36  1 87  1  109  2  109  1
104  1  104  2 68  4  110  1  119  1
13  1  116  1  102  2  102  2  105  3
102  2  116  1  119  1 13  1 13  1
110  1 14  3  4  4  115  5 14  5
94  3 67  3 68  3 95  3 37  4
102  3 37  3 83  7 83  4  3  4
32 11  3  8 31  9 66  5 18  4
75  6 63  3  120  4 66  6 66  6
120  3 75  5 53  3 66  6 66  6
120  3 66  5 66  5  120  2 66  4
43  6 43  6 44  6  100  4  107  7
46  2 66  6 66  6 66  6 66  6
46  5 46  5  120  3 73  3 66  4
66  6  100  3 43  2 43  3 30  8
100  2  100  6  120  3 44  3 44  2
120  2  120  4 69  5 69  4 53  9
53  6 71  3 52  7 53  7 53  6
66  4 66  4 53  9 51  2  120  2
75  9  120  2 53 10 53  9 53  8
34  6 34  6 34  3 60  2  100  4
71  6  110  1  116  1  116  1  106  4
116  1  116  1 59  3 40  0  1  1
106  0 62  0  5  0 54  5 19  5
89  5 55  2 58  0 62  1 54  0
48  0 12  0 36  1 21  1  107  0
17  1 17  1 17  1 78  0 72  0
87  1 94  1  111  1  9  1 64  3
94  2 64  1 97  1 42  0 52  0
55  0 61  0  114  2  114  0 74  1
112  0 76  0  114  4 74  3 74  5
74  3 58  2 17  1 17  1 17  1
93  1 57  0 56  0  121  0 11  2
11  1  118  3  118  1  122  0 67  0
7  0 80  0 89  0  111  0  109  1
124  0 19  0 84  0 59  0 50  0
18  0 65  0  109  0  -12  5  1  8
3  1  5  2  5  4  1  7  1  3
5  3  1  6  1 12  1  1  5  1
5  1  5  1  5  4  5  1  5  5
5  1  5  1  5  1  5  1  5  6
5  1  5  1  5 13  1 16  1 19
1  4  1  7  5  7  5 22  1  7
5  7  5  7  5  7  5  8  5  3
1 25  1 28  1 31  1  9  5  9
5 10  5  3  1 11  5  9  5 12
5 13  5 14  5  6  1 15  5 12
5 16  5  3  1  7  1 34  1  4
1 37  1 40  1 43  1  9  1  6
1 46  1 17  5 18  5 19  5  5
1  8  5 20  5 10  5 21  5 22
5  7  5  7  5  7  5  7  5  9
1  6  1  6  1 49  1  5  1 23
5 24  5  5  1 25  5 25  5 23
5 23  5  9  5 26  5 27  5  1
5 23  5 25  5 28  5 29  5 17
5 30  5  1  5 18  5 20  5 19
5 10  5 31  5 24  5  9  5 32
5 23  5 23  5 30  5 23  5 30
5 25  5 33  5 23  5  1  5 85
1  1  5 15  5 15  5 33  5 18
1 88  1 91  1 94  1 97  1  100
1  103  1  106  1 12  5 25  5  7
5 24  1 10  5 33  1 14  5 15
1 24  1  3  1  3  1  3  1  9
1  9  1 18  1 27  1 48  1  3
1  3  1  5  1 14  5  6  1  6
1  1  5  1  5 14  5 15  5  6
5 30  5 24  1  118  1  121  1 16
5  127  1  124  1  2  5  2  5 28
5  6  1 33  5 15  1  5  1  5
1 34  5 15  5 34  5  5  1 14
5 14  5  6  5  7  5  7  5  7
5  6  5  130  1  3  1  4  5  5
3 28  5 25  5 14  5 20  5 20
5 21  5 34  5  7  1 35  5  5
5 29  5  133  1  136  1 22  5 22
5  8  5 23  5 12  5  4  1  4
1 12  5  139  1 34  5 45  1  142
1  145  1 51  1  148  1 12  5 36
5 36  5 12  5  151  1  154  1  157
1  2  5  2  5  3  1  160  1  163
1  4  5 16  5 35  5  6  1  4
1  3  1 37  5  7  5 22  5  5
5  8  5 37  5 15  1 21  1 22
5 37  5 36  5 14  5 30  1  7
5 36  5 33  1 31  5 36  1  8
5 27  1 13  5 45  1 11  5  4
1  7  1  4  1 12  5 12  5 12
1 15  1 12  5  3  1 12  5  1
5  1  5  1  5  1  5  1  5 18
1 45  1 48  1 78  1  169  1  172
1  4  1 12  5 12  5 30  5  5
1 12  5  4  1 12  5  7  1 12
5  1  5  1  5  1  5 12  5 12
5 12  5  3  1  3  1  3  1  6
1  3  1 33  5 33  5  9  1  175
1  6  1  4  1  3  1  4  1 33
5 33  5  9  5 33  5 15  1  5
1  178  1 38  5 23  5 24  1  4
1  9  5  9  5  9  5  9  5  9
5  4  1  184  1 12  5 12  5 36
5  5  1  5  1  5  1  6  1 31
5  5  5 36  5  4  5  5  1  4
1  5  1  5  1 16  5  9  1 36
5  7  1  1  5 12  5  4  1  4
1  4  1  4  1  4  1  7  1  187
1  190  1  4  1  4  1 15  5  3
1 12  5 12  5 12  1 11  5 60
1 12  1  7  5 72  1 17  5 93
1  5  1 30  1 33  1 51  1 66
1 87  1 23  5 12  5 10  1 12
5 13  1 12  5  193  1 36  5 36
5  4  1  4  1  4  1  4  1  4
1  4  1  4  1 12  5  4  1 12
5  199  1  202  1  205  1 12  5  208
1  211  1  214  1 33  1 63  1 19
5 29  5  3  1 29  5  217  1  1
5  1  5 12  5 12  5 42  1 57
1 69  1 12  5  4  1 12  5 12
5 23  5 12  5 12  5 12  5  9
1  4  1 12  5 12  5 18  5 25
5 12  5 21  1 31  1  220  1 14
5 14  5 13  5  3  1 12  5 12
5 36  1 84  1 12  5 12  5  4
1 15  5 23  5 12  5 12  5  7
5  3  1  6  1 23  5  223  1  1
5 36  1 84  1 15  5 13  5 12
5  4  1 12  5 12  5 12  5 15
5 25  1 28  1  4  1  4  3  4
3  4  1  4  1 14  5 23  5 12
5  1  5  1  5 12  5 12  5 12
5 12  5 34  5 31  1 36  5  1
5  1  5 12  5 12  5 12  5 12
5  -13  1  225  133  5  4  0  143  2
4  0  144  2  2  0  145  5  3  0
147  5  5  0  152  2  4  256  152  5
5  257  152  5  3  258  152  2  4  0
152  2  6  259  153  5  3  262  153  2
7  263  153  5  8  266  153  5  9  271
153  5 10  275  153  5  8  279  153  5
4  281  153  5  5  282  153  5 11  283
153  5 11  285  153  5 12  287  153  5
13  288  153  5 14  292  153  5  9  293
153  5  3  310  153  2 15  311  153  5
4  314  153  5  4  315  153  5 10  317
153  5 16  0  153  5  4  322  154  5
17  323  154  5 18  325  154  5 19  327
156  5  3  342  159  2 20  343  159  5
21  344  160  5 22  345  161  5  2  350
161  5 17  351  162  5 26  353  163  5
13  355  163  5 17  0  163  5 23  0
165  5 24  360  167  5 15  366  167  5
25  367  167  5 10  368  169  5  4  373
169  5 26  374  169  5 27  379  169  5
21  0  170  5 27  382  171  5 28  387
171  5  3  391  171  2 10  392  171  5
7  396  171  5 25  400  171  5 24  401
171  5  5  405  171  2 19  406  171  5
3  410  171  5  4  413  171  5 25  415
171  5  4  420  171  5 23  421  171  5
29  423  171  5 30  0  171  5 11  425
173  5  5  427  173  5 18  0  173  5
4  428  174  5 31  429  174  5 18  0
178  5 32  431  179  5 30  0  179  5
28  443  181  5 33  0  181  5 21  0
182  5 34  445  183  5 14  446  183  5
35  451  194  5 21  0  268  5 18  0
269  5 12  455  270  5 18  0  270  5
5  0  271  5 18  0  272  5 23  465
273  5 36  474  273  5 31  478  273  5
18  0  273  5 37  480  274  5  -14  5
0  5  5  5  0  0  5  8  5  6
8  8  8  3  0  5  6  0  5  5
0  7  0  8  9  0  5  0  5  3
27  5  5 67  3  5 75  5  6  6
5  5  0  0  5  3  3  5  5  5
3  4  0  5  5  5  4  0  0  6
3  5  5  5  5  5  0  6  5  0
5  5  5  0  0  0  0  0  0  0
0  0  0  0  3  0  0  0  0  0
0  0  0  0  0  0  0  0  0  0
0  0  0  0  0  0  0 10  0  0
5  0  5  5  5  0  0  5 12  5
3 27  0 19  3  0  5  0  0  5
0  0  6  0  4 12  0  5  0  0
0 12  0  0  6  0  0  5  0  5
5  5  0  0  5 21  5  6 27  0
25  3  0  5  0  0  5  0  3 12
0  4 15  6  5  0  0  0  9  0
0  9  0  0  5  0  5  5  5  0
0  5 39  5  0 30  0  0  3  0
5  0 42  5  0  0  0  0  0  0
0  5  0  0  0 24  0  0 12  0
0 60  0  0  0  0  0  0  0  9
0  0 24  0  5  0  0  0  0 12
0  0  0 18  0  0  0  5  5  0
0  0 24  0  0  5  9  0 39  5
4  3  3  5  0  5 30 12  5  5
5  5  0  0  6  5  4  8  5  0
15  0  6  0  5  9  5  5  5  5
5  5  5  5 21 13  3 10  0  8
5  0  0  0  0  6  5  5  5  0
0  0  4  5  5  8  0  0  0  0
15  5  0  5  8  3 27  8  8  5
5  5  9  0  0  0  3  3  0  0
5  9  6  5  9  5  0  0  0  0
5  5  0  0  0  0  5 15  5  5
3  0  6 27  0  0  5  5  5 90
3  0  0  3  5  0  0  9  0  0
5  5  5  0  0  0  4  0  0  0
0  0  0  0  0  0  8  5  0  0
36  0  0  166  0  8  4  4  4  0
5  0  9  6  0  0  0 24  9 34
9  0  4  0  9  0  0 15  3  0
15  0  9  6  0  4 10 30  0  0
196  6 15 22  7  0  0  0  0  0
0  0  0  0 15  0  4  0  0  0
0 39  0  0  0  0  0  0  0  5
0  0  0  0 24  0  0  5  0  0
12  4  4  3  0  0  0  5  5  6
0 30  3  3  3  4  4  0 45  8
0 15  0  3  9  0 12  6  0  4
0 30  0  0  109  0  3 81  4  4
6  5  0  5  0 42  5  0 30  0
0  3  5  4  0  0  0  0 15  5
5 15  0  0  6  0  4  0 30  0
0  112  0 12  5  5  5  5  5  5
5  5  0  5  5 27  5  5  5  5
0  5  0  0  5  6 27  5  5  5
15  6  5  5  5  5  5  5  124  0
 18 90  0  0  0  0  0  0  0 12
  0  6  5  0 10  0  0  0  0  0
  0  0  0  0  0  0  0  0  0  0
  0  6 27  0  0 64  0  0 16  0
 13  0  0  0  0  0  0  0  6  5
  0 13  0  0  0  0  0  0  0  0
  0  0  0  0  0  0  0  0  6 27
  0  0 70  0  0 27  0  3  0  0
  0  0  0  6  0  6  5  0 16  0
  0  0  0  0  0  0  0  0  0  0
  0  0  0  0  0  6 27  0  0 73
  0  0  0  0  0  0  0  9  0  0
  0  0  6  5 12  5  0  0  0  0
  5  5  0  0  0  0  0 15  3  0
  6  0  6 27  0  0  5  5  5  0
  0  0  0  0  6  0  0  0  0  0
  5 15  5  0  0  0  0  5  5  0
  0  0  0  0  0  0  0  0  0  0
  0  0  0  5  0  5 84  0  9  0
  0  0  0  0  0 12  0 21  0 15
  0  0  0  0 10  0  0  0  3 15
  0  0  0  0  0  0  0 24  0  0
  5  0  0  4  5  4  3  5  5  3
  3 36  6  6  5  5  5  6  0  7
  5  5  5  5  0  0  9  5  5  5
  5  5  5  6 27  5  5  5  5  5
  5  0  5  5  0  0  9  5  0  5
  6  0  0  0  5  5  0  0  0  0
  0  0  0  5  5  0  0  0  0  0
  6 27  0  0 79  0  0 19  0 16
  0  0  0  0  0  0  0  6 24  0
 12  0  0  0  0  3  0  0  0  9
  0  0  6  0  3  0  0  6 27  0
  0 58  0  9  0  0  0  0  0  0
  0  0  0  0  6  0  0  0  0  0
  0  0  0  0  0  0  0  0  0  0
  0  0  0  0  6 27  0  0 52  0
  0  0  0  0  0  0  0  0  0  0
  0  6  0  0  0  0  0  0  0  0
  0  0  0  0  0  0  0  0  0  0
  0  6 27  0  0 55  0  0 75  0
  6  6  0  0  0  5  5 15  6  3
  0 22  3  4  0  0  0  0  0  0
  0 12  3  0  0  0  0  0  6 27
  0  0  3  0  0 54  0  3  0  0
  0  0  0  6  0  6 12  0 28  0
  0  0  0  0  0  0  0  0  0  0
  0  0  0  0  0  6 27  0  0 61
  0  0  4  5  4  0  5  5  0  0
  0  0  6  5  5  5  0  0  0  5
 18  0  5  0  0  0  0 15  0  5
  5  5  3 27  5  5  115 12  5  5
  0  5  5  0  0  3  5  0  5  6
 27  0  0  5  5  0  0  0  0  0
  0 21  5  5  0  0  0  0  0  6
 27  0  0 76  0  0  0  0  0  0
  0  0  0  0  0  0  6  0  0  0
  0  0  0  0  0  0  0  0  0  0
  0  0  0  0  0  0  6 27  0  0
 82  0  0 10  5  0  0  5  5 12
 12  5 15  6  5  5  5  0  4  0
  5  5  5  5  0  6 18  0  5  5
  5  5  5  3 27  5  5  5  5  5
 31  5  0  6  5  5  0  5  5  6
  0  5  5  5  3  4  0  5  5  5
  5  0  0  3 12  5  5  5  5  5
  0 18  5  3  5  5  5  0  0  0
  0  0  0  0  0  0  0  0  0  0
  0  0  0  0  0  7  0  0  0  0
  0  0  0  5  0  0  0  0  3  0
  0  5  0  0  5  5  5  5  5  5
  6  5  5  5  0  5  5  5  5  5
  3  5  5  5  0 12  4  5  5  5
  5  5  5  7  0 21  4  0  5  5
  5  0  0  0  0  0  0  0  0  0
  0  0  0  0  0  0  0  0  0 27
  0  0  0  0  0  0  0  9  0  0
  0  0  0  0  0  5  0  0  0  0
  0  0  0  0  0  0  0  0  0  0
  0  0  0  0  0  0  0  0  0  0
  0  0  0  0  6  0  0  0  0  0
  0  0  181  0  0  -15

========================================================================================
DOCUMENT :usus Folder:VOLUK03:types.text
========================================================================================


const (********************************************************)
   sfirst = 1; (*  FIRST INDEX OF STRINGS*)
   so_max_sorceline   = 9998; (*  DESCRIPTION OF SOURCE LINES*)
   so_max_sourcecolumn = 257; (*ADJUST*) (*MUST BE MAX INPUT LENGTH+1*)
   st_nil = 0; (* NULL CODING; USED TO INDICATE THAT SYMBOL IS NOT FOUND*)
   st_sym_ubound = 101;  (* MUST BE PRIME *)
   st_word_length = 9;  (* MAX RESERVED WORD LENGTH *)
   stb_empty = 0;            (*EMPTY TEXT TABLE REFERENCE*)
   stb_str_ubound = 600;    (*TEXT TABLE SIZE*)
(* DECLARATIONS FROM LA*)
(* SPECIAL CHARACTER FOR END OF FILE MARKING*)
   eof_char = '$';
(* CONSTANTS REPRESENTING CONTROL CHARACTERS IN ASCII  *)
   nul = 0; ht = 5; del= 7; vt = 11; ff = 12; cr = 13; lf = 37; (*ADJUST*)
   max_int = 32767;  { adjusted from  2147483647, by EDS }  (*ADJUST*)
type  (********************************************************)
   so_sorceline_range = 0 .. 9999 (*SO_MAX_SOURCELINE + 1*);
           (* ONLY VALID FROM 1 .. 9998*)
   so_sorcecolumn_range = sfirst .. so_max_sourcecolumn;
           (* ALL COLUMNS ARE VALID*)
   string           = packed array[so_sorcecolumn_range] of char;
                             (* ONLY THIS STRING TYPE IS USED*)
   so_sorce_string = string;(* SOURCE LINES*)
   so_symbol_string = string;(* SYMBOLS HAVE AT MOST LINE SIZE*)
(* SOURCE LINE POSITION DESCRIPTION USED THROUGHOUT THE COMPILER*)
   so_position =
      record
         sourceline : so_sorceline_range;
         column     : so_sorcecolumn_range
      end;
(* THE RANGE OF ERROR NUMBERS*)
   er_errornumber_range = 0 .. 9999;
{ adjusted, one 9 removed by EDS }
(* DIFFERENT ERROR KINDS*)
   er_error_type =
      (er_warning   , er_symbol_error   , er_syntax_error   ,
       er_sym_inserted, er_reset_position , er_semantic_error ,
       er_comp_restriction, er_compiler_error , er_io_error  );
   co_base_type = 2 .. 16;
   st_symbol = 0 .. st_sym_ubound;
              (* POSSIBLE RESULT OF CODING, INCLUDES THE NULL CODING*)
   st_literal = packed array [sfirst .. st_word_length] of char;
(*---------------------------------------------------------------*)
(* ENUMERATION TYPE FOR ALL LEXICAL UNITS*)
(*---------------------------------------------------------------*)
   lu_lexical_unit =
   (* LEXICAL UNITS WHICH ARE CODED*)
     ( lu_identifier_sym , lu_integer_sym    , lu_real_sym  ,
       lu_character_sym  , lu_string_sym,
   (* END OF FILE*)
       lu_eof_sym   ,
   (* RESERVED WORDS*)
       lu_abort_sym , lu_accept_sym, lu_access_sym, lu_all_sym   ,
       lu_and_sym   , lu_array_sym , lu_at_sym    , lu_begin_sym ,
       lu_body_sym  , lu_case_sym  , lu_constant_sym   ,
       lu_declare_sym    , lu_delay_sym , lu_delta_sym , lu_digits_sym,
       lu_do_sym    , lu_else_sym  , lu_elsif_sym , lu_end_sym   ,
       lu_entry_sym , lu_exception_sym  , lu_exit_sym  , lu_for_sym   ,
       lu_function_sym   , lu_generic_sym    , lu_goto_sym  ,
       lu_if_sym    , lu_in_sym    , lu_is_sym    , lu_limited_sym    ,
       lu_loop_sym  , lu_mod_sym   , lu_new_sym   , lu_not_sym   ,
       lu_null_sym  , lu_of_sym    , lu_or_sym    , lu_others_sym,
       lu_out_sym   , lu_package_sym    , lu_pragma_sym,
       lu_private_sym    , lu_procedure_sym  , lu_raise_sym ,
       lu_range_sym , lu_record_sym, lu_rem_sym   , lu_renames_sym    ,
       lu_return_sym, lu_reverse_sym    , lu_salect_sym,
       lu_seperate_sym   , lu_subtype_sym    , lu_task_sym  ,
       lu_terminate_sym  , lu_then_sym  , lu_type_sym  , lu_use_sym   ,
       lu_when_sym  , lu_while_sym , lu_with_sym  , lu_xor_sym   ,
   (* DELIMITERS*)
       lu_minus_sym , lu_dot_sym   , lu_interval_sym   , lu_less_sym  ,
       lu_left_label_sym , lu_box_sym   , lu_less_equal_sym ,
       lu_lpar_sym  , lu_plus_sym  , lu_separator_sym  ,
       lu_catenation_sym , lu_multiply_sym   , lu_exponentiation_sym  ,
       lu_rpar_sym  , lu_semicolon_sym  , lu_divide_sym,
       lu_not_equal_sym  , lu_comma_sym , lu_greater_sym    ,
       lu_right_label_sym, lu_greator_equal_sym   , lu_colon_sym ,
       lu_assign_sym, lu_quote_sym , lu_equal_sym , lu_arrow_sym );
(*---------------------------------------------------------------*)
(* DESCRIPTOR OF LEXICAL UNITS*)
(*---------------------------------------------------------------*)
    lu_selector =  (lu_id, lu_int, lu_real, lu_other);
              (* THIS IS NEEDED FOR DISCRIMINANT SELECTION*)
   lu_sym_descriptor =
      record
         sym     : lu_lexical_unit;
         case discrim : lu_selector  of
            lu_id :      (* LU_IDENTIFIER_SYM, LU_STRING_SYM*)
                         (* LU_CHARACTER_SYM, RESERVED_WORDS*)
                        (* OPERATORS*)
               (idcode : st_symbol)
            (*OTHERS ARE NOT CODED*)
      end;   (* RECORD;*)
   lu_symbol_string =  so_symbol_string;
(* TEXT TABLE*)
   stb_str_0range =  0 .. stb_str_ubound;
   stb_str_range  =  1 .. stb_str_ubound;
   stb_s_tab_rec =
      record
         textb,
         texte : stb_str_0range
      end;
(* DECLARATIONS FROM LA*)
   character_type =
      (letter_a_f   , letter_g_z   , low_letter   , digit   , dquote  ,
       quote   , hyphen  , ampersand    , lpar    , rpar    , asterisk,
       plus    , comma   , point   , slash   , colon   , semicolon    ,
       langle  , equal   , rangle  , vbar    , underscore   , nwline  ,
       ignore  , blank   , htab    , eofc     , other_graphics    , non_ada );
var   (********************************************************)
  (* SPECIAL POSITIONS*)
   so_nil_position :                 (* USED IF NO POSITION AVAILABLE*)
      (*CONSTANT*) so_position
      (* := (SOURCELINE => SO_SOURCELINE_RANGE'FIRST   *)
      (*     COLUMN     => SO_SOURCECOLUMN_RANGE'FIRST)*);
   lu_reserved_word : array [st_symbol] of lu_lexical_unit;
                             (* RESERVED WORD INDICATOR*)
   lu_code_minus, lu_code_less, lu_cde_less_equal, lu_code_plus,
      lu_code_catenation, lu_code_multiply, lu_code_exponentiation,
      lu_code_divide, lu_code_not_equal, lu_code_greater,
      lu_cde_greater_equal, lu_code_equal : st_symbol;
   lu_no_symbol : lu_sym_descriptor;
(*---------------------------------------------------------------*)
(* INITIALIZATION*)
(*---------------------------------------------------------------*)
(*TEXT TABLE*)
   stb_s_tab_strings : packed array [stb_str_range] of char;
   stb_number_char : stb_str_0range;
(*HASH TABLE*)
   stb_s_tab_entries : array [st_symbol] of stb_s_tab_rec;
   stb_texttable_full, stb_hashtable_full : boolean;
(*-------------------------------------------------------------------*)
(* SYMBOL TABLE CODES FOR ERROR UNITS*)
   lub_cde_identifier, lub_code_integer, lub_code_real,lub_code_string,
      lub_code_character : st_symbol;
(*------------------------------------------------------------------*)
(* DECLARATIONS FROM LA*)
   char_type_table : array [char] of character_type;
(* BUFFER, BUFFER-POINTER*)
(* ASSERT: CURRENT_CHAR == BUFFER(CURRENT);*)
(*        BUFFER(LAST_CHAR..LAST_CHAR+1)=(CR,CR) OR BUFFER(FIRST)=EOFC*)
(*        CURRENT IS ALWAYS NEXT CHARACTER*)
   buffer : so_sorce_string;
   (*  LOOKAHEAD=2*)
   current, last_char :  integer;
   current_char : char;
   line_no : integer;
(* LAST RECOGNIZED LEXICAL UNIT (BECAUSE QUOTE AMBIGUITIES)*)
   last_symbol : lu_sym_descriptor;
   last_pos : so_position;
(*------------------------------------------------------------------*)
   errors_count   : integer;
   warnings_count : integer;
   error_no       : integer;
   erb_last_pos   : so_position;
(*-------------------------------------------------------------------*)
      tabdat  : file of integer;
      (********************************************************)
   morefiles:boolean;
   reply:char;


========================================================================================
DOCUMENT :usus Folder:VOLUK03:voluk3.doc.text
========================================================================================

                            USUS Library Volume UK3
                             An ADA Syntax Checker
                             Submitted by USUS(UK)

VOLUK3:
ADADOC.TEXT       20  Documentation of the ADA Syntax Checker
ADA.TEXT          34  The main program of the ADA Syntax Checker
COINT.TEXT        14    an include file
LAINIT.TEXT        8      ditto
LANEXT.TEXT       40      ditto
LUERROR.TEXT      14      ditto
LUINIT.TEXT       16      ditto
PARSER.TEXT       40      ditto
TYPES.TEXT        18      ditto
STGET.TEXT        12      ditto
TEXTDAT.TEXT     136  A data file     
FILECHECK.TEXT     4  A utility program 
ADA.CODE          33  A code file of the ADA Syntax Checker that
                        won't run under IV.0
GENDAT.TEXT        4  Generates the file TEXTDAT.TEXT
GENDAT.CODE        2 
ADATEST.TEXT      21  A non-UCSD text file of a sample ADA test case
NEWADATEST.TEXT   24  A version of ADATEST.TEXT converted to UCSD format
                        but without proper indentation
CONTENTS.TEXT      6  The original UK contents file
VOLUK3.DOC.TEXT    6  You're reading it.
__________________________________________________________________________

Please transfer the text below to a disk label if you copy this volume.

    USUS Volume UK3 -***- USUS Software Library
                         
   For not-for-profit use by USUS members only.
  May be used and distributed only according to 
      stated policy and the author's wishes.



This volume was assembled by USUS(UK) from material collected by
their Library committee.
__________________________________________________________________________


========================================================================================
DOCUMENT :usus Folder:VOLUK04:apl.text
========================================================================================

(*$L PRINTER:*)
(*$D+*)
(*$R-*)
(**************************************************************)
(* This program is an adaptation for UCSD pascal of a program *)
(* that appears in the Byte Book Of Pascal. The changes made  *)
(* were very small, so it is still fairly inefficient.        *)
(* There are still probably a few typos in it as well as      *)
(* common or garden bugs.                                     *)
(* The APL subset that has been implemented so far is fairly  *)
(* small and limiting, such as no character strings, plus     *)
(* things like restictions on where generalised matrices may  *)
(* be used (bracketing them sometimes helps).                 *)
(* If you find any bugs or write any enhancements I would be  *)
(* grateful if you could forward them on to me either via     *)
(* USUS or Inmos Ltd.,                                        *)
(*           Whitefriars,                                     *)
(*             Lewins Mead,                                   *)
(*               Bristol BS1 2NP,                             *)
(*                 England.                                   *)
(* Greg Nunan 10/10/80.                                       *)
(**************************************************************)
program scanner(infile, outfile, cherfile);

const
  maxvarnamelength = 10;
  maxinputline = 80;
  maxoutputline = 80;
  inputarraysize = 82;
  numberofmessages = 75;
  messagelength = 50;
  spectablength = 6;
  doptablength = 16;
  chartablength = 12;
  redtablength = 16;
  moptablength = 12;
  numofopspertable = 16;
  norminfile = 'console:';
  normoutfile = 'console:';
  indent = '      ';
  extrabytes = 2;                                               (* heap *)
  blocksize = 64;                                               (* heap *)
  blockbytes = 128;                                             (* heap *)
  endofstore = 0;                                               (* heap *)
  used = 1;                                                     (* heap *)
  unused = 0;                                                   (* heap *)
  
type
  packedstring = packed array[1..maxvarnamelength] of char;
  tokennoun = (formres, formarg, globvar, monadoper, reductoper,
               dyadoper, specoper, constant, statend);
  values = record
             realval: real;
             nextvalue: ^values
           end;
  vartab = record
             varname: packedstring;       (* v1 *)
             functabptr: ^functab;        (* v2 - ftab *)
             valtabptr: ^valtab;          (* v3 - vtab *)
             deferedvaltabptr: ^fparmtab;
             nextvartabptr: ^vartab
           end;
  valtab = record
             intermedresult: boolean;
             dimensions: integer;
             firstdimen: ^dimeninfo;
             forwardorder: boolean;
             firstvalue: ^values;
             nextvaltablink: ^valtab
           end;
  tokentable = record
                 nextoken: ^tokentable;
                 case noun: tokennoun of          (* p *)
                   formres,
                   formarg,
                   globvar: (vartabptr: ^vartab); (* vtab *)
                   monadoper: (monindx: integer);
                   reductoper: (redindx: integer);
                   dyadoper: (dopindx: integer);
                   specoper: (charindx: integer);
                   constant: (valtabptr: ^valtab);
                   statend: (endadj: integer)
               end;
  vfunc = record
            nextstmnt: ^tokentable;
            nextvfuncptr: ^vfunc;
            statlabel: packedstring
          end;
  functab = record
              funcname: packedstring;             (* f1 *)
              arity: (niladic, monadic, dyadic);  (* f2 *)
              result: boolean; (* true = explicit    f3 *)
              resultname: packedstring;           (* f4 *)
              leftarg: packedstring;              (* f5 *)
              rightarg: packedstring;             (* f6 *)
              firstatement: ^vfunc;
              nextfunctabptr: ^functab;
              numofstatements: integer
            end;
  fparmtab = record
               ptrval: ^valtab;     (* sd1 and sd2 *)
               lastparm: ^fparmtab  (* link to last sd1 or sd2 *)
             end;
  dimeninfo = record
                nextdimen: ^dimeninfo;
                dimenlength: integer
              end;
  oprecord = record
               opindex: integer;
               opsymbol : char
             end;
  operandtab = record
                 operptr: ^valtab;        (* sval *)
                 lastoper: ^operandtab    (* link to last sval *)
               end;
  subrtab = record                                (* sf *)
              calledsubr: ^functab;               (* s1 *)
              tokencallingsubr: ^tokentable;      (* s2 *)
              statemcallingsubr: ^vfunc;          (* s3 *)
              lastsubrptr: ^subrtab       (* link to last sf *)
            end;
  optable = array[1..numofopspertable] of oprecord;
  vartabptrtype = ^vartab;
  typevaltabptr = ^valtab;
  tokenptr = ^tokentable;
  ptrfunctab = ^functab;
  typevaluesptr = ^values;
  typevfuncptr = ^vfunc;                                        (* heap *)
  fparmptr = ^fparmtab;                                         (* heap *)
  dimenptr = ^dimeninfo;                                        (* heap *)
  operandptr = ^operandtab;                                     (* heap *)
  typesubrtabptr = ^subrtab;                                    (* heap *)
  aplcharset = (asymbol, bsymbol, csymbol, dsymbol, esymbol,
                fsymbol, gsymbol, hsymbol, isymbol, jsymbol,
                ksymbol, lsymbol, msymbol, nsymbol, osymbol,
                psymbol, qsymbol, rsymbol, ssymbol, tsymbol,
                usymbol, vsymbol, wsymbol, xsymbol, ysymbol,
                zsymbol,
                onesymbol, twosymbol, threesymbol, foursymbol,
                fivesymbol, sixsymbol, sevensymbol, eightsymbol,
                ninesymbol, zerosymbol,
                colon, rightarrow, leftarrow, smallcircle,
                period, leftparen, rightparen, leftbracket,
                rightbracket, semicolon, quadrangle, space,
                plus, minus, times, divide, asterisk, iota,
                rho, comma, tilde, equals, notequal, lessthan,
                lessorequal, greaterorequal, greaterthan,
                andsymbol, orsymbol, ceiling, floor, largecircle,
                forwardslash, doublequote, negative,
                questionmark, omega, epsilon, uparrow, downarrow,
                alpha, underscore, del, delta, singlequote,
                eastcap, westcap, southcap, northcap, ibeam,
                tbeam, verticalstroke, backwardslash);
  block = array[1..blocksize] of integer;                       (* heap *)
  pointer = ^integer;                                           (* heap *)
  storeptr = record                                             (* heap *)
               case integer of                                  (* heap *)
                 0: (ptr: ^integer);                            (* heap *)
                 1: (int: integer)                              (* heap *)
             end;                                               (* heap *)
  xxx = record                                                  (* heap *)
          case integer of                                       (* heap *)
            0: (ptr: ^integer);                                 (* heap *)
            1: (valus: typevaluesptr);                          (* heap *)
            2: (ops: operandptr);                               (* heap *)
            3: (tokens: tokenptr);                              (* heap *)
            4: (funcs: ptrfunctab);                             (* heap *)
            5: (subrs: typesubrtabptr);                         (* heap *)
            6: (fparms: fparmptr);                              (* heap *)
            7: (vars: vartabptrtype);                           (* heap *)
            8: (valts: typevaltabptr);                          (* heap *)
            9: (vfuncs: typevfuncptr);                          (* heap *)
           10: (dims: dimenptr);                                (* heap *)
           11: (int: integer)                                   (* heap *)
        end;                                                    (* heap *)
                
var
  xcolonsym, xrightarrow, xleftarrow, xlittlecircle,
  xperiod, xleftpar, xrightpar, xleftbracket,
  xrightbracket, xsemicolsym, xquadsym: integer;
  character: array[aplcharset] of char;
  aplstatement: packed array[1..inputarraysize] of char;
  digits: array[onesymbol..zerosymbol] of integer;
  errormsgs: packed array[1..numberofmessages] of string[messagelength];
  infile, outfile: interactive;
  cherfile: text;
  moptab, doptab, redtab, chartab, spectab: optable;
  savelabel: packedstring;
  name: packedstring;
  newtokenptr, oldtokenptr, holdtokenptr, savetokenptr: ^tokentable;
  testfuncptr, newfunctabptr, oldfunctabptr: ^functab;
  newvartabptr, oldvartabptr: ^vartab;
  leftvalptr, rightvalptr, valptr: ^values;
  newvalues, newvalptr: ^values;
  newdim: ^dimeninfo;
  dimptr, newptr, leftdimptr, rightdimptr: ^dimeninfo;
  varpointer: ^vartab;
  oldvfuncptr, newvfuncptr: ^vfunc;
  newvaltablink, oldvaltablink: ^valtab;
  position: integer;
  linelength: integer;
  code, colcnt: integer;
  funcstatements: integer;
  tokenerror, firstfunction: boolean;
  linetoolong, haslabel: boolean;
  switch, funcmode, tokenswitch, itsanidentifier: boolean;
  opertabptr: ^operandtab;        (* sv *)
  ptrlastoper: ^operandtab;
  subrtabptr: ^subrtab;
  rparmptr: ^fparmtab;            (* p1 *)
  lparmptr: ^fparmtab;            (* p2 *)
  vfuncptr: ^vfunc;               (* nl *)
  hold: ^tokentable;      (* holds last symbol *)
  totaldigs, afterdigs: integer;
  realsperline: integer;
  rollnum: integer;
  freestore: storeptr;                                          (* heap *)
  areasize: integer;                                            (* heap *)
        
procedure setupheap; forward;                                   (* heap *)

procedure getvalu(var valu: typevaluesptr); forward;            (* heap *)

procedure getoper(var oper: operandptr); forward;               (* heap *)

procedure gettoken(var token: tokenptr); forward;               (* heap *)

procedure getfunc(var func: ptrfunctab); forward;               (* heap *)

procedure getsubr(var subr: typesubrtabptr); forward;           (* heap *)

procedure getfparm(var fparm: fparmptr); forward;               (* heap *)

procedure getvarr(var varr: vartabptrtype); forward;            (* heap *)

procedure getvalt(var valt: typevaltabptr); forward;            (* heap *)

procedure getvfunc(var vfunk: typevfuncptr); forward;           (* heap *)

procedure getdim(var dim: dimenptr); forward;                   (* heap *)

procedure ridvalu(var valu: typevaluesptr); forward;            (* heap *)

procedure ridoper(var oper: operandptr); forward;               (* heap *)

procedure ridtoken(var token: tokenptr); forward;               (* heap *)

procedure ridfunc(var func: ptrfunctab); forward;               (* heap *)

procedure ridsubr(var subr: typesubrtabptr); forward;           (* heap *)

procedure ridfparm(var fparm: fparmptr); forward;               (* heap *)

procedure skipspaces; forward;

procedure getaplstatement; forward;

function namesmatch(nameone, nametwo: packedstring): boolean; forward;

procedure makeanumber(var realnumber: real; var itsanumber: boolean); forward;


procedure reverselinklist(var argptr: typevaltabptr); forward;

function nameinvartable(name: packedstring;
                        var varpointer: vartabptrtype;
                        testfuncptr: ptrfunctab): boolean; forward;

function funcalreadydefined(var newfuname: packedstring;
                            var funcindex: ptrfunctab): boolean; forward;

(*$I aplinit.text*)
(*$I aplparse0.text*)
(*$I aplparse1.text*)
(*$I aplparse2.text*)
(*$I aplparse3.text*)
(*$I aplprocs.text*)
(*$I aplheap.text*)

begin {scanner}
aplinit;
write(outfile, areasize/(memavail*2): 4: 2, ': ');
getaplstatement;
while (aplstatement[1] <> character[forwardslash]) or
      (aplstatement[2] <> character[asterisk])  (* /* ends program *) do
  begin
    skipspaces;
    tokenswitch := true;
    while (position <= linelength) and (not tokenerror) 
          and (not linetoolong) do
      begin (* scanning *)
        if aplstatement[position] = character[del] (* function delimiter *)
        then (* del encountered !!!! *)
          if funcmode
          then
            begin (* end of current function *)
              if newfunctabptr <> nil
              then newfunctabptr^.numofstatements := funcstatements;
              if funcstatements > 0
              then
                begin
                  newfunctabptr^.nextfunctabptr := oldfunctabptr;
                  oldfunctabptr := newfunctabptr;
                  newvfuncptr^.nextvfuncptr := nil
                end
              else serror(75); (* function defined with no statements *)
              funcmode := false;
              position := position + 1
            end
          else processfunctionheader (* start of a new function *)
        else (* not a del encountered *)
          begin
            if tokenswitch = true
            then
              begin (* this is start of a new statement *)
                tokenswitch := false;
                holdtokenptr := oldtokenptr; (* save starting position *)
                maketokenlink;
                newtokenptr^.noun := statend;
                newtokenptr^.endadj := 0;
                haslabel := false
              end;
            maketokenlink;
            identifier(name, itsanidentifier);
            if not itsanidentifier
            then trytogetanumber
            else
              begin (* process identifier *)
                skipspaces;
                if (aplstatement[position] = character[colon]) and
                   (newtokenptr^.nextoken^.noun = statend)
                then
                  begin (* process statement label *)
                    savelabel := name;
                    haslabel := true;
                    position := position + 1
                  end
                else
                  begin (* process variable name *)
                    if not funcmode
                    then newtokenptr^.noun := globvar
                    else
                      if namesmatch(name, newfunctabptr^.resultname)
                      then newtokenptr^.noun := formres
                      else
                        if (namesmatch(name, newfunctabptr^.leftarg))
                           or (namesmatch(name, newfunctabptr^.rightarg))
                        then newtokenptr^.noun := formarg
                        else newtokenptr^.noun := globvar;
                    if newtokenptr^.noun <> globvar
                    then testfuncptr := newfunctabptr
                    else testfuncptr := nil;
                    if not nameinvartable(name, varpointer, testfuncptr)
                    then
                      begin
                        addnametovartable(name);
                        newtokenptr^.vartabptr := newvartabptr
                      end
                    else newtokenptr^.vartabptr := varpointer
                  end
              end
          end;
        skipspaces
      end;
    if newtokenptr <> nil
    then
      if (tokenerror) or (newtokenptr^.noun = statend)
      then destroystatement
      else
        if funcmode
        then
          begin
            funcstatements := funcstatements + 1;
            if funcstatements > 0
            then
              begin (* calatogue function statement *)
                getvfunc(newvfuncptr);
                if funcstatements = 1
                then newfunctabptr^.firstatement := newvfuncptr
                else oldvfuncptr^.nextvfuncptr := newvfuncptr;
                oldvfuncptr := newvfuncptr;
                if haslabel
                then newvfuncptr^.statlabel := savelabel;
                newvfuncptr^.nextstmnt := newtokenptr
              end
          end
        else
          if aplstatement[1] <> character[del]
          then
            begin
              parser(newtokenptr, newvaltablink);
              destroystatement
            end;
    tokenerror := false;
    write(outfile, areasize/(memavail*2): 4: 2, ': ');
    getaplstatement
  end
end.


========================================================================================
DOCUMENT :usus Folder:VOLUK04:aplchers.text
========================================================================================

abcdefghijklmnopqrstuvwxyz1234567890                    { normal chars }
:RLO.()[];@ +-X%*!P,~=#<{}>&VCFQ/"-?Z`^DA_$^'EWSNIT|\   { special chars }
NOT USED
digit must follow a decimal point
extraneous characters follow function header
invalid character encountered
function already defined
illegal name to right of explicit result
invalid function/argument name
result of assignment not valid variable
invalid function right argument name
invalid expression
symbol not found
statement number to branch to not integer
dydadic operator not preceded by primary
invalid expression within parentheses
mismatched parentheses
NOT USED
left argument of dyadic function not a primary
NOT USED
value not boolean
attempted division by zero
argument not a scalar
argument is negative
argument is not an integer
argument is a scalar or empty vector
NOT USED
invalid outer product expression
invalid inner product expression
NOT USED
left argument is not a vector
NOT USED
NOT USED
error in function argument
error in function argument
invalid index expression
non-scalar indices
assigned expression not a scalar
non-integer indices
index out of range
invalid index expression
NOT USED
NOT USED
NOT USED
NOT USED
NOT USED
wrong number of subscripts
NOT USED
NOT USED
NOT USED
NOT USED
number and base of different sign
argument is a vector of length one
arguments not compatible for inner product
argument(s) with rank greater than one
attempted inverse of zero
arguments incompatible for dyadic operation
left argument not a vector
NOT USED
NOT USED
NOT USED
greater than three dimensions
nil
re-enter last line
input
NOT USED
NOT USED
NOT USED
NOT USED
NOT USED
variable not assigned a value
identifier too long
input line too long
invalid reduction operator
dyadic reduction reference
monadic reference to dyadic operator
function defined with no statements


========================================================================================
DOCUMENT :usus Folder:VOLUK04:aplheap.text
========================================================================================

(*$D-*)
(* note that these are dirty routines that are machine/implementation *)
(* dependant, particularly the mixing of integer/byte sizes/pointers  *)

procedure outofheap;
begin
writeln('**** out of heap space (', areasize, ' allocated) ****');
exit(scanner)
end; {outofheap}

procedure setupheap;
begin
areasize := 0;
if memavail < 1
then outofheap
else
  begin
    new(freestore.ptr);
    writeln(')APL : ', memavail*2, ' bytes available');
    freestore.ptr^ := endofstore
  end
end; {setupheap}

procedure getextrablock(pptr: pointer; var sizethisone: integer);
var
  blockptr: ^block;
begin
if memavail < blocksize
then outofheap
else
  begin
    new(blockptr);
    sizethisone := blockbytes + pptr^;
    blockptr^[blocksize] := endofstore;
    areasize := areasize + blockbytes
  end
end; {getextrablock}

procedure getxxx(size: integer; var heap: xxx);
var
  p, q: storeptr;
  sizethisarea: integer;
begin
p.ptr := freestore.ptr;
q.ptr := freestore.ptr;
size := size + extrabytes + (size mod 2);
sizethisarea := 0;
while (sizethisarea < size) and (q.ptr^ <> endofstore) do
  begin
    p.ptr := q.ptr;
    while (p.ptr^ mod 2) = used do
      p.int := p.int + p.ptr^ - used;
    q.ptr := p.ptr;
    while ((q.ptr^ mod 2) = unused) and (q.ptr^ <> endofstore) do
      q.int := q.int + q.ptr^;
    sizethisarea := q.int - p.int; (* note that this sets the unused flag *)
    if p.ptr^ <> endofstore
    then p.ptr^ := sizethisarea
  end;
while sizethisarea < size do
  getextrablock(p.ptr, sizethisarea);
if sizethisarea > size
then
  begin
    q.int := p.int + size;
    q.ptr^ := sizethisarea - size (* note that this sets the unused flag *)
  end;
p.ptr^ := size + used;
p.int := p.int + extrabytes;
heap.ptr := p.ptr
end; {getxxx}

procedure getvalu{var valu: typevaluesptr};
var
  dummyvalu: values;
  dummyxxx: xxx;
begin
getxxx(sizeof(dummyvalu), dummyxxx);
valu := dummyxxx.valus
end; {getvalu}

procedure getoper{var oper: operandptr};
var
  dummyoper: operandtab;
  dummyxxx: xxx;
begin
getxxx(sizeof(dummyoper), dummyxxx);
oper := dummyxxx.ops
end; {getoper}

procedure gettoken{var token: tokenptr};
var
  dummytoken: tokentable;
  dummyxxx: xxx;
begin
getxxx(sizeof(dummytoken), dummyxxx);
token := dummyxxx.tokens
end; {gettoken}

procedure getfunc{var func: ptrfunctab};
var
  dummyfunc: functab;
  dummyxxx: xxx;
begin
getxxx(sizeof(dummyfunc), dummyxxx);
func := dummyxxx.funcs
end; {getfunc}

procedure getsubr{var subr: typesubrtabptr};
var
  dummysubr: subrtab;
  dummyxxx: xxx;
begin
getxxx(sizeof(dummysubr), dummyxxx);
subr := dummyxxx.subrs
end; {getsubr}

procedure getfparm{var fparm: fparmptr};
var
  dummyfparm: fparmtab;
  dummyxxx: xxx;
begin
getxxx(sizeof(dummyfparm), dummyxxx);
fparm := dummyxxx.fparms
end; {getfparm}

procedure getvalt{var valt: typevaltabptr};
var
  dummyvalt: valtab;
  dummyxxx: xxx;
begin
getxxx(sizeof(dummyvalt), dummyxxx);
valt := dummyxxx.valts
end; {getvalt}

procedure getvarr{var varr: vartabptrtype};
var
  dummyvarr: vartab;
  dummyxxx: xxx;
begin
getxxx(sizeof(dummyvarr), dummyxxx);
varr := dummyxxx.vars
end; {getvarr}

procedure getvfunc{var vfunk: typevfuncptr};
var
  dummyvfunc: vfunc;
  dummyxxx: xxx;
begin
getxxx(sizeof(dummyvfunc), dummyxxx);
vfunk := dummyxxx.vfuncs
end; {getvfunc}

procedure getdim{var dim: dimenptr};
var
  dummydim: dimeninfo;
  dummyxxx: xxx;
begin
getxxx(sizeof(dummydim), dummyxxx);
dim := dummyxxx.dims
end; {getdim}

procedure ridxxx(var heap: xxx);
begin
heap.int := heap.int - extrabytes;
heap.ptr^ := heap.ptr^ - used
end; {ridxxx}

procedure ridvalu{var valu: typevaluesptr};
var
  dummyxxx: xxx;
begin
dummyxxx.valus := valu;
ridxxx(dummyxxx)
end; {ridvalu}

procedure ridoper{var oper: operandptr};
var
  dummyxxx: xxx;
begin
dummyxxx.ops := oper;
ridxxx(dummyxxx)
end; {ridoper}

procedure ridtoken{var token: tokenptr};
var
  dummyxxx: xxx;
begin
dummyxxx.tokens := token;
ridxxx(dummyxxx)
end; {ridtoken}

procedure ridfunc{var func: ptrfunctab};
var
  dummyxxx: xxx;
begin
dummyxxx.funcs := func;
ridxxx(dummyxxx)
end; {ridfunc}

procedure ridsubr{var subr: typesubrtabptr};
var
  dummyxxx: xxx;
begin
dummyxxx.subrs := subr;
ridxxx(dummyxxx)
end; {ridsubr}

procedure ridfparm{var fparm: fparmptr};
var
  dummyxxx: xxx;
begin
dummyxxx.fparms := fparm;
ridxxx(dummyxxx)
end; {ridfparm}

(*$D+*)


========================================================================================
DOCUMENT :usus Folder:VOLUK04:aplinit.text
========================================================================================

(*$D-*)
segment procedure aplinit;

procedure initparser;
begin
opertabptr := nil;
subrtabptr := nil;
lparmptr := nil;
rparmptr := nil;
vfuncptr := nil;
hold := nil;
xcolonsym := 1;
xrightarrow := 2;
xleftarrow := 3;
xlittlecircle := 4;
xperiod := 5;
xleftpar := 6;
xrightpar := 7;
xleftbracket := 8;
xrightbracket := 9;
xsemicolsym := 10;
xquadsym := 11;
getoper(opertabptr);
opertabptr^.lastoper := nil;
ptrlastoper := opertabptr
end; {initparser}

procedure readcherfile; (* read character set and error msgs from file *)
var
  aplchar: char;
  symbolindex: aplcharset;
  msgrow: integer;
begin
reset(cherfile, 'aplchers.text');
for symbolindex := asymbol to backwardslash do
  begin
    read(cherfile, aplchar);
    if symbolindex = zerosymbol
    then readln(cherfile);
    character[symbolindex] := aplchar
  end;
readln(cherfile);
for msgrow := 1 to numberofmessages do
  readln(cherfile, errormsgs[msgrow]);
close(cherfile)
end; {readcherfile}

procedure fillupoptables;
begin
(* monadic operators *)
moptab[1].opsymbol := character[plus];  moptab[1].opindex := 2;
moptab[2].opsymbol := character[minus];  moptab[2].opindex := 3;
moptab[3].opsymbol := character[times];  moptab[3].opindex := 4;
moptab[4].opsymbol := character[divide];  moptab[4].opindex := 5;
moptab[5].opsymbol := character[asterisk];  moptab[5].opindex := 6;
moptab[6].opsymbol := character[iota];  moptab[6].opindex := 21;
moptab[7].opsymbol := character[rho];  moptab[7].opindex := 22;
moptab[8].opsymbol := character[comma];  moptab[8].opindex := 23;
moptab[9].opsymbol := character[tilde];  moptab[9].opindex := 1;
moptab[10].opsymbol := character[ceiling];  moptab[10].opindex := 9;
moptab[11].opsymbol := character[floor];  moptab[11].opindex := 10;
moptab[12].opsymbol := character[questionmark];  moptab[12].opindex := 7;
(* dyadic operators *)
doptab[1].opsymbol := character[plus];  doptab[1].opindex := 52;
doptab[2].opsymbol := character[minus];  doptab[2].opindex := 53;
doptab[3].opsymbol := character[times];  doptab[3].opindex := 54;
doptab[4].opsymbol := character[divide];  doptab[4].opindex := 55;
doptab[5].opsymbol := character[asterisk];  doptab[5].opindex := 56;
doptab[6].opsymbol := character[iota];  doptab[6].opindex := 87;
doptab[7].opsymbol := character[rho];  doptab[7].opindex := 88;
doptab[8].opsymbol := character[comma];  doptab[8].opindex := 89;
doptab[9].opsymbol := character[equals];  doptab[9].opindex := 71;
doptab[10].opsymbol := character[notequal];  doptab[10].opindex := 72;
doptab[11].opsymbol := character[lessthan];  doptab[11].opindex := 73;
doptab[12].opsymbol := character[lessorequal];  doptab[12].opindex := 74;
doptab[13].opsymbol := character[greaterorequal];  doptab[13].opindex := 75;
doptab[14].opsymbol := character[greaterthan];  doptab[14].opindex := 76;
doptab[15].opsymbol := character[andsymbol];  doptab[15].opindex := 77;
doptab[16].opsymbol := character[orsymbol];  doptab[16].opindex := 78
end; {fillupoptables}

procedure fillupspectables;
begin
(* special characters *)
chartab[1].opsymbol := character[colon];
chartab[2].opsymbol := character[rightarrow];
chartab[3].opsymbol := character[leftarrow];
chartab[4].opsymbol := character[smallcircle];
chartab[5].opsymbol := character[period];
chartab[6].opsymbol := character[leftparen];
chartab[7].opsymbol := character[rightparen];
chartab[8].opsymbol := character[leftbracket];
chartab[9].opsymbol := character[rightbracket];
chartab[10].opsymbol := character[semicolon];
chartab[11].opsymbol := character[quadrangle];
chartab[12].opsymbol := character[space];
spectab[1].opsymbol := character[colon];
spectab[2].opsymbol := character[rightarrow];
spectab[3].opsymbol := character[leftarrow];
spectab[4].opsymbol := character[leftparen];
spectab[5].opsymbol := character[semicolon];
spectab[6].opsymbol := character[leftbracket]
end; {fillupspectables}

procedure fillupredtables;
begin
(* reduction operators *)
redtab[1].opsymbol := character[plus];  redtab[1].opindex := 2;
redtab[2].opsymbol := character[minus];  redtab[2].opindex := 3;
redtab[3].opsymbol := character[times];  redtab[3].opindex := 4;
redtab[4].opsymbol := character[divide];  redtab[4].opindex := 5;
redtab[5].opsymbol := character[asterisk];  redtab[5].opindex := 6;
redtab[6].opsymbol := character[equals];  redtab[6].opindex := 21;
redtab[7].opsymbol := character[notequal];  redtab[7].opindex := 22;
redtab[8].opsymbol := character[lessthan];  redtab[8].opindex := 23;
redtab[9].opsymbol := character[lessorequal];  redtab[9].opindex := 24;
redtab[10].opsymbol := character[greaterorequal];  redtab[10].opindex := 25;
redtab[11].opsymbol := character[greaterthan];  redtab[11].opindex := 26;
redtab[12].opsymbol := character[andsymbol];  redtab[12].opindex := 27;
redtab[13].opsymbol := character[orsymbol];  redtab[13].opindex := 28;
redtab[14].opsymbol := character[ceiling];  redtab[14].opindex := 29;
redtab[15].opsymbol := character[floor];  redtab[15].opindex := 30;
redtab[16].opsymbol := character[largecircle];  redtab[16].opindex := 31
end; {fillupredtables}

procedure fillupdigittables;
begin
(* digit characters *)
digits[onesymbol] := 1;
digits[twosymbol] := 2;
digits[threesymbol] := 3;
digits[foursymbol] := 4;
digits[fivesymbol] := 5;
digits[sixsymbol] := 6;
digits[sevensymbol] := 7;
digits[eightsymbol] := 8;
digits[ninesymbol] := 9;
digits[zerosymbol] := 0
end; {fillupdigittables}

begin {aplinit}
setupheap;                                                      (* heap *)
readcherfile;
initparser; (* initialize tables etc. *)
fillupoptables;
fillupspectables;
fillupredtables;
fillupdigittables;
funcmode := false;
firstfunction := true;
oldvaltablink := nil;
oldfunctabptr := nil;
oldvartabptr := nil;
oldtokenptr := nil;
newtokenptr := nil;
newfunctabptr := nil;
newvfuncptr := nil;
holdtokenptr := nil;
tokenerror := false;
newvaltablink := nil;
newvartabptr := nil;
totaldigs := 12;
afterdigs := 2;
rollnum := 5006;
rewrite(outfile, normoutfile);
reset(infile, norminfile);
realsperline := (maxoutputline-6{sizeof(indent)}) div (totaldigs+1)
end; {aplinit}

(*$D+*)


========================================================================================
DOCUMENT :usus Folder:VOLUK04:aplparse0.text
========================================================================================

procedure parser(var tokentabptr: tokenptr;
                 var ptrtoda: typevaltabptr);
var
  vfunchold: ^vfunc;              (* hold while searching *)
  auxopertabptr: ^operandtab;
  auxsubrtabptr: ^subrtab;
  auxrparmptr: ^fparmtab;
  auxlparmptr: ^fparmtab;
  validexp: boolean;              (* true if valid expression *)
  cnt: integer;
  npv: integer;                   (* number of indices *)
  assign, assign1: boolean;       (* assignment in progress *)
  donesuccessor: boolean;
  doneparse: boolean;

procedure expression(var validexp: boolean); forward;

procedure error(errorindex: integer);
begin
  writeln(outfile, 'error ',errorindex,': ', errormsgs[errorindex]);
  exit(parser) (* return to scanner *)
end; {error}

procedure release;
begin (* realease oprtab *)
  opertabptr := ptrlastoper;
  while opertabptr^.lastoper <> nil do
    begin
      auxopertabptr := opertabptr;
      opertabptr := opertabptr^.lastoper;
      ridoper(auxopertabptr)
    end
end; {release}

procedure returntocallingsubr;
var
  nameptr: ^vartab;
begin (* returntocallingsubr *)
  if subrtabptr^.calledsubr^.result
  then
    begin (* place explicit result in opertab *)
      if not nameinvartable(subrtabptr^.calledsubr^.resultname,
                            nameptr, subrtabptr^.calledsubr)
      then error(11) (* symbol not found *)
      else
        begin
          auxopertabptr := opertabptr;
          getoper(opertabptr);
          opertabptr^.lastoper := auxopertabptr;
          ptrlastoper := opertabptr;
          opertabptr^.operptr := nameptr^.valtabptr
        end
    end;
  (* return to calling function *)
  vfuncptr := subrtabptr^.statemcallingsubr;
  tokentabptr := subrtabptr^.tokencallingsubr^.nextoken;
  if subrtabptr^.calledsubr^.arity <> niladic
  then
    begin (* monadic or dyadic *)
      auxrparmptr := rparmptr;
      rparmptr := rparmptr^.lastparm;
      ridfparm(auxrparmptr);
      if subrtabptr^.calledsubr^.arity = dyadic
      then
        begin (* dyadic only *)
          auxlparmptr := lparmptr;
          lparmptr := lparmptr^.lastparm;
          ridfparm(auxlparmptr)
        end
    end;
  auxsubrtabptr := subrtabptr;
  subrtabptr := subrtabptr^.lastsubrptr;
  ridsubr(auxsubrtabptr)
end; {returntocallingsubr}

function specsymbol(sym: integer): boolean;
var
  validsym: boolean;
begin (* specsymbol *)
  validsym := false;
  if tokentabptr^.noun = specoper
  then
    if tokentabptr^.charindx = sym
    then
      begin
        hold := tokentabptr;
        tokentabptr := tokentabptr^.nextoken;
        validsym := true
      end;
  specsymbol := validsym
end; {specsymbol}

procedure callsubr;
var
  ptrtovartab: ^vartab;
begin (* callsubr *)
  if subrtabptr^.calledsubr^.arity <> niladic
  then
    begin
      if not nameinvartable(subrtabptr^.calledsubr^.rightarg,
                            ptrtovartab, subrtabptr^.calledsubr)
      then error(32); (* error in function argument *)
      if ptrtovartab^.functabptr <> subrtabptr^.calledsubr
      then error(32); (* program logic error, variable name of *)
                      (* function argument not found in symbol table *)
      auxrparmptr := rparmptr;
      getfparm(rparmptr);
      rparmptr^.lastparm := auxrparmptr;
      ptrtovartab^.deferedvaltabptr := rparmptr;
      if subrtabptr^.calledsubr^.arity = dyadic
      then
        begin (* if dyadic *)
          if not nameinvartable(subrtabptr^.calledsubr^.leftarg,
                                ptrtovartab, subrtabptr^.calledsubr)
          then error(33); (* same as error(32) *)
          if ptrtovartab^.functabptr <> subrtabptr^.calledsubr
          then error(33);
          auxlparmptr := lparmptr;
          getfparm(lparmptr);
          lparmptr^.lastparm := auxlparmptr;
          ptrtovartab^.deferedvaltabptr := lparmptr;
          lparmptr^.ptrval := opertabptr^.operptr;
          auxopertabptr := opertabptr;
          opertabptr := opertabptr^.lastoper;
          ridoper(auxopertabptr);
          ptrlastoper := opertabptr
        end;
      rparmptr^.ptrval := opertabptr^.operptr;
      auxopertabptr := opertabptr;
      opertabptr := opertabptr^.lastoper;
      ridoper(auxopertabptr);
      ptrlastoper := opertabptr
    end;
  subrtabptr^.tokencallingsubr := tokentabptr;
  tokentabptr := subrtabptr^.calledsubr^.firstatement^.nextstmnt;
  vfuncptr := subrtabptr^.calledsubr^.firstatement
end; {callsubr}

function functcall: boolean;
var
  ptrtofunctab: ^functab;
  nameoffunc: packedstring;
  validfn: boolean;
begin (* functcall *)
  validfn := false;
  if tokentabptr^.noun = globvar
  then
    begin
      nameoffunc := tokentabptr^.vartabptr^.varname;
      if funcalreadydefined(nameoffunc, ptrtofunctab)
      then
        begin
          auxsubrtabptr := subrtabptr;
          getsubr(subrtabptr);
          subrtabptr^.lastsubrptr := auxsubrtabptr;
          subrtabptr^.calledsubr := ptrtofunctab;
          subrtabptr^.tokencallingsubr := tokentabptr;
          subrtabptr^.statemcallingsubr := vfuncptr;
          hold := tokentabptr;
          tokentabptr := tokentabptr^.nextoken;
          validfn := true
        end
    end;
  functcall := validfn
end; {functcall}

procedure numwrite(realno: real);
var
  prefix, root: integer;
  sigdig, colcnt: integer;
begin (* output a number *)
  if realno >= 0.0
  then write(outfile, ' ', realno:totaldigs:afterdigs)
    (* output positive number *)
  else
    begin (* output negative number *)
      realno := -1.0 * realno;
      sigdig := trunc((ln(realno))/(ln(10.0)));
      for colcnt := 1 to (((totaldigs - afterdigs) - 3) - sigdig) do
        write(outfile, ' ');
      write(outfile, character[negative]);
      sigdig := sigdig + afterdigs + 3;
      write(outfile, realno:sigdig:afterdigs)
    end
end; {numwrite}

procedure outputval;
var
  cnt: integer;
  auxvaluesptr: ^values;
  dimhold: integer;
  dimen1, dimen2, dimen3: integer;
  outcnt1, outcnt2, outcnt3: integer;
  idimens: integer;
begin (* outputval *)
  cnt := 0;
  write(outfile, indent);
  if not opertabptr^.operptr^.forwardorder
  then reverselinklist(opertabptr^.operptr);
  auxvaluesptr := opertabptr^.operptr^.firstvalue;
  idimens := opertabptr^.operptr^.dimensions;
  if not (idimens in [0..3])
  then write(outfile, errormsgs[60])
  else
    if auxvaluesptr = nil
    then write(outfile, errormsgs[61])
    else
      if idimens = 0
      then numwrite(auxvaluesptr^.realval)
      else
        begin
          dimen1 := opertabptr^.operptr^.firstdimen^.dimenlength;
          if idimens >= 2
          then
            dimen2 := opertabptr^.operptr^.firstdimen^.nextdimen^.dimenlength
          else dimen2 := 1;
          if idimens = 3
          then dimen3 :=
            opertabptr^.operptr^.firstdimen^.nextdimen^.nextdimen^.dimenlength
          else dimen3 := 1;
          if idimens = 3
          then
            begin (* rotate dimensions *)
              dimhold := dimen1;
              dimen1 := dimen2;
              dimen2 := dimen3;
              dimen3 := dimhold
            end;
          for outcnt3 := 1 to dimen3 do
            begin
              for outcnt2 := 1 to dimen1 do
                begin
                  for outcnt1 := 1 to dimen2 do
                    begin
                      cnt := cnt + 1;
                      if (((cnt-1) mod realsperline) = 0) and (cnt <> 1)
                      then writeln(outfile);
                      numwrite(auxvaluesptr^.realval);
                      auxvaluesptr := auxvaluesptr^.nextvalue
                    end;
                  if idimens >= 2
                  then
                    begin
                      writeln(outfile); write(outfile, indent);
                      cnt := 0
                    end
                end;
              if idimens = 3
              then
                begin
                  writeln(outfile); writeln(outfile); write(outfile, indent)
                end
            end
        end;
  writeln(outfile)
end; {outputval}


========================================================================================
DOCUMENT :usus Folder:VOLUK04:aplparse1.text
========================================================================================

function variable: boolean;
var
  globordummy: boolean;         (* gord *)
  passedadj: ^vartab;           (* k *)
  rarg: boolean;                (* rd *)
  parmptr: ^valtab;             (* pt *)
  validvar: boolean;
  validindex: boolean;

procedure inputval;
var
  auxptrtoda: ^valtab;
  auxvaluesptr: ^values;
  aux2valuesptr: ^values;
  realv: real;
  boolv: boolean;
  ccntr, cnt: integer;
  auxdimeninfoptr: ^dimeninfo;
begin (* inputval *)
  cnt := 0;
  position := 1;
  auxptrtoda := ptrtoda;
  getvalt(ptrtoda);
  if auxptrtoda = nil
  then auxptrtoda := ptrtoda
  else auxptrtoda^.nextvaltablink := ptrtoda;
  auxopertabptr := opertabptr;
  getoper(opertabptr);
  ptrlastoper := opertabptr;
  opertabptr^.lastoper := auxopertabptr;
  opertabptr^.operptr := ptrtoda;
  getvalu(aux2valuesptr);
  ptrtoda^.firstvalue := aux2valuesptr;
  getaplstatement;
  repeat
    makeanumber(realv, boolv);
    skipspaces;
    if not boolv
    then
      begin
        for colcnt := 1 to messagelength do
          write(outfile, errormsgs[62, colcnt]);
        writeln(outfile);
        position := 1;
        cnt := 0;
        aux2valuesptr := opertabptr^.operptr^.firstvalue;
        getaplstatement
      end
    else
      begin
        cnt := cnt + 1;
        auxvaluesptr := aux2valuesptr;
        getvalu(aux2valuesptr);
        auxvaluesptr^.realval := realv;
        auxvaluesptr^.nextvalue := aux2valuesptr
      end
  until position > linelength;
  ridvalu(aux2valuesptr);
  auxvaluesptr^.nextvalue := nil;
  ptrtoda^.intermedresult := false;
  ptrtoda^.dimensions := 1;
  ptrtoda^.forwardorder := true;
  ptrtoda^.nextvaltablink := nil;
  getdim(auxdimeninfoptr);
  ptrtoda^.firstdimen := auxdimeninfoptr;
  auxdimeninfoptr^.dimenlength := cnt;
  auxdimeninfoptr^.nextdimen := nil
end; {inputval}

procedure getarrayposition(var valuesptr: typevaluesptr);
var
  indice: real;
  kcnt: integer;
  sl: integer;
  auxdimeninfoptr: ^dimeninfo;
begin (* getarrayposition *)
  if npv <> parmptr^.dimensions
  then error(45); (* wrong number of subscripts *)
  sl := 0;
  auxopertabptr := opertabptr;
  auxdimeninfoptr := parmptr^.firstdimen;
  for kcnt := 1 to npv do
    begin
      if auxopertabptr^.operptr^.dimensions <> 0
      then error(35); (* non-scalar indices *)
      indice := auxopertabptr^.operptr^.firstvalue^.realval;
      if indice - 1.0*trunc(indice) <> 0.0
      then error(37); (* non-integer indices *)
      if not (trunc(indice) in [1..auxdimeninfoptr^.dimenlength])
      then error(38); (* out of range index *)
      sl := (sl*auxdimeninfoptr^.dimenlength) + trunc(indice) - 1;
      auxopertabptr := auxopertabptr^.lastoper;
      ridoper(opertabptr);
      opertabptr := auxopertabptr;
      auxdimeninfoptr := auxdimeninfoptr^.nextdimen
    end;
  valuesptr := parmptr^.firstvalue;
  while sl <> 0 do (*              determine which value in               *)
                   (* pt[sval(sv)], pt[sval(sv-1)] ... pt[sval(sv-npv+1)] *)
                   (*                  := sval(sv-npv)                    *)
    begin
      valuesptr := valuesptr^.nextvalue;
      sl := sl - 1
    end
end; {getarrayposition}

procedure linkresults;
var
  ptrtovalues: ^values;
begin (* linkresults *)
  if npv = 0
  then
    begin
      if not globordummy
      then
        if rarg
        then rparmptr^.ptrval := opertabptr^.operptr
        else lparmptr^.ptrval := opertabptr^.operptr
      else passedadj^.valtabptr := opertabptr^.operptr
    end
  else
    begin
      if globordummy
      then parmptr := passedadj^.valtabptr
      else parmptr := passedadj^.deferedvaltabptr^.ptrval;
      getarrayposition(ptrtovalues);
      if opertabptr^.operptr^.dimensions <> 0
      then error(36); (* assigned expression not a scalar *)
      ptrtovalues^.realval := opertabptr^.operptr^.firstvalue^.realval
    end;
  auxopertabptr := opertabptr;
  opertabptr := opertabptr^.lastoper;
  ridoper(auxopertabptr);
  ptrlastoper := opertabptr
end; {linkresults}

procedure stackpointers;
var
  auxptrtoda: ^valtab;
  ptrtovalues, auxvaluesptr: ^values;
begin (* stackpointers *)
  if npv = 0
  then
    begin
      auxopertabptr := opertabptr;
      getoper(opertabptr);
      opertabptr^.lastoper := auxopertabptr;
      opertabptr^.operptr := parmptr;
      ptrlastoper := opertabptr
    end
  else
    begin
      auxptrtoda := ptrtoda;
      getvalt(ptrtoda);
      ptrtoda^.nextvaltablink := auxptrtoda;
      ptrtoda^.intermedresult := true;
      ptrtoda^.dimensions := 0;
      ptrtoda^.firstdimen := nil;
      ptrtoda^.forwardorder := true;
      getvalu(auxvaluesptr);
      ptrtoda^.firstvalue := auxvaluesptr;
      getarrayposition(ptrtovalues);
      ptrtoda^.firstvalue^.realval := ptrtovalues^.realval;
      ptrtoda^.firstvalue^.nextvalue := nil;
      auxopertabptr := opertabptr;
      getoper(opertabptr);
      opertabptr^.lastoper := auxopertabptr;
      opertabptr^.operptr := ptrtoda;
      ptrlastoper := opertabptr
    end
end; {stackpointers}

function simplevariable: boolean;
var
  validsv: boolean;
begin (* simplevariable *)
  validsv := false;
  rarg := false;
  globordummy := false;
  if assign
  then
    begin
      if (tokentabptr^.noun = formres)
         or (tokentabptr^.noun = globvar)
      then
        begin
          globordummy := true;
          passedadj := tokentabptr^.vartabptr;
          hold := tokentabptr;
          tokentabptr := tokentabptr^.nextoken;
          validsv := true
        end
      else
        if tokentabptr^.noun = formarg
        then
          begin
            if namesmatch(tokentabptr^.vartabptr^.functabptr^.leftarg,
                          tokentabptr^.vartabptr^.varname)
            then rarg := true;
            passedadj := tokentabptr^.vartabptr
          end
    end
  else
    begin
      if (tokentabptr^.noun = formres)
         or (tokentabptr^.noun = globvar)
      then
        begin
          parmptr := tokentabptr^.vartabptr^.valtabptr;
          if parmptr <> nil
          then
            begin
              hold := tokentabptr;
              tokentabptr := tokentabptr^.nextoken;
              validsv := true
            end
        end
      else
        begin
          if tokentabptr^.noun = formarg
          then
            begin
              if namesmatch(tokentabptr^.vartabptr^.functabptr^.leftarg,
                            tokentabptr^.vartabptr^.varname)
              then parmptr := lparmptr^.ptrval
              else parmptr := rparmptr^.ptrval;
              hold := tokentabptr;
              tokentabptr := tokentabptr^.nextoken;
              validsv := true
            end
        end
    end;
  simplevariable := validsv
end; {simplevariable}

procedure index(var validi: boolean);
var
  valide1, valide2: boolean;
begin (* index *)
  validi := false;
  expression(valide1);
  if valide1
  then
    begin
      npv := 1; (* no. of index expressions *)
      while specsymbol(xsemicolsym) do
        begin
          npv := npv + 1;
          expression(valide2);
          if not valide2
          then error(39) (* invalid index expression *)
        end;
      validi := true
    end
end; {index}

begin (* variable *)
validvar := false;
npv := 0;
if not assign
then
  if specsymbol(xquadsym)
  then
    begin
      inputval;
      validvar := true
    end
  else
    begin
      if specsymbol(xrightbracket)
      then
        begin
          index(validindex);
          if (not validindex) or (not specsymbol(xleftbracket))
          then error(34) (* invalid index expression *)
        end;
      if simplevariable
      then
        begin
          stackpointers;
          validvar := true
        end
    end
else
  if specsymbol(xquadsym)
  then
    begin
      outputval;
      validvar := true
    end
  else
    begin
      if specsymbol(xrightbracket)
      then
        begin
          index(validindex);
          if (not validindex) or (not specsymbol(xleftbracket))
          then error(34) (* invalid index expression *)
        end;
      if simplevariable
      then
        begin
          linkresults;
          validvar := true
        end
    end;
variable := validvar
end; {variable}


========================================================================================
DOCUMENT :usus Folder:VOLUK04:aplparse2.text
========================================================================================

procedure primary(var valid: boolean); (* recursive entry *)
var
  validx: boolean;
  assign: boolean;

function vector: boolean;
var
  vec: boolean;
begin (* vector *)
  vec := false;
  if tokentabptr^.noun = constant
  then
    begin
      auxopertabptr := opertabptr;
      getoper(opertabptr);
      ptrlastoper := opertabptr;
      opertabptr^.lastoper := auxopertabptr;
      opertabptr^.operptr := tokentabptr^.valtabptr;
      hold := tokentabptr;
      tokentabptr := tokentabptr^.nextoken;
      vec := true
    end;
  vector := vec
end; {vector}

begin (* primary *)
valid := true;
if not vector
then
  begin
    assign := false;
    if not variable
    then
      if specsymbol(xrightpar)
      then
        begin
          expression(validx);
          if not validx
          then error(14) (* non-valid expression within parens *)
          else
            if not specsymbol(xleftpar)
            then error(15) (* right paren not balanced with left paren *)
            else valid := true
        end
      else
        if not functcall
        then valid := false
        else
          begin
            callsubr;
            primary(valid)
          end
  end
end; {primary}

procedure expression{var validexp: boolean}; (* recursive *)
var
  donexp: boolean;
  validpri, validfunc, validassn: boolean;
  code: integer;

procedure assignment(var valida: boolean);
begin (* assignment *)
  valida := false;
  if specsymbol(xleftarrow)
  then
    begin
      assign := true;
      assign1 := true;
      if variable
      then valida := true
      else error(8); (* result of an assn not a valid variable *)
      valida := true;
      assign := false
    end
end; {assignment}

function mop: boolean;
var
  validm: boolean;
begin (* mop *)
  validm := false;
  if (tokentabptr^.noun = monadoper)
     or (tokentabptr^.noun = reductoper)
  then
    begin
      if tokentabptr^.noun = monadoper
      then code := moptab[tokentabptr^.monindx].opindex
      else code := redtab[tokentabptr^.redindx].opindex;
      hold := tokentabptr;
      tokentabptr := tokentabptr^.nextoken;
      validm := true
    end;
  mop := validm
end; {mop}

function dop: boolean;
var
  validd: boolean;
begin (* dop *)
  validd := false;
  if tokentabptr^.noun = dyadoper
  then
    begin
      code := doptab[tokentabptr^.dopindx].opindex;
      hold := tokentabptr;
      tokentabptr := tokentabptr^.nextoken;
      if (code > 80)
      then validd := true
      else
        if tokentabptr^.noun = specoper
        then
          if specsymbol(xperiod)
          then
            begin
              if tokentabptr^.noun = dyadoper
              then
                begin
                  if doptab[tokentabptr^.dopindx].opindex <= 80
                  then
                    begin
                      code := code + 100*doptab[tokentabptr^.dopindx].opindex;
                      hold := tokentabptr;
                      tokentabptr := tokentabptr^.nextoken;
                      validd := true
                    end
                  else error(27) (* invalid inner product exp *)
                end
              else
                if tokentabptr^.noun = specoper
                then
                  begin
                    if specsymbol(xlittlecircle)
                    then
                      begin
                        code := 10*code;
                        validd := true
                      end
                    else error(26) (* inval outer prod exp *)
                  end
                else error(26) (* same as above *)
            end
          else validd := true
        else validd := true
    end;
  dop := validd
end; {dop}

function itsboolean(test: real): boolean;
begin
  if (test = 1.0) or (test = 0.0)
  then itsboolean := true
  else itsboolean := false
end; {itsboolean}

procedure dyadcomp(var sfloat: real; value: real; code: integer);
begin (* compute result of dyadic operation *)
  case code of (* left codes - reduction ops / right code - dyadic ops *)
    2, 52: sfloat := value + sfloat;            (* addition *)
    3, 53: sfloat := value - sfloat;            (* subtraction *)
    4, 54: sfloat := value * sfloat;            (* multiplication *)
    5, 55: if sfloat = 0.0                      (* division *)
           then error(20) (* attempted division by zero *)
           else sfloat := value / sfloat;
    6, 56: if value > 0.0                       (* number raised to a power *)
           then sfloat := exp(sfloat * ln(value))
           else sfloat := 1.0 / (exp(sfloat * ln(abs(value))));
   21, 71: if value = sfloat                    (* equality *)
           then sfloat := 1.0
           else sfloat := 0.0;
   22, 72: if value <> sfloat                   (* inequality *)
           then sfloat := 1.0
           else sfloat := 0.0;
   23, 73: if value < sfloat                    (* less than *)
           then sfloat := 1.0
           else sfloat := 0.0;
   24, 74: if value <= sfloat                   (* less than or equal to *)
           then sfloat := 1.0
           else sfloat := 0.0;
   25, 75: if value >= sfloat                   (* greater than or equal to *)
           then sfloat := 1.0
           else sfloat := 0.0;
   26, 76: if value > sfloat                    (* greater than *)
           then sfloat := 1.0
           else sfloat := 0.0;
   27, 77: if (itsboolean(value)) and (itsboolean(sfloat))
           then                                 (* and *)
             if (value = 1.0) and (sfloat = 1.0)
             then sfloat := 1.0
             else sfloat := 0.0
           else error(19); (* value not boolean *)
   28, 78: if (itsboolean(value)) and (itsboolean(sfloat))
           then                                 (* or *)
             if (value = 1.0) or (sfloat = 1.0)
             then sfloat := 1.0
             else sfloat := 0.0
           else error(19); (* value not boolean *)
   29:     if value > sfloat                    (* maximum or ceiling *)
           then sfloat := value;
   30:     if value < sfloat                    (* minimum or floor *)
           then sfloat := value;
   31:     if (value*sfloat) < 0.0              (* log to a base *)
           then error(50) (* number and base of different sign *)
           else sfloat := (ln(abs(sfloat))) / (ln(abs(value)))
  end (* case *)
end; {dyadcomp}

procedure indexgenerator(arg: typevaltabptr); (* monadic iota generator *)
var
  iotaindex: integer;
  topvalue: integer;
begin
  if arg^.dimensions <> 0
  then error(21) (* argument not a scalar *)
  else
    if arg^.firstvalue^.realval < 0.0
    then error(22) (* argument is negative *)
    else
      if arg^.firstvalue^.realval <> trunc(arg^.firstvalue^.realval)
      then error(23) (* argument is not an integer *)
      else
        begin
          getvalt(newvaltablink);
          oldvaltablink^.nextvaltablink := newvaltablink;
          newvaltablink^.nextvaltablink := nil;
          newvaltablink^.forwardorder := true;
          newvaltablink^.intermedresult := true;
          newvaltablink^.dimensions := 1; (* result is a vector *)
          getdim(newdim);
          newvaltablink^.firstdimen := newdim;
          topvalue := trunc(arg^.firstvalue^.realval); (* last index generd *)
          newdim^.dimenlength := topvalue;
          newdim^.nextdimen := nil;
          iotaindex := 1;
          switch := true;
          while iotaindex <= topvalue do
            begin
              getvalu(newvalues);
              newvalues^.realval := iotaindex;
              if switch = true
              then
                begin
                  switch := false;
                  newvaltablink^.firstvalue := newvalues
                end
              else newvalptr^.nextvalue := newvalues;
              newvalptr := newvalues;
              iotaindex := iotaindex + 1
            end;
          if switch = true
          then newvaltablink^.firstvalue := nil
               (* result is a vector of length 0 *)
          else newvalues^.nextvalue := nil
        end
end; {indexgenerator}

procedure ravel(arg: typevaltabptr); (* monadic comma operator *)
var
  elements: integer;
begin
  getvalt(newvaltablink);
  oldvaltablink^.nextvaltablink := newvaltablink;
  newvaltablink^.nextvaltablink := nil;
  newvaltablink^.intermedresult := true;
  newvaltablink^.forwardorder := arg^.forwardorder;
  newvaltablink^.dimensions := 1; (* result is a vector *)
  getdim(newdim);
  newvaltablink^.firstdimen := newdim;
  newdim^.nextdimen := nil;
  switch := true;
  valptr := arg^.firstvalue;
  elements := 0;
  while valptr <> nil do
    begin (* duplicate values into result *)
      getvalu(newvalues);
      newvalues^.realval := valptr^.realval;
      elements := elements + 1;
      if switch = true
      then
        begin
          switch := false;
          newvaltablink^.firstvalue := newvalues
        end
      else newvalptr^.nextvalue := newvalues;
      newvalptr := newvalues;
      valptr := valptr^.nextvalue
    end;
  newdim^.dimenlength := elements;
  if switch = true
  then newvaltablink^.firstvalue := nil
  else newvalues^.nextvalue := nil
end; {ravel}

procedure shapeof(arg: typevaltabptr); (* monadic rho operator *)
begin
  getvalt(newvaltablink);
  oldvaltablink^.nextvaltablink := newvaltablink;
  newvaltablink^.nextvaltablink := nil;
  newvaltablink^.intermedresult := true;
  newvaltablink^.forwardorder := true;
  newvaltablink^.dimensions := 1; (* result is a vector *)
  getdim(newdim);
  newdim^.dimenlength := arg^.dimensions;
  newvaltablink^.firstdimen := newdim;
  newdim^.nextdimen := nil;
  switch := true;
  dimptr := arg^.firstdimen;
  while dimptr <> nil do
    begin (* argument dimensions become result values *)
      getvalu(newvalues);
      newvalues^.realval := dimptr^.dimenlength;
      if switch = true
      then
        begin
          switch := false;
          newvaltablink^.firstvalue := newvalues
        end
      else newvalptr^.nextvalue := newvalues;
      newvalptr := newvalues;
      dimptr := dimptr^.nextdimen
    end;
  if switch = true
  then newvaltablink^.firstvalue := nil (* result is a vector of length 0 *)
  else newvalues^.nextvalue := nil
end; {shapeof}

procedure reduction(arg: typevaltabptr);
var
  counter: integer;
  rowlength: integer;
  sfloat: real;
begin
  if (arg^.dimensions = 0) or (arg^.firstvalue = nil)
  then error(24) (* argument is a scalar or vector of length zero *)
  else
    if (arg^.dimensions = 1) and (arg^.firstdimen^.dimenlength = 1)
    then error(51) (* argument is a vector of length one *)
    else
      begin
        getvalt(newvaltablink);
        oldvaltablink^.nextvaltablink := newvaltablink;
        newvaltablink^.nextvaltablink := nil;
        newvaltablink^.intermedresult := true;
        if arg^.forwardorder = true
        then reverselinklist(arg);
        newvaltablink^.forwardorder := false;
        newvaltablink^.dimensions := arg^.dimensions - 1;
        dimptr := arg^.firstdimen;
        switch := true;
        while dimptr^.nextdimen <> nil do
          begin (* build dimensions of result *)
            getdim(newdim);
            if switch = true
            then
              begin
                switch := false;
                newvaltablink^.firstdimen := newdim
              end
            else newptr^.nextdimen := newdim;
            newdim^.dimenlength := dimptr^.dimenlength;
            newptr := newdim;
            dimptr := dimptr^.nextdimen
          end;
        if switch = true
        then newvaltablink^.firstdimen := nil
             (* arg is a vector, result is scalar *)
        else newdim^.nextdimen := nil;
        rowlength := dimptr^.dimenlength;
        valptr := arg^.firstvalue;
        switch := true;
        while valptr <> nil do
          begin (* perform reduction *)
            sfloat := valptr^.realval; (* sfloat gets last value in row *)
            valptr := valptr^.nextvalue;
            for counter := 2 to rowlength do
              begin
                dyadcomp(sfloat, valptr^.realval, code);
                valptr := valptr^.nextvalue
              end;
            getvalu(newvalues);
            newvalues^.realval := sfloat;
            if switch = true
            then
              begin
                switch := false;
                newvaltablink^.firstvalue := newvalues
              end
            else newvalptr^.nextvalue := newvalues;
            newvalptr := newvalues
          end;
        newvalues^.nextvalue := nil
      end
end; {reduction}

procedure roll(rollsize: real; var rollresult: real);
const
  rollmult = -23571;
  rolladd = 7473;
  twotothe16 = 65536.0;
var
  temprollnum: real;
begin
  rollnum := rollnum*rollmult + rolladd;
  if rollnum < 0
  then temprollnum := twotothe16 + rollnum
  else temprollnum := rollnum;
  rollresult := trunc(rollsize*(temprollnum/twotothe16) + 1.0)
end; {roll}

procedure monadic(arg: typevaltabptr; token: tokenptr);
(* operations with codes between 1 and 31 *)
begin
  if token^.noun = reductoper
  then reduction(arg)
  else
    if code > 20
    then
      case code of
        21: indexgenerator(arg);
        22: shapeof(arg);
        23: ravel(arg)
      end (* case *)
    else
      begin
        getvalt(newvaltablink);
        oldvaltablink^.nextvaltablink := newvaltablink;
        newvaltablink^.nextvaltablink := nil;
        newvaltablink^.intermedresult := true;
        newvaltablink^.forwardorder := arg^.forwardorder;
        newvaltablink^.dimensions := arg^.dimensions;
        switch := true;
        dimptr := arg^.firstdimen;
        while dimptr <> nil do
          begin (* duplicate dimensions of arg into result *)
            getdim(newdim);
            newdim^.dimenlength := dimptr^.dimenlength;
            if switch = true
            then
              begin
                switch := false;
                newvaltablink^.firstdimen := newdim
              end
            else newptr^.nextdimen := newdim;
            newptr := newdim;
            dimptr := dimptr^.nextdimen
          end;
        if switch = true
        then newvaltablink^.firstdimen := nil (* result is a scalar *)
        else newdim^.nextdimen := nil;
        switch := true;
        valptr := arg^.firstvalue;
        while valptr <> nil do
          begin
            getvalu(newvalues);
            if switch = true
            then
              begin
                switch := false;
                newvaltablink^.firstvalue := newvalues
              end
            else newvalptr^.nextvalue := newvalues;
            newvalptr := newvalues;
            case code of
              1: if itsboolean(valptr^.realval) (* logical negation *)
                 then newvalues^.realval := 1.0 - valptr^.realval
                 else error(19); (* value not boolean *)
              2: newvalues^.realval := valptr^.realval; (* no-op *)
              3: newvalues^.realval := 0.0 - valptr^.realval; (* negation *)
              4: if valptr^.realval > 0.0 (* signum *)
                 then newvalues^.realval := 1.0
                 else
                   if valptr^.realval < 0.0
                   then newvalues^.realval := -1.0
                   else newvalues^.realval := 0.0;
              5: if valptr^.realval = 0.0 (* reciprocal *)
                 then error(54) (* attempted inverse of zero *)
                 else newvalues^.realval := 1.0 / valptr^.realval;
              6: newvalues^.realval := exp(valptr^.realval); (* exp *)
              9: if valptr^.realval = trunc(valptr^.realval) (* ceiling *)
                 then newvalues^.realval := valptr^.realval
                 else newvalues^.realval := trunc(valptr^.realval + 1.0);
             10: newvalues^.realval := trunc(valptr^.realval); (* floor *)
              7: if trunc(valptr^.realval) <> valptr^.realval
                 then error(23) (* argument is not an integer *)
                 else
                   if valptr^.realval < 0.0
                   then error(22) (* argument is negative *)
                   else roll(valptr^.realval, newvalues^.realval) (* roll *)
            end; (* case *)
            valptr := valptr^.nextvalue
          end;
        if switch = true
        then newvaltablink^.firstvalue := nil
        else newvalues^.nextvalue := nil
      end
end; {monadic}

procedure catenate(leftarg, rightarg: typevaltabptr);
(* dyadic comma operator - joins 2 arguments *)
var
  resultlength: integer;
begin (* catenate *)
  if (rightarg^.dimensions > 1) or (leftarg^.dimensions > 1)
  then error(53) (* argument(s) with rank greater than 1 *)
  else
    begin
      getvalt(newvaltablink);
      oldvaltablink^.nextvaltablink := newvaltablink;
      newvaltablink^.nextvaltablink := nil;
      newvaltablink^.intermedresult := true;
      if leftarg^.forwardorder = false
      then reverselinklist(leftarg);
      if rightarg^.forwardorder = false
      then reverselinklist(rightarg);
      newvaltablink^.forwardorder := true;
      newvaltablink^.dimensions := 1; (* result is a vector *)
      getdim(newdim);
      newvaltablink^.firstdimen := newdim;
      newdim^.nextdimen := nil;
      resultlength := 0;
      if leftarg^.dimensions = 0
      then resultlength := resultlength + 1 (* leftarg is a scalar *)
      else resultlength := resultlength + leftarg^.firstdimen^.dimenlength;
      if rightarg^.dimensions = 0
      then resultlength := resultlength + 1 (* rightarg is a scalar *)
      else resultlength := resultlength + rightarg^.firstdimen^.dimenlength;
      newdim^.dimenlength := resultlength;
      switch := true;
      if resultlength = 0
      then newvaltablink^.firstvalue := nil (* result is vector of length 0 *)
      else
        begin (* transfer values to result *)
          leftvalptr := leftarg^.firstvalue;
          while leftvalptr <> nil do
            begin (* transfer left arg values (if any) *)
              getvalu(newvalues);
              if switch = true
              then
                begin
                  switch := false;
                  newvaltablink^.firstvalue := newvalues
                end
              else newvalptr^.nextvalue := newvalues;
              newvalues^.realval := leftvalptr^.realval;
              newvalptr := newvalues;
              leftvalptr := leftvalptr^.nextvalue
            end;
          rightvalptr := rightarg^.firstvalue;
          while rightvalptr <> nil do
            begin (* transfer right arg values (if any) *)
              getvalu(newvalues);
              if switch = true
              then
                begin
                  switch := false;
                  newvaltablink^.firstvalue := newvalues
                end
              else newvalptr^.nextvalue := newvalues;
              newvalues^.realval := rightvalptr^.realval;
              newvalptr := newvalues;
              rightvalptr := rightvalptr^.nextvalue
            end;
          newvalues^.nextvalue := nil
        end (* transfer of values *)
    end
end; {catenate}

procedure indexof(leftarg, rightarg: typevaltabptr);
(* dyadic iota operator *)
var
  mapindex,
  icount,
  testlength,
  onemore: integer;
begin (* indexof *)
  if leftarg^.dimensions <> 1
  then error(29) (* left argument is not a vector *)
  else
    begin
      getvalt(newvaltablink);
      oldvaltablink^.nextvaltablink := newvaltablink;
      newvaltablink^.nextvaltablink := nil;
      newvaltablink^.intermedresult := true;
      if leftarg^.forwardorder = false
      then reverselinklist(leftarg);
      newvaltablink^.forwardorder := rightarg^.forwardorder;
      newvaltablink^.dimensions := rightarg^.dimensions;
      if rightarg^.dimensions = 0
      then newvaltablink^.firstdimen := nil (* right argument is a scalar *)
      else
        begin (* build dimensions of result *)
          switch := true;
          dimptr := rightarg^.firstdimen;
          while dimptr <> nil do
            begin
              getdim(newdim);
              if switch = true
              then
                begin
                  switch := false;
                  newvaltablink^.firstdimen := newdim
                end
              else newptr^.nextdimen := newdim;
              newdim^.dimenlength := dimptr^.dimenlength;
              newptr := newdim;
              dimptr := dimptr^.nextdimen
            end;
          newdim^.nextdimen := nil
        end;
      switch := true;
      rightvalptr := rightarg^.firstvalue;
      while rightvalptr <> nil do
        begin
          getvalu(newvalues);
          if switch = true
          then
            begin
              switch := false;
              newvaltablink^.firstvalues := newvalues
            end
          else newvalptr^.nextvalue := newvalues;
          icount := 1;
          leftvalptr := leftarg^.firstvalue;
          testlength := leftarg^.firstdimen^.dimenlength;
                        (* length of left arg *)
          onemore := testlength + 1; (* length of left arg plus one !!! *)
          mapindex := onemore;
          while (icount <= testlength) and (mapindex = onemore) do
            begin (* try to match value in right arg with one in left arg *)
              if leftvalptr^.realval = rightvalptr^.realval
              then mapindex := icount; (*value match *)
              icount := icount + 1;
              leftvalptr := leftvalptr^.nextvalue
            end;
          newvalues^.realval := mapindex;
          newvalptr := newvalues;
          rightvalptr := rightvalptr^.nextvalue
        end; (* if no match, index becomes one more than length of left arg *)
      newvalues^.nextvalue := nil
    end
end; {indexof}

procedure reshape(leftarg, rightarg: typevaltabptr);
(* dyadic rho operator - change dimensions of *)
var
  resultlength,
  elements: integer;
  dimptr: ^dimeninfo;
  newptr: ^values;
begin (* reshape *)
  if leftarg^.dimensions > 1
  then error(56) (* left argument is not a vector or a scalar *)
  else
    begin
      getvalt(newvaltablink);
      oldvaltablink^.nextvaltablink := newvaltablink;
      newvaltablink^.nextvaltablink := nil;
      newvaltablink^.intermedresult := true;
      if leftarg^.forwardorder = false
      then reverselinklist(leftarg);
      if rightarg^.forwardorder = false
      then reverselinklist(rightarg);
      newvaltablink^.forwardorder := true;
      if leftarg^.firstdimen = nil
      then newvaltablink^.dimensions := 1
      else newvaltablink^.dimensions := leftarg^.firstdimen^.dimenlength;
      resultlength := 1;
      leftvalptr := leftarg^.firstvalue;
      switch := true;
      while leftvalptr <> nil do (* left arg values are dimensions of result *)
        begin (* build result dimensions *)
          resultlength := resultlength*trunc(leftvalptr^.realval);
          getdim(newdim);
          newdim^.dimenlength := trunc(leftvalptr^.realval);
          leftvalptr := leftvalptr^.nextvalue;
          if switch = true
          then
            begin
              switch := false;
              newvaltablink^.firstdimen := newdim
            end
          else dimptr^.nextdimen := newdim;
          dimptr := newdim;
        end;
      newdim^.nextdimen := nil;
      rightvalptr := rightarg^.firstvalue;
      elements := 0;
      switch := true;
      while elements < resultlength do
        begin (* duplicate right arg values into result values *)
          elements := elements + 1;
          getvalu(newvalues);
          if rightvalptr = nil (* extend right argument if necessary *)
          then rightvalptr := rightarg^.firstvalue;
          newvalues^.realval := rightvalptr^.realval;
          if switch = true
          then
            begin
              switch := false;
              newvaltablink^.firstvalue := newvalues
            end
          else newptr^.nextvalue := newvalues;
          newptr := newvalues;
          rightvalptr := rightvalptr^.nextvalue
        end;
      newvalues^.nextvalue := nil
    end
end; {reshape}

procedure innerproduct(leftarg, rightarg: typevaltabptr);
var
  inpro1code, inpro2code: integer;
  leftskip, rightskip: integer;
  icount, jcount, kcount, lcount, mcount: integer;
  lastleftdim,
  firstrightdim,
  commonlength: integer;
  lptr: ^values;
  hold: real;
  sfloat: real;
  value: real;
begin (* inner product is matrix multiplication *)
  dimptr := leftarg^.firstdimen;
  if leftarg^.firstdimen <> nil
  then
    while dimptr^.nextdimen <> nil do
      dimptr := dimptr^.nextdimen; (* get last dimen of left arg (if any) *)
  if (dimptr <> nil) and (rightarg^.firstdimen <> nil)
  then
    if dimptr^.dimenlength <> rightarg^.firstdimen^.dimenlength
    then error(52) (* last dim of left arg not = first dim of right arg *)
    else
      begin
        inpro1code := code div 100; (* seperate operators *)
        inpro2code := code mod 100;
        getvalt(newvaltablink);
        oldvaltablink^.nextvaltablink := newvaltablink;
        newvaltablink^.nextvaltablink := nil;
        newvaltablink^.intermedresult := true;
        if leftarg^.forwardorder = false
        then reverselinklist(leftarg);
        if rightarg^.forwardorder = false
        then reverselinklist(rightarg);
        newvaltablink^.forwardorder := true;
        newvaltablink^.dimensions :=
          leftarg^.dimensions + rightarg^.dimensions - 2;
        if newvaltablink^.dimensions < 0
        then newvaltablink^.dimensions := 0;
        switch := true;
        lastleftdim := 0;
        if leftarg^.firstdimen <> nil
        then
          begin (* copy all but last of left arg dims into result *)
            leftskip := 1;
            dimptr := leftarg^.firstdimen;
            while dimptr^.nextdimen <> nil do
              begin (* copy left arg dimensions *)
                getdim(newdim);
                newdim^.dimenlength := dimptr^.dimenlength;
                leftskip := leftskip*dimptr^.dimenlength;
                if switch = true
                then
                  begin
                    switch := false;
                    newvaltablink^.firstdimen := newdim
                  end
                else newptr^.nextdimen := newdim;
                newptr := newdim;
                dimptr := dimptr^.nextdimen
              end;
            lastleftdim := dimptr^.dimenlength
          end;
        if rightarg^.firstdimen <> nil
        then
          begin (* copy all but last of right arg dims into result *)
            rightskip := 1;
            dimptr := rightarg^.firstdimen^.nextdimen;
            while dimptr <> nil do
              begin (* copy right arg dimensions *)
                getdim(newdim);
                newdim^.dimenlength := dimptr^.dimenlength;
                rightskip := rightskip*dimptr^.dimenlength;
                if switch = true
                then
                  begin
                    switch := false;
                    newvaltablink^.firstdimen := newdim
                  end
                else newptr^.nextdimen := newdim;
                newptr := newdim;
                dimptr := dimptr^.nextdimen
              end
          end;
        if switch = true
        then newvaltablink^.firstdimen := nil
        else newdim^.nextdimen := nil;
        if leftarg^.firstvalue = nil then leftskip := 0;
        if rightarg^.firstvalue = nil then rightskip := 0;
        switch := true;
        if rightarg^.firstdimen <> nil
        then firstrightdim := rightarg^.firstdimen^.dimenlength
        else firstrightdim := 0;
        if firstrightdim > lastleftdim
        then commonlength := firstrightdim
        else commonlength := lastleftdim;
        icount := 0;
        leftvalptr := leftarg^.firstvalue;
        while icount < leftskip do
          begin (* loop for each row in left arg *)
            lptr := leftvalptr; (* hold start of row position *)
            jcount := 0;
            while jcount < rightskip do
              begin (* loop for each column in right arg *)
                leftvalptr := lptr;
                rightvalptr := rightarg^.firstvalue;
                lcount := 0;
                while lcount < jcount do
                  begin (* skip to starting value in right arg *)
                    rightvalptr := rightvalptr^.nextvalue;
                    if rightvalptr = nil
                    then rightvalptr := rightarg^.firstvalue; (* extend arg *)
                    lcount := lcount + 1
                  end;
                kcount := 0;
                while kcount < commonlength do
                  begin (* loop for each element in row/column *)
                    sfloat := rightvalptr^.realval;
                    dyadcomp(sfloat, leftvalptr^.realval, inpro2code);
                    value := sfloat;
                    if kcount = 0
                    then (* set identity value for first time through *)
                      case inpro1code of
                        52, 53, 78:             sfloat := 0.0;
                        54, 55, 56, 77:         sfloat := 1.0;
                        71, 72, 73, 74, 75, 76: (* null case *)
                      end (* case *)
                    else sfloat := hold;
                    dyadcomp(sfloat, value, inpro1code);
                    hold := sfloat; (* save summer result *)
                    leftvalptr := leftvalptr^.nextvalue;
                    if leftvalptr = nil
                    then leftvalptr := leftarg^.firstvalue; (* extend arg *)
                    mcount := 0;
                    while mcount < rightskip do
                      begin (* skip to next value in right arg *)
                        mcount := mcount + 1;
                        rightvalptr := rightvalptr^.nextvalue;
                        if rightvalptr = nil
                        then rightvalptr := rightarg^.firstvalue
                      end;
                    kcount := kcount + 1
                  end;
                getvalu(newvalues);
                newvalues^.realval := sfloat;
                if switch = true
                then
                  begin
                    switch := false;
                    newvaltablink^.firstvalue := newvalues
                  end
                else newvalptr^.nextvalue := newvalues;
                newvalptr := newvalues;
                jcount := jcount + 1
              end;
            icount := icount + 1
          end;
        if switch = true
        then newvaltablink^.firstvalue := nil
        else newvalues^.nextvalue := nil
      end
end; {innerproduct}

procedure outerproduct(leftarg, rightarg: typevaltabptr);
var
  outprocode: integer;
  sfloat: real;
begin
  outprocode := code div 10;
  getvalt(newvaltablink);
  oldvaltablink^.nextvaltablink := newvaltablink;
  newvaltablink^.nextvaltablink := nil;
  newvaltablink^.intermedresult := true;
  if leftarg^.forwardorder = false
  then reverselinklist(leftarg);
  if rightarg^.forwardorder = false
  then reverselinklist(rightarg);
  newvaltablink^.forwardorder := true;
  newvaltablink^.dimensions := leftarg^.dimensions + rightarg^.dimensions;
  switch := true;
  dimptr := leftarg^.firstdimen;
  while dimptr <> nil do
    begin (* copy left arg dimensions to result *)
      getdim(newdim);
      newdim^.dimenlength := dimptr^.dimenlength;
      if switch = true
      then
        begin
          switch := false;
          newvaltablink^.firstdimen := newdim
        end
      else newptr^.nextdimen := newdim;
      newptr := newdim;
      dimptr := dimptr^.nextdimen
    end;
  dimptr := rightarg^.firstdimen;
  while dimptr <> nil do
    begin (* copy right arg dimensions to result *)
      getdim(newdim);
      newdim^.dimenlength := dimptr^.dimenlength;
      if switch = true
      then
        begin
          switch := false;
          newvaltablink^.firstdimen := newdim
        end
      else newptr^.nextdimen := newdim;
      newptr := newdim;
      dimptr := dimptr^.nextdimen
    end;
  if switch = true
  then newvaltablink^.firstdimen := nil
  else newdim^.nextdimen := nil;
  switch := true;
  leftvalptr := leftarg^.firstvalue;
  while leftvalptr <> nil do
    begin
      rightvalptr := rightarg^.firstvalue;
      while rightvalptr <> nil do
        begin
          sfloat := rightvalptr^.realval;
          dyadcomp(sfloat, leftvalptr^.realval, outprocode);
          getvalu(newvalues);
          if switch = true
          then
            begin
              switch := false;
              newvaltablink^.firstvalue := newvalues
            end
          else newvalptr^.nextvalue := newvalues;
          newvalues^.realval := sfloat;
          newvalptr := newvalues;
          rightvalptr := rightvalptr^.nextvalue
        end;
      leftvalptr := leftvalptr^.nextvalue
    end;
  if switch = true
  then newvaltablink^.firstvalue := nil
  else newvalues^.nextvalue := nil
end; {outerproduct}

procedure dyadic(leftarg, rightarg: typevaltabptr);
(* operators with codes of 52 and higher *)
var
  compatible: boolean;
  arg: typevaltabptr;
  sfloat: real;
begin
  if code > 1000
  then innerproduct(leftarg, rightarg)
  else
    if code > 100
    then outerproduct(leftarg, rightarg)
    else
      if code > 80
      then
        case code of
          87: indexof(leftarg, rightarg);
          88: reshape(leftarg, rightarg);
          89: catenate(leftarg, rightarg)
        end (* case *)
      else
        begin (* simple dyadics *)
          compatible := true;
          if (leftarg^.dimensions >= 1) and (rightarg^.dimensions >= 1)
          then
            if leftarg^.dimensions <> rightarg^.dimensions
            then compatible := false (* different ranks/neither scalar *)
            else
              begin (* ranks match - check lengths *)
                leftdimptr := leftarg^.firstdimen;
                rightdimptr := rightarg^.firstdimen;
                while leftdimptr <> nil do
                  begin
                    if leftdimptr^.dimenlength <> rightdimptr^.dimenlength
                    then compatible := false; (* different length(s) *)
                    leftdimptr := leftdimptr^.nextdimen;
                    rightdimptr := rightdimptr^.nextdimen
                  end
              end;
          if compatible = true (* arguments suitable for dyadic operation *)
          then
            begin (* build dimensions of result *)
              if rightarg^.dimensions > leftarg^.dimensions
              then arg := rightarg
              else arg := leftarg; (* result has shape of larger arg *)
              getvalt(newvaltablink);
              oldvaltablink^.nextvaltablink := newvaltablink;
              newvaltablink^.nextvaltablink := nil;
              newvaltablink^.intermedresult := true;
              if leftarg^.forwardorder <> rightarg^.forwardorder
              then reverselinklist(leftarg);
              newvaltablink^.forwardorder := arg^.forwardorder;
              newvaltablink^.dimensions := arg^.dimensions;
              switch := true;
              dimptr := arg^.firstdimen;
              while dimptr <> nil do
                begin (* copy dimensions to result *)
                  getdim(newdim);
                  newdim^.dimenlength := dimptr^.dimenlength;
                  if switch = true
                  then
                    begin
                      switch := false;
                      newvaltablink^.firstdimen := newdim
                    end
                  else newptr^.nextdimen := newdim;
                  newptr := newdim;
                  dimptr := dimptr^.nextdimen
                end;
              if switch = true
              then newvaltablink^.firstdimen := nil (* result is a scalar *)
              else newdim^.nextdimen := nil;
              switch := true;
              rightvalptr := rightarg^.firstvalue;
              leftvalptr := leftarg^.firstvalue;
              valptr := arg^.firstvalue;
              while valptr <> nil do
                begin (* perform operation *)
                  getvalu(newvalues);
                  sfloat := rightvalptr^.realval;
                  dyadcomp(sfloat, leftvalptr^.realval, code);
                  newvalues^.realval := sfloat;
                  if switch = true
                  then
                    begin
                      switch := false;
                      newvaltablink^.firstvalue := newvalues
                    end
                  else newvalptr^.nextvalue := newvalues;
                  newvalptr := newvalues;
                  valptr := valptr^.nextvalue;
                  leftvalptr := leftvalptr^.nextvalue;
                  rightvalptr := rightvalptr^.nextvalue;
                  if leftvalptr = nil
                  then leftvalptr := leftarg^.firstvalue; (* extend arg *)
                  if rightvalptr = nil
                  then rightvalptr := rightarg^.firstvalue (* extend *)
                end;
              if switch = true
              then newvaltablink^.firstvalue := nil (* vector of len 0 *)
              else newvalues^.nextvalue := nil
            end
          else error(55) (* arguments incompatible for dyadic operation *)
        end
end; {dyadic}

procedure funcall(var validfunk: boolean);
var
  validpm: boolean;
begin (* funcall *)
  validfunk := false;
  if functcall
  then
    begin
      if tokentabptr^.noun <> statend
      then
        begin
          subrtabptr^.tokencallingsubr := tokentabptr;
          primary(validpm);
          if not validpm
          then error(17) (* leftarg of dyadic func call not a primary *)
        end;
      callsubr;
      validfunk := true
    end
end; {funcall}

begin (* expression *)
primary(validpri);
if not validpri
then
  begin
    if tokentabptr^.noun = statend
    then
      begin
        validexp := true;
        assign1 := true
      end
    else validexp := false
  end
else
  begin
    donexp := false;
    while not donexp do
      begin
        funcall(validfunc);
        if validfunc
        then
          begin
            expression(validexp);
            donexp := true
          end
        else
          begin
            assignment(validassn);
            if validassn and (tokentabptr^.noun = statend)
            then
              begin
                donexp := true;
                validexp := true
              end;
            if not validassn
            then
              if mop
              then
                begin
                  monadic(opertabptr^.operptr, hold);
                  opertabptr^.operptr := newvaltablink
                end
              else
                if not dop
                then
                  begin
                    validexp := true;
                    donexp := true
                  end
                else
                  begin
                    primary(validpri);
                    if not validpri
                    then error(13) (* dyad oper not preceded by a pri *)
                    else
                      begin
                        dyadic(opertabptr^.operptr,
                               opertabptr^.lastoper^.operptr);
                        auxopertabptr := opertabptr;
                        opertabptr := opertabptr^.lastoper;
                        ptrlastoper := opertabptr;
                        ridoper(auxopertabptr);
                        opertabptr^.operptr := newvaltablink
                      end
                  end
          end
      end
  end
end; {expression}

========================================================================================
DOCUMENT :usus Folder:VOLUK04:aplparse3.text
========================================================================================

begin (* parser *)
assign := false;
assign1 := false;
doneparse := false;
repeat
  expression(validexp); (* check for valid expression *)
  if not validexp
  then error(10) (* invalid expression *)
  else
    if specsymbol(xrightarrow)
    then
      if not ((opertabptr^.operptr^.firstvalue = nil) and
              (opertabptr^.operptr^.dimensions > 0))
      then (* branch *)
        (* result of expression is at opertabptr *)
        if opertabptr^.operptr^.firstvalue^.realval <>
           trunc(opertabptr^.operptr^.firstvalue^.realval)
        then error(12) (* stmt.num.to branch to not an integer *)
        else
          if subrtabptr = nil
          then
            begin (* interpretive *)
              tokentabptr := hold;
              doneparse := true
            end
          else (* function mode *)
            if trunc(opertabptr^.operptr^.firstvalue^.realval)
               in [1..(subrtabptr^.calledsubr^.numofstatements)]
            then
              begin
                vfunchold := subrtabptr^.calledsubr^.firstatement;
                for cnt := 1 to trunc(opertabptr^.operptr^.firstvalue^.realval)
                do
                  begin
                    vfuncptr := vfunchold;
                    tokentabptr := vfuncptr^.nextstmnt;
                    vfunchold := vfuncptr^.nextvfuncptr
                  end;
                auxopertabptr := opertabptr;
                opertabptr := opertabptr^.lastoper;
                ridoper(auxopertabptr);
                ptrlastoper := opertabptr;
                tokentabptr := vfuncptr^.nextstmnt
              end
            else (* successor *)
      else (* successor *)
    else (* successor *)
      begin
        if not assign1
        then outputval;
        assign1 := false;
        if subrtabptr = nil
        then
          begin (* interpretive *)
            hold := tokentabptr;
            tokentabptr := tokentabptr^.nextoken;
            doneparse := true
          end
        else (* function *)
          begin
            vfuncptr := vfuncptr^.nextvfuncptr;
            donesuccessor := false;
            repeat
              if vfuncptr <> nil
              then
                begin
                  tokentabptr := vfuncptr^.nextstmnt;
                  donesuccessor := true
                end
              else
                begin
                  returntocallingsubr;
                  if tokentabptr^.noun = statend
                  then donesuccessor := true
                end
            until donesuccessor
          end
      end
until doneparse;
release (* release memory *)
end; {parser}


========================================================================================
DOCUMENT :usus Folder:VOLUK04:aplprocs.text
========================================================================================

procedure printaplstatement;
begin
  writeln(outfile, aplstatement)
end; {printaplstatement}

procedure serror(errorindex: integer);
var
  msgcol: integer;
begin
tokenerror := true;
writeln(outfile, errormsgs[errorindex]);
printaplstatement; (* echo statement to user *)
for msgcol := 1 to (position - 1) do
  write(outfile, ' ');
writeln(outfile, character[uparrow]) (* print pointer to user error *)
end; {serror}

procedure skipspaces;
begin
while (aplstatement[position] = character[space])
      and (position <= linelength) do
  position := position + 1
end; {skipspaces}

procedure getaplstatement;
var
  inputchars: string;
begin
  (* blank out line *)
fillchar(aplstatement, sizeof(aplstatement), character[space]);
linelength := 0;
position := 1;
linetoolong := false;
aplstatement[inputarraysize] := character[omega];
aplstatement[inputarraysize - 1] := character[space]; (* set end-of-line *)
repeat
  begin
    write(outfile, character[quadrangle]);
    if funcmode
    then write(outfile, character[leftbracket], funcstatements + 1: 2,
               character[rightbracket], character[space])
    else write(outfile, '    ', character[space]);
    readln(infile, inputchars);
    while (linelength < length(inputchars)) and (not linetoolong) do
      if linelength < maxinputline
      then
        begin
          linelength := linelength + 1;
          aplstatement[linelength] := inputchars[linelength]
        end
      else linetoolong := true
  end
until linelength <> 0; (* reject null lines *)
if linetoolong then serror(71)
end; {getaplstatement}

function itsadigit(testchar: char): boolean;
var
  digitindex: aplcharset;
begin (* test to see if input character is a digit *)
itsadigit := true;
for digitindex := onesymbol to zerosymbol do
  if testchar = character[digitindex] then exit(itsadigit);
itsadigit := false
end; {itsadigit}

function itsaletter(testchar: char): boolean;
var
  letterindex: aplcharset;
begin (* test to see if input character is a letter *)
itsaletter := true;
for letterindex := asymbol to zsymbol do
  if testchar = character[letterindex] then exit(itsaletter);
itsaletter := false
end; {itsaletter}

function chartonum(testchar: char): integer;
var
  digitindex: aplcharset;
begin (* change a character to a number *)
for digitindex := onesymbol to zerosymbol do
  if testchar = character[digitindex]
  then
    begin
      chartonum := digits[digitindex];
      exit(chartonum)
    end
end; {chartonum}

function namesmatch{nameone, nametwo: packedstring): boolean};
begin (* see if two names (identifiers) are the same *)
namesmatch := nameone = nametwo
end; {namesmatch}

procedure tablelookup(testchar: char; tablelength: integer; table: optable;
                      var tableindex: integer);
var
  index: integer;
begin (* check for membership in a given table *)
tableindex := 0;
for index := 1 to tablelength do
  if testchar = table[index].opsymbol
  then
    begin
      tableindex := index;
      exit(tablelookup)
    end
end; {tablelookup}

procedure identifier(var name: packedstring; var itsanidentifier: boolean);
var
  namelength: integer;
  nametoolong: boolean;
begin
itsanidentifier := false;
skipspaces;
if itsaletter(aplstatement[position])
then
  begin
    nametoolong := false;
    itsanidentifier := true;
    for namelength := 1 to maxvarnamelength do (* blank out name *)
      name[namelength] := character[space];
    namelength := 0;
    while (itsaletter(aplstatement[position])) or
          (itsadigit(aplstatement[position])) do
      begin (* build identifier *)
        namelength := namelength + 1;
        if namelength <= maxvarnamelength
        then name[namelength] := aplstatement[position]
        else nametoolong := true;
        position := position + 1
      end;
    if nametoolong
    then serror(70) (* name greater than maxlength *)
  end
end; {identifier}

procedure makeanumber{var realnumber: real; var itsanumber: boolean};
var
  sign, digitcount: integer;
begin (* convert character input string to numerical representation *)
itsanumber := false;
skipspaces;
sign := 1;
digitcount := 0;
realnumber := 0.0;
if (aplstatement[position] = character[negative]) or
   (itsadigit(aplstatement[position]))
then
  begin
    itsanumber := true;
    if aplstatement[position] = character[negative]
    then
      begin
        sign := -1;
        position := position + 1
      end;
    if not itsadigit(aplstatement[position])
    then
      begin
        serror(1); (* digit must follow a minus sign *)
        itsanumber := false
      end
    else
      begin (* form whole number portion *)
        while itsadigit(aplstatement[position]) do
          begin
            realnumber := 10.0*realnumber + chartonum(aplstatement[position]);
            position := position + 1
          end;
        if aplstatement[position] = character[period]
        then
          begin
            position := position + 1;
            while itsadigit(aplstatement[position]) do
              begin (* form fractional portion *)
                realnumber := realnumber +
                              (chartonum(aplstatement[position]) /
                              pwroften(digitcount + 1));
                digitcount := digitcount + 1;
                position := position + 1
              end;
            if digitcount = 0
            then
              begin
                serror(2); (* digits must follow a decimal point *)
                itsanumber := false
              end
          end;
        realnumber := realnumber * sign
      end
  end
end; {makeanumber}

function monadicreference: boolean;
var
  subposition, tableindex: integer;
begin (* see if operator is monadic within context of input line *)
monadicreference := false;
if newtokenptr^.nextoken^.noun = statend
then monadicreference := true
else
  begin
    subposition := position - 1;
    while (subposition > 0) and
          (aplstatement[subposition] = character[space]) do
      subposition := subposition - 1; (* get last non-blank *)
    if subposition <> 0
    then tablelookup(aplstatement[subposition],
                     spectablength, spectab, tableindex);
    if (tableindex <> 0) or (subposition = 0)
    then monadicreference := true
    else
      if (newtokenptr^.nextoken^.noun <> formres) and
         (newtokenptr^.nextoken^.noun <> formarg) and
         (newtokenptr^.nextoken^.noun <> globvar) and
         (newtokenptr^.nextoken^.noun <> constant) and
         (aplstatement[subposition] <> character[period]) and
         (aplstatement[subposition] <> character[rightparen]) and
         (aplstatement[subposition] <> character[rightbracket])
      then monadicreference := true
  end
end; {monadicreference}

procedure dyadicopcheck;
var
  tableindex: integer;
begin
tablelookup(aplstatement[position], doptablength, doptab, tableindex);
if tableindex = 0
then
  begin
    tablelookup(aplstatement[position], chartablength, chartab, tableindex);
    if tableindex = 0
    then
      if aplstatement[position] = character[southcap]
      then
        begin
          oldtokenptr := savetokenptr;
          ridtoken(newtokenptr);
          newtokenptr := savetokenptr;
          position := linelength + 1
        end (* this was a comment - ignore remainder of line *)
      else serror(4) (* invalid character encountered *)
    else
      begin (* special character encountered *)
        newtokenptr^.noun := specoper;
        newtokenptr^.charindx := tableindex
      end
  end
else
  if monadicreference
  then serror(74) (* monadic reference to dyadic operator *)
  else
    begin (* operator is dyadic *)
      newtokenptr^.noun := dyadoper;
      newtokenptr^.dopindx := tableindex
    end
end; {dyadicopcheck}

procedure checkothertables;
var
  tableindex: integer;
  chkindex: integer;
function nextnonblank: char;
  begin
  chkindex := position + 1;
  while (chkindex < linelength) and
        (aplstatement[chkindex] = character[space]) do
    chkindex := chkindex + 1;
  nextnonblank := aplstatement[chkindex]
  end; {nextnonblank}
begin
if nextnonblank = character[forwardslash]
then
  begin
    tablelookup(aplstatement[position], redtablength, redtab, tableindex);
    if tableindex = 0
    then serror(72) (* invalid reduction operator *)
    else
      if not monadicreference
      then serror(73) (* dyadic reduction reference *)
      else
        begin (* operator is valid reduction operator *)
          newtokenptr^.noun := reductoper;
          newtokenptr^.redindx := tableindex
        end;
    position := chkindex + 1
  end
else
  begin
    tablelookup(aplstatement[position], moptablength, moptab, tableindex);
    if tableindex = 0
    then dyadicopcheck
    else
      if not monadicreference
      then dyadicopcheck
      else
        begin (* operator is monadic *)
          newtokenptr^.noun := monadoper;
          newtokenptr^.monindx := tableindex
        end;
    position := position + 1
  end
end; {checkothertables}

procedure trytogetanumber;
var
  numbercount: integer;
  realnumber: real;
  itsanumber: boolean;
begin
numbercount := 0;
makeanumber(realnumber, itsanumber);
if not itsanumber
then checkothertables
else
  begin (* store values in value table *)
    getvalt(newvaltablink);
    newvaltablink^.nextvaltablink := oldvaltablink;
    oldvaltablink := newvaltablink;
    newvaltablink^.forwardorder := true;
    if funcmode
    then newvaltablink^.intermedresult := false
    else newvaltablink^.intermedresult := true;
    switch := true;
    while itsanumber do
      begin
        numbercount := numbercount + 1;
        getvalu(newvalues);
        if switch = true
        then
          begin
            switch := false;
            newvaltablink^.firstvalue := newvalues
          end
        else newvalptr^.nextvalue := newvalues;
        newvalues^.realval := realnumber;
        newvalptr := newvalues;
        makeanumber(realnumber, itsanumber)
      end;
    newvalues^.nextvalue := nil;
    if numbercount > 1
    then
      begin
        newvaltablink^.dimensions := 1; (* number is a vector *)
        getdim(newdim);
        newvaltablink^.firstdimen := newdim;
        newdim^.dimenlength := numbercount;
        newdim^.nextdimen := nil
      end
    else
      begin
        newvaltablink^.dimensions := 0;
        newvaltablink^.firstdimen := nil
      end;
    newtokenptr^.noun := constant;
    newtokenptr^.valtabptr := newvaltablink
  end
end; {trytogetanumber}

function nameinvartable{name: packedstring;
                        var varpointer: vartabptrtype;
                        testfuncptr: ptrfunctab): boolean};
var
  found: boolean;
begin
found := false;
varpointer := oldvartabptr;
while (varpointer <> nil) and (found = false) do
  begin
    if (namesmatch(name, varpointer^.varname)) and
       (varpointer^.functabptr = testfuncptr) (* test for global var *)
    then found := true
    else varpointer := varpointer^.nextvartabptr
  end;
nameinvartable := found
end; {nameinvartable}

procedure addnametovartable(name: packedstring);
begin (* new variable name encountered *)
getvarr(newvartabptr);
newvartabptr^.nextvartabptr := oldvartabptr;
oldvartabptr := newvartabptr;
newvartabptr^.varname := name;
newvartabptr^.valtabptr := nil;
if newtokenptr <> nil
then
  if (newtokenptr^.noun = formres) or (newtokenptr^.noun = formarg)
  then newvartabptr^.functabptr := newfunctabptr
  else newvartabptr^.functabptr := nil
end; {addnametovartable}

function funcalreadydefined{var newfuname: packedstring;
                            var funcindex: ptrfunctab): boolean};
var
  found: boolean;
begin
found := false;
funcindex := oldfunctabptr;
while (funcindex <> nil) and (found = false) and (newfunctabptr <> nil) do
  if namesmatch(funcindex^.funcname, newfuname)
  then found := true
  else funcindex := funcindex^.nextfunctabptr;
funcalreadydefined := found
end; {funcalreadydefined}

procedure maketokenlink;
begin
gettoken(newtokenptr);
newtokenptr^.nextoken := oldtokenptr;
savetokenptr := oldtokenptr;
oldtokenptr := newtokenptr
end; {maketokenlink}

procedure processfunctionheader;
var
  dummyptr: ^functab;
  name1, name2, name3: packedstring;
  itsanidentifier: boolean;
  funcheaderror: boolean;
  arityindex: integer;
begin
funcheaderror := false;
funcmode := true;
funcstatements := -1;
if firstfunction
then
  begin
    funcstatements := 0;
    firstfunction := false
  end;
arityindex := 1;
position := position + 1;
identifier(name1, itsanidentifier);
if not itsanidentifier
then
  begin
    serror(7); (* unrecognizable function/argument name *)
    funcmode := false; (* exit function mode *)
    funcheaderror := true
  end
else
  begin
    getfunc(newfunctabptr);
    skipspaces;
    if aplstatement[position] = character[leftarrow]
    then
      begin
        newfunctabptr^.result := true; (* explicit result *)
        newfunctabptr^.resultname := name1;
        position := position + 1;
        identifier(name1, itsanidentifier);
        if not itsanidentifier
        then
          begin
            serror(6); (* unrecognizable name to right of explicit result *)
            funcheaderror := true
          end
      end
    else newfunctabptr^.result := false; (* no explicit result *)
    skipspaces;
    if (position <= linelength) and (not funcheaderror)
    then
      begin
        identifier(name2, itsanidentifier);
        if not itsanidentifier
        then
          begin
            serror(7); (* invalid function/argument name *)
            funcheaderror := true
          end
        else arityindex := 2
      end;
    skipspaces;
    if (position <= linelength) and (not funcheaderror)
    then
      begin
        identifier(name3, itsanidentifier);
        if not itsanidentifier
        then
          begin
            serror(9); (* invalid function right argument name *)
            funcheaderror := true
          end
        else arityindex := 3
      end;
    skipspaces;
    if (position <= linelength) and (not funcheaderror)
    then
      begin
        serror(3); (* extraneous characters to right of function header *)
        funcheaderror := true
      end;
    case arityindex of
      1: begin
           newfunctabptr^.arity := niladic;
           newfunctabptr^.funcname := name1
         end;
      2: begin
           newfunctabptr^.arity := monadic;
           newfunctabptr^.funcname := name1;
           newfunctabptr^.rightarg := name2;
           addnametovartable(name2);
           newvartabptr^.functabptr := newfunctabptr
         end;
      3: begin
           newfunctabptr^.arity := dyadic;
           newfunctabptr^.leftarg := name1;
           newfunctabptr^.funcname := name2;
           newfunctabptr^.rightarg := name3;
           addnametovartable(name1);
           newvartabptr^.functabptr := newfunctabptr;
           addnametovartable(name3);
           newvartabptr^.functabptr := newfunctabptr
         end;
    end; {case}
    if funcalreadydefined(newfunctabptr^.funcname, dummyptr)
    then
      begin
        serror(5); (* function already defined *)
        funcheaderror := true
      end;
    if funcheaderror
    then
      begin
        ridfunc(newfunctabptr); (* header no good *)
        funcmode := false; (* exit function mode *)
        newfunctabptr := oldfunctabptr
      end
  end
end; {processfunctionheader}

procedure destroystatement;
var
  dumtokenptr: ^tokentable;
  auxsubrtabptr: ^subrtab;
begin
if subrtabptr <> nil
then
  begin
    while subrtabptr^.lastsubrptr <> nil do
      begin
        auxsubrtabptr := subrtabptr;
        subrtabptr := subrtabptr^.lastsubrptr;
        ridsubr(auxsubrtabptr)
      end;
    ridsubr(subrtabptr)
  end;
dumtokenptr := oldtokenptr;
while dumtokenptr <> holdtokenptr do
  begin
    oldtokenptr := oldtokenptr^.nextoken;
    ridtoken(dumtokenptr);
    dumtokenptr := oldtokenptr
  end;
newtokenptr := holdtokenptr;
oldtokenptr := holdtokenptr (* return pointer to end of last good line *)
end; {destroystatement}

procedure reverselinklist{var argptr: typevaltabptr};
var
  hold, temptr: ^values;
begin
valptr := argptr^.firstvalue;
temptr := valptr^.nextvalue;
while temptr <> nil do
  begin
    hold := temptr^.nextvalue;
    temptr^.nextvalue := valptr;
    valptr := temptr;
    temptr := hold
  end;
argptr^.firstvalue^.nextvalue := nil;
argptr^.firstvalue := valptr;
if argptr^.forwardorder = true
then argptr^.forwardorder := false
else argptr^.forwardorder := true (* toggle list order switch *)
end; {reverselinklist}


========================================================================================
DOCUMENT :usus Folder:VOLUK04:contents.text
========================================================================================

USUS(UK) SOFTWARE LIBRARY VOLUME 4                           30-AUG-82

The following material was submitted by Chris Lee, INMOS     10-Feb-82
----------------------------------------------------------------------

The APL program is an adaptation for UCSD pascal of a program by Alan
M Kaniss that appears in the Byte Book Of Pascal. The changes made
were very small, so it is still fairly inefficient.  There are still
probably a few typos in it as well as common or garden bugs.  The APL
subset that has been implemented so far is fairly small and limiting,
such as no character strings, plus things like restictions on where
generalised matrices may be used (bracketing them sometimes helps).
If you find any bugs or write any enhancements I would be grateful if
you could forward them on to me Greg Nunan either via USUS or Inmos
Ltd., Whitefriars, Lewins Mead, Bristol BS1 2NP, England.  

APL.TEXT              The APL Interpreter with its associated include files.
APLPARSE1.TEXT  
APLPARSE2.TEXT  
APLPROCS.TEXT
APLPARSE3.TEXT
APLHEAP.TEXT
APLINIT.TEXT  
APLCHERS.TEXT 
APLPARSE0.TEXT

The following materail was submitted by Morton Ogilvie, ERCC  23-Aug-82
-----------------------------------------------------------------------

SORT/MERGE Package Release 1.3 
SORT.DOC.TEXT    - Full user documentation of the Package, for use
                   under versions II.0, II.1 and IV.0 of the UCSD
                   p-System;

SORT.MERGE.TEXT  - Pascal source of the main program supporting the
                   primary SORT, MERGE and CHECK procedures:
                   configured for use under version IV.0, but with
                   comments indicating modifications required for
                   use under versions II.0 and II.1;

SORT.DUMUN.TEXT  - Pascal source of the minimal User-provided Unit
                   required in addition to the main program, to the
                   define file and record structures and key comparison
                   specifications of the SORT, MERGE and CHECK
                   procedures, and to define intialisation and
                   termination procedures: suitable for TEXT or
                   FILE OF STRING files, with comments indicating
                   modifications required for other file types;

SORT.TXTUN.TEXT  - Pascal source of a more generalised User-provided
                   Unit defining file structures and specifications for
                   SORT, MERGE and CHECK operations for TEXT or FILE
                   OF STRING files, for use under version II.0, II.1
                   or IV.0;




UK Volume 4 continued 

The following material was submitted by Jim McNicol, SCRI     23-Aug-82
-----------------------------------------------------------------------

SPBSSTUFF is an Intrinsic Unit of procedures and functions designed to
ease the problems of error checking in conversational style programs. 
Including Screenops it adds 18 blocks of diskspace to the
SYSTEM.LIBRARY.
          
SPBSSTUFF.TEXT
SPBSSTUFF.CODE
SPBSSDOC1.TEXT
SPBSSDOC2.TEXT

The contents of SPBSSTUFF are:-
          Procedure PrintLine(x,y:integer;s:string);
          Function GetChar(okchars:setofchar):char;
          Function GetCHoice(options:setofchar):char;
          Procedure Goodbye;
          Procedure GetString(var s:string;maxlen:integer;okchars:setofchar);
          Procedure OpenNewFile (var nameoffile:string;s1,s2:string);          
          Procedure OpenOldFile (var nameoffile:string;s1,s2:string);             
          Procedure GetTextfileName(var s:string;s1,s2:string);
          Procedure IoError(ioresult:integer);
          Procedure WriteIoError(ioresult:integer);
          Procedure IntNum(var num:integer;var good:boolean;s:string);
          Procedure RealNum(var num:real;var good:boolean;s:string);
          Procedure GetRealNo(var num:real;termchars:setofchar);
          Procedure GetIntNo(var num:integer;var ok:boolean;maxlen : 
                           integer;termchars: setofchar);
          Function GetReal(x,y:integer;min,max:real):real;
          Function GetInt(x,y:integer;min,max:integer):integer;
          Procedure CheckPrinter;
          Procedure Continue (x,y:integer);
          Procedure Yes:boolean;
          Procedure Bell (times:integer);


CONTENTS.TEXT      This list.
          

========================================================================================
DOCUMENT :usus Folder:VOLUK04:sort.doc.text
========================================================================================

EDINBURGH REGIONAL COMPUTING CENTRE                                TRAINING UNIT


   User Specification for the ERCC UCSD p-System II.0 -IV.0 SORT/MERGE Package


Introduction

     The ERCC UCSD p-System SORT/MERGE Package provides you with facilities for
sorting, merging and checking the order of your files of TEXT or DATA type, with
any record structure you may wish to define.

Access

     You may use the Package under the UCSD p-System (Version II or IV) on any
of the following micro-computers:

     Cromemco System Three
     Intertec Superbrain QD/DD
     Apple II
     Terak 8510
     Sirius 1

     All files referred to in this description as relating to the Package are
obtainable from the United Kingdom UCSD System Users' Society {USUS(UK)} or from
the Microcomputer Support Unit, Edinburgh Regional Computing Centre.

     These TEXT files are identified as follows:

     SORT.DOC.TEXT   - the text of this User Specification for the Package;
     SORT.MERGE.TEXT - the Pascal source code of the main SORT/MERGE Program
                       (configured for use under UCSD Version IV.0, comments
                       indicating modifications for use under Version II.0);
     SORT.DUMUN.TEXT - a minimal User Unit required to complete the Package;
     SORT.TXTUN.TEXT - a general-purpose User Unit for sorting TEXT files
                       or files of STRING (two versions, for use under UCSD
                       Versions II.0/II.1 and IV.0.)

General Description

     The Package performs the following primary procedures:

     Sort  - Sort the contents of a file (TEXT or DATA) into order with respect
             to certain key information held in each line or record (as defined
             by you), placing the sorted records in another nominated file;
             
     Merge - Merge together into a single file the contents of two files of the
             same record structure, which you have already sorted into the
             required order, with respect to the same key information;

     Check - Check that the contents of a TEXT or DATA file are correctly
             ordered with respect to the key information you define.

     [N.B. If your file is of some size, the Sort procedure may need one or two
temporary files, at least as large as your original file, for working space.
These temporary files may, but need not, reside on the same volume as your
original file.   The Sort procedure can, in general, handle a file of up to half
the capacity of a disk volume, while the Merge and Check procedures can handle
a file occupying a full disk.]

     Secondary functions include invoking your own procedures to initialise
information required for the primary procedures and to terminate the primary
procedures as you wish (tidying up, listing or reformatting files, etc.)   In
the UCSD Version IV.0 implementation, you may invoke the FILER at any stage to
assist you in managing your files, automatically returning to the Sort/Merge
Package on leaving the Filer.


File and Record Structures

     The file or files which you present to the Package may be any TEXT files,
containing lines of text, or DATA files, containing structured records of your
own specification.
     
     The ordered file produced by the Sort or Merge procedure need not be of
the same structure as the file or files which you present.   You may define it
to be of whatever structure you wish.

     Further, the key information on which you wish to base the ordering may
not be contained explicitly in the records of the file or files you present
(e.g. you may wish to extract numerical data from lines of text or convert
alphanumeric data from ISO to EBCDIC code, etc.)   You may, therefore wish to
define an intermediate record structure upon which comparisons are to be made.
Any temporary files required by the Sort procedure will be of this intermediate
structure.

     If you wish to change the structure of your records for either of these
reasons, you will need to provide the necessary code to convert from one record
type to the other.   You might wish to include code to select certain records
from the input file and ignore others.

     You will, in any case, need to provide additional code to define exactly
what the key information is and how records are to be compared.

     The code provided in the additional User Unit files, referred to above,
is likely to be suitable for these purposes, for certain common cases.   You
may, therefore, be able to avoid producing your own code or perhaps merely
tailor the provided code to suit your own needs.


The User-provided Unit

     You must specify the structures of your files and any additional file
manipulation procedures you wish to make availabe to the Package, in the form of
a UCSD Pascal Unit.   This Unit must also define the way in which records are to
be compared and must provide any other information necessary to the sorting,
merging or checking procedures which you wish to be conducted.

     A minimal User Unit for sorting TEXT files (or DATA files of FILE OF STRING
type) is provided in the text file:

     SORT.DUMUN.TEXT

(q.v.)   You should include any additional code you may need for any particular
application within the framework defined by that Unit.

     First of all, the Unit must always be called 'SORTSPEC' and you must write
the comment:

     (*$S++*)

immediately before the UNIT SORTSPEC statement, as indicated in the sample Unit.

     The CONST item RUNLENGTH defines the maximum number of records, of
intermediate (SORTTYPE) structure, which are processed in the initial phase of
the Sort procedure, in which segments of the file are sorted into runs, and
copied to a temporary file; these are later merged together into a single,
sorted file.   If your records are more than 80 bytes in length, you may have
to reduce the value of RUNLENGTH to accommodate them in memory in smaller
groups.   Increasing the value of RUNLENGTH will increase the memory
requirement of the procedure, and will prolong the initial phase, but will
reduce the number of merging passes and may reduce the number of temporary
files required.   If RUNLENGTH is at least half the number of records to be
sorted, only one temporary file will be required; if it equals or exceeds the
number of records, the sort will be completed in a single pass, with no need
of temporary files - subject to the availability of sufficient main storage.
Values of 20480 DIV SIZEOF(SORTTYPE) and 10240 DIV SIZEOF(SORTTYPE) will
normally be suitable for the RUNLENGTH parameter in the UCSD Version II and
Version IV implementations, respectively.   If a System Halt or Stack Overflow
condition arises on attempting to execute the Package, you should reduce the
value of RUNLENGTH and try again.

     You may require to replace the definitions of the TYPE identifiers
INPUTTYPE, SORTTYPE and OUTPUTTYPE with the specifications of the record
structures you want your input, intermediate (work files) and output files to
have, respectively.  [SORTTYPE is the record structure on which the comparison
of key information is based in the Sort, Merge and Check procedures.]

     If you are defining different record structures for your files, you will
next have to write, in the PROCEDURE USERIN, whatever Pascal statements are
needed to convert a record of INPUTTYPE (INPUTREC) into one of SORTTYPE
(SORTREC), and in the PROCEDURE USEROUT the code required to convert from
SORTTYPE (SORTREC) to OUTPUTTYPE (OUTPUTREC).   You may leave these procedures
unchanged if your files are all of the same structure.

     [N.B. In the case of TEXT files, the INPUTTYPE and OUTPUTTYPE declarations
are not used by the Package to define the input and output files; they are,
however, used in the buffering mechanism on input.   They should be defined as
STRING (equivalent to STRING[80]), or STRING[maximum line length], which may
also be a suitable definition for the intermediate SORTTYPE structure.   You may
still define a different SORTTYPE record structure if your key comparison
procedure demands it.   Text lines in the input file which are longer than the
length specified by INPUTTYPE are truncated by the Package, to avoid failure.]

     In any case, you must include in the (BOOLEAN) FUNCTION COMPARE whatever
code you require to compare two records (of SORTTYPE type) and indicate whether
they are correctly ordered [all keys of the two records are equal or any key of
the first record (SORTREC1) takes precedence over the corresponding key of the
second (SORTREC2), all previous keys being equal.]

     If the code you have included in the PROCEDURES USERIN and USEROUT or the
FUNCTION COMPARE requires any preliminary housekeeping (interactive requests
for specifications of keys, etc.) you may include code to perform the operations
you need in the PROCEDURE INITIALISE.   You may leave this procedure empty if
you have no such requirement - but it must still appear in the Unit.

     If you require the Package to perform any housekeeping on conclusion of
the main procedures (e.g. listing the output files), you must include the
required code in the PROCEDURE TERMINATE, in a similar fashion.

     You should insert any declarations of variables or other identifiers
which you may need for any of these purposes immediately after the
IMPLEMENTATION statement.   Any file indentifiers should, however, be declared
in the INTERFACE section, as 'PUBLIC' variables.

     If you intend to run the Package under Version II.0 of the UCSD p-System,
you will require to remove the final 'BEGIN' statement from the Unit.   If,
however, you are using version II.1 or IV.0, you may insert after that 'BEGIN'
statement any code you wish to pre-initialise variables used in the INITIALISE,
USERIN, COMPARE, USEROUT and TERMINATE procedures.

     The code provided in the file SORT.TXTUN.TEXT (q.v.) illustrates a more
generalised form of the User-provided Unit for sorting TEXT files (or DATA
files of FILE OF STRING type), containing lines or records of not more than 80
characters in which up to 6 key fields (of STRING, INTEGER or REAL type) may be
defined in each record or line of text.  The keys are specified interactively,
by invoking the PROCEDURE INITIALISE and the output file may be listed to the
CONSOLE: automatically, by invoking the PROCEDURE TERMINATE.   This Unit may be
altered easily, by changing the values of the CONST items MAXRECL, MAXNOKEYS and 
RUNLENGTH, to specify respectively the maximum length of your records, the
maximum number of keys you require and the number of records of intermediate
type you estimate can be accommodated in memory during the initial sort phase.


Compilation and Linkage of the Package

     Once you have produced your User Unit, you must next compile it.   The
Package demands that you must place the code generated by the Pascal Compiler in
the CODE file:

     SORT.SPEC.CODE

on the System (Boot) Disk.

     Once you have completed the compilation of your Unit, you must now prepare
to compile the code of the main SORT/MERGE Package, in the file:

     SORT.MERGE.TEXT

     If you are using the UCSD Version IV.0 System and you wish to use the
facility to enter the Filer and return to the Package, you must first arrange
for the System Unit contained in the CODE file:

     COMMANDIO.CODE
     
to be on the System (Boot) disk.   Otherwise (if you are running under Version
II.0 or II.1 or you do not wish to use the Filer entry facility) you will need
to edit the file:

     SORT.MERGE.TEXT

as indicated by the comments in the USES statement and the PROCEDURE ENTERFILER. 

     If you are using UCSD Version II, you may place the compiled code in any
file of your choice, say:

     SORT.MERGE.CODE
     
     If you are using the UCSD Version IV.0 System, you must place the compiled
code in the CODE file:

     SORTMERGE.CODE

on the System (Boot) disk.   [N.B. no '.' in the name 'SORTMERGE' this time.]
   
     When you have successfully completed both compilations, you must next link
the two code files together, as follows:

     If you are using the UCSD Version II System:
     
          Enter the Linker (Command L at UCSD System level);
          
          In response to the prompt:
     
             Host File?
     
          type:
     
             SORT.MERGE

          (or whatever you have called your code file compiled from the main
          Package, without '.CODE') and press RETURN;
     
          In response to the prompt:
     
             Lib file?
     
          type:
     
             SORT.SPEC
     
          (the name of the CODE file cotaining you Unit, without '.CODE') and
          press RETURN;
     
          In response to the second prompt:
     
             Lib file?
     
          and the prompt:
     
             Map file?
     
          press RETURN;
     
          In response to the prompt:
     
             Output file?
     
          type:
     
             SORTMERGE.CODE
     
          and press RETURN.   [N.B. No '.' in the name 'SORTMERGE' this time,
          and '.CODE' is essential.]

     If you are using the UCSD Version IV System, link your code files as
     follows:
     
          Enter the Editor (Command E at UCSD System level);
          
          In response to the prompt:
          
               No workfile is present.  File?
               
          press RETURN;
          
          In response to the Editor prompt line, type:
          
               I
               
          type the line:
          
               SORT.SPEC
               
          press RETURN and terminate with CONTROL and C together;
               
          then in response to the Editor prompt line, type:
               
               Q
               W
               
          and in response to the prompt:
               
               Name of output file ->
               
          type:
               
               USERLIB.TEXT
               
          and press RETURN;
          
          [The above creates a search list for automatic linking of your
          Unit.]
          
     This procedure will result in the production of a complete program which
will conduct the sorting, merging and checking operations you have defined.


Execution of the Package

     When you have produced the CODE file:

        SORTMERGE.CODE

by the above compiling and linking operations, you can now execute it, as
follows:

     Type the UCSD System command:

        X SORTMERGE

     The Package will introdue itself and offer the prompt:

        I(nit S(ort M(erge C(heck F(iler T(erm Q(uit:

    [If this does not appear and the system hangs, the most probable cause is
STACK OVERFLOW due to excess memory requirements.   In this case, reduce the
value you have assigned to the RUNLENGTH item in your Unit, repeat the Compiling
and Linking procedures and try again.]

    If you have included code in the PROCEDURE INITIALISE, you should type:

        I

and that procedure will be invoked for you.   Upon its conclusion, the Package
will offer the above prompt again, to allow you to choose another procedure.

     If you want to Sort one of your TEXT or DATA files , type:

        S

and the Sort procedure will be invoked.   Proceed as follows:

     In response to the prompt:

        Sort which file?

     type the name of the file (of INPUTTYPE structure) you want to sort,
     including the disk identifier or drive number and '.TEXT' or '.DATA' as
     appropriate;

     In response to the prompt:

        Into which file?

     type the name of the (new) file (of OUTPUTTYPE structure) in which you wish
     the sorted records to be placed, including the disk identifier or drive
     number and '.TEXT' or '.DATA' as appropriate.   This may be on the same
     disk as your unsorted input file, if you wish;

     In response to the prompt:

        Which work disk?

     type the disk identifier or drive number of a disk which the procedure may
     use to create any temporary work files it may need.   This may be the same
     disk as that containing you unsorted and sorted files.   [Space for at
     least two copies of your records in SORTTYPE format should be available.]

     In response to the prompt:

        Press SPACE or RETURN when ready, ESC to abort

     press the RETURN key, when you have loaded the disks you have nominated
     [pressing the ESC key will abort the Sort procedure and return to
     the prompt line:

        I(nit S(ort M(erge C(heck T(erm Q(uit?

     to allow you to chose another procedure.]

     The Sort procedure will then commence.   Messages such as:

         Sort1 starts
         ... . . . ...
         Sort2 starts
         ... . . . ...
         .
         .
         .
         Merge1 starts
         ... . . . ...
         Merge2 starts
         ... . . . ...
         .
         .
         .

     etc. will be displayed at certain stages of the procedure to allow you to
     monitor its progress.   The 'comfort dots' appearing during each phase
     indicate the number of lines or records transferred to the work files or
     output file.   On conclusion, the Package will return to the original
     prompt, to enable you to choose a further procedure.

     If you type:

        M

the Merge procedure will be entered.   Proceed as follows:

     In response to the prompt:

        Merge which file?

     type the name of the first of the two files (of INPUTTYPE structure,
     already sorted) which you wish to merge together, including the disk
     identifier or drive number and '.TEXT' or '.DATA' as appropriate;

     In response to the prompt:

        With which file?

     type the name of the second file you wish to merge, including the disk
     identifier or drive number and '.TEXT or '.DATA'.   This may be on the same
     disk as the first.   The two files must be of the same type and structure,
     otherwise the procedure will terminate at this point;

     In response to the prompt:

        Into which file?

     type the name of the (new) file (of OUTPUTTYPE structure) into which you
     wish the resultant merged sequence of records to be placed, including the
     disk identifier or drive number and '.TEXT' or '.DATA' as appropriate.
     This file may be on the same disk as the input files, provided sufficient
     space is available;

     The Merging procedure will commence, 'comfort dots' appearing to indicate
     the number of lines or records transferred to the output file.   Upon its
     conclusion, the Package will return to the original prompt, to allow you
     to choose a further procedure.

     If you type:

        C

the Check procedure will be invoked.   Proceed as follows:

     In response to the prompt:

        Check which file?

     type the name of the file (of INPUTTYPE strucutre) you wish to check for
     order against the key specification defined in your Unit, including the
     disk identifier or drive number and '.TEXT' or '.DATA' as appropriate.
     This file may be of OUTPUTTYPE as long as that is the same as INPUTTYPE;

     The Check procedure will commence, 'comfort dots' and asterisks indicating
      the lines or records which are found to be in and out of sequence,
     respectively.   Upon conclusion, the procedure will print a report of the
     form:

        File FILENAME holds N records: M are out of order

     and will return the Package to the original prompt, to allow you to choose
     a further procedure.

     If you type:

        T

the Package will enable you to conclude a Sort, Merge or Check procedure as you
have defined in your PROCEDURE TERMINATE, by invoking that procedure.   On its
conclusion, the Package will return to the original prompt, to allow you to
choose a further procedure.

     If you are using the UCSD Version IV System, you may type:

        F

The Package will automatically invoke the UCSD System Filer.   This will enable
you to manipulate your files and disks between Sort, Merge and Check procedures
without leaving the Sort/Merge Package.   On quitting the Filer (Filer Command
Q), the Package will return to its original prompt, to allow you to choose a
further procedure.

     If you type:

       Q

the Sort/Merge Package will terminate, returning you to main UCSD System
Command level.


Advice and Consultancy

     Any problems relating to the operation of the Sort/Merge Package
should be related to the author, Mr D.D.M. Ogilvie, Training Unit Manager,
ERCC, 59 George Square, Edinburgh EH8 9JU - telephone 031-667 1011 ext 2303.



                                                           D.D.M. Ogilvie
                                                           ERCC
                                                           23rd August, 1982




========================================================================================
DOCUMENT :usus Folder:VOLUK04:sort.dumun.text
========================================================================================

(*$S++*)
UNIT SORTSPEC;

(* File type and key specicification template for SORT/MERGE Package *)

INTERFACE

   CONST RUNLENGTH=256;       (* Set to 20480 DIV SIZEOF(SORTTYPE) or less *)
         
   TYPE INPUTTYPE=STRING;     (* Replace by RECORD TYPE of unsorted file *)
        SORTTYPE=INPUTTYPE;   (* Replace by RECORD TYPE for key comparisons *)
        OUTPUTTYPE=INPUTTYPE; (* Replace by RECORD TYPE for sorted file *)
        
   PROCEDURE INITIALISE;
   PROCEDURE USERIN(INPUTREC: INPUTTYPE; VAR SORTREC: SORTTYPE);
   FUNCTION  COMPARE(SORTREC1, SORTREC2: SORTTYPE): BOOLEAN;
   PROCEDURE USEROUT(SORTREC: SORTTYPE; VAR OUTPUTREC: OUTPUTTYPE);
   PROCEDURE TERMINATE;
   
IMPLEMENTATION
   
   (* Insert declaration of any local variables, etc. required by PROCEDURES
      INITIALISE, USERIN, COMPARE, USEROUT and TERMINATE - these are optional *)
      
   PROCEDURE INITIALISE;
      BEGIN
         (* Insert any code required to initialise local variables required
            by the PROCEDURES USERIN, COMPARE, USEROUT and TERMINATE or to
            manipulate the file to be sorted, etc. - this is optional *)
      END;
   
   PROCEDURE USERIN;
      BEGIN
         SORTREC:=INPUTREC
         (* Replace by any code required to convert an INPUTTYPE RECORD into a
            SORTTYPE RECORD *)
      END;

   FUNCTION COMPARE;
      BEGIN
         COMPARE:=SORTREC1<=SORTREC2
         (* Replace by code required to compare the key fields of two SORTTYPE
            RECORDS and return the result TRUE if they are correctly ordered
            relatively, FALSE if not *)
      END;
      
   PROCEDURE USEROUT;
      BEGIN
         OUTPUTREC:=SORTREC
         (* Replace by any code required to convert a SORTYPE RECORD into an
            OUTPUTTYPE RECORD *)
      END;
      
   PROCEDURE TERMINATE;
      BEGIN
         (* Insert any code required to manipulate the sorted file or
            otherwise conclude the SORT/MERGE Procedures - this is optional *)
      END;
      
(* Remove the following BEGIN statement for use under UCSD Version II.0 *)

BEGIN
   (* Version IV.0 only - Insert any code required to pre-intialise any variables
      defined in the INTERFACE or IMPLEMENTATION sections above. *)
END.

:
========================================================================================
DOCUMENT :usus Folder:VOLUK04:sort.merge.text
========================================================================================

(*$S++*)
(*$R-*)

(* ERCC UCSD p-System II.0-IV.0 SORT/MERGE Package Version 1.3 23-Aug-82 *)

(* Please forward any comments, suggestions, bugs etc. to the author:

      Morton Ogilvie,
      Training Unit Manager,
      Edinburgh Regional Computing Centre,
      59 George Square,
      Edinburgh EH14 5AW,
      Scotland                                                      *)


PROGRAM SORTMERGE(INPUT,OUTPUT,F0,F1,F2,F3,F4,F5,F6,F7,F8);

(* SORT, MERGE and CHECK for TEXT or DATA FILES *)

USES (*$U COMMANDIO.CODE*) COMMANDIO, (*$U SORT.SPEC.CODE*) SORTSPEC;

     (* Remove the references to COMMANDIO above for Version II or
        if Filer entry not required under Version IV.

        SORTSPEC is Unit supplied by user to define file and record
        structures and sorting keys, etc. *)

TYPE DATAARRAY=ARRAY[1..RUNLENGTH] OF SORTTYPE;
     INCHAN=0..5;
     OUTCHAN=6..8;
     FILETYPE=(TXT,INT,OUT);

VAR  F0,F1:TEXT;
     F2,F3:FILE OF INPUTTYPE;
     F4,F5,F6:FILE OF SORTTYPE;
     F7:FILE OF OUTPUTTYPE;
     F8:TEXT;
     SORTIN,SORTOUT,SINKFILE,TEMP1,TEMP2,TEMP:STRING[30];
     REC1,REC2:SORTTYPE;
     BLOCK:DATAARRAY;
     RECSLEFT:ARRAY[4..5] OF INTEGER;
     MAXL,NODOTS,NORECS,NOOUT,BLOCKSIZE,SBLOCKS,MBLOCKS,MPASS:INTEGER;
     SOURCE,PSOURCE,SSOURCE:INCHAN;
     SINK:OUTCHAN;
     QUIT,TEXTIN,TEXTOUT,EXISTP,EXISTS,OK,GOTONE,GOTOTHER:BOOLEAN;
     BUFFER:RECORD
               CASE TIO:FILETYPE OF
                  TXT: (LINE: STRING[255]);
                  INT: (RECI: INPUTTYPE);
                  OUT: (RECO:OUTPUTTYPE)
            END;
     COMMAND,CH:CHAR;

PROCEDURE MONITOR(CH: CHAR);
   BEGIN
      IF NODOTS=0 THEN WRITELN;
      IF CH<>'.' THEN WRITE(CHR(7));
      WRITE(CH);
      NODOTS:=NODOTS+1;
      IF NODOTS=80 THEN NODOTS:=0
   END;

PROCEDURE CONNECT(CHAN: INTEGER; FILENAME: STRING; VAR EXISTS: BOOLEAN);
   VAR MODE: STRING[4];
   BEGIN
      IF CHAN IN [0..5] THEN MODE:='find' ELSE MODE:='make';
      IF FILENAME='' THEN EXISTS:=FALSE ELSE BEGIN
         (*$I-*)
         CASE CHAN OF
         0: RESET(F0,FILENAME);
         1: RESET(F1,FILENAME);
         2: RESET(F2,FILENAME);
         3: RESET(F3,FILENAME);
         4: RESET(F4,FILENAME);
         5: RESET(F5,FILENAME);
         6: REWRITE(F6,FILENAME);
         7: REWRITE(F7,FILENAME);
         8: REWRITE(F8,FILENAME)
         END;
         EXISTS:=IORESULT=0;
         (*$I+*)
      END;
      IF EXISTS THEN
         IF (CHAN>5) THEN SINKFILE:=FILENAME ELSE
      ELSE WRITELN('Sorry, cannot ',MODE,' your file ',FILENAME)
   END;

PROCEDURE DISCONNECT(CHAN: OUTCHAN; VAR OK: BOOLEAN);
   BEGIN
      (*$I-*)
      CASE CHAN OF
      6: CLOSE(F6,LOCK);
      7: CLOSE(F7,LOCK);
      8: CLOSE(F8,LOCK);
      END;
      OK:=IORESULT=0;
      (*$I+*)
      IF NOT OK THEN WRITELN('Sorry, cannot close file ',SINKFILE);
   END;

FUNCTION ENDOF(SOURCE:INCHAN): BOOLEAN;
   BEGIN
      CASE SOURCE OF
         0: ENDOF:=EOF(F0);
         1: ENDOF:=EOF(F1);
         2: ENDOF:=EOF(F2);
         3: ENDOF:=EOF(F3);
         4: ENDOF:=(RECSLEFT[4]=0) OR EOF(F4);
         5: ENDOF:=(RECSLEFT[5]=0) OR EOF(F5);
      END
   END;

PROCEDURE TAKE;
   BEGIN
      IF ENDOF(SOURCE) THEN GOTONE:=FALSE ELSE
      CASE SOURCE OF
      0: BEGIN
            WHILE EOLN(F0) AND NOT EOF(F0) DO READLN(F0);
            IF EOF(F0) THEN GOTONE:=FALSE ELSE BEGIN
               READLN(F0,BUFFER.LINE);
               IF LENGTH(BUFFER.LINE)>MAXL THEN
                  BUFFER.LINE:=COPY(BUFFER.LINE,1,MAXL);
               USERIN(BUFFER.RECI,REC1)
            END
         END;
      1: BEGIN
            WHILE EOLN(F1) AND NOT EOF(F1) DO READLN(F1);
            IF EOF(F1) THEN GOTONE:=FALSE ELSE BEGIN
               READLN(F1,BUFFER.LINE);
               IF LENGTH(BUFFER.LINE)>MAXL THEN
                  BUFFER.LINE:=COPY(BUFFER.LINE,1,MAXL);
               USERIN(BUFFER.RECI,REC2)
            END
         END;
      2: BEGIN
            USERIN(F2^,REC1);
            GET(F2)
         END;
      3: BEGIN
            USERIN(F3^,REC2);
            GET(F3)
         END;
      4,5: 
      END
   END;

PROCEDURE GIVE;
   BEGIN
      CASE SINK OF
      6: BEGIN
            CASE SOURCE OF
            0,2: F6^:=REC1;
            1,3: F6^:=REC2;
            4: BEGIN
                  F6^:=F4^;
                  GET(F4);
               END;
            5: BEGIN
                  F6^:=F5^;
                  GET(F5);
               END
            END;
            PUT(F6)
         END;
      7: BEGIN
            CASE SOURCE OF
            0,2: USEROUT(REC1,F7^);
            1,3: USEROUT(REC2,F7^);
            4: BEGIN
                  USEROUT(F4^,F7^);
                  GET(F4);
               END;
            5: BEGIN
                  USEROUT(F5^,F7^);
                  GET(F5);
               END
            END;
            PUT(F7)
         END;
      8: BEGIN
            CASE SOURCE OF
            0,2: USEROUT(REC1,BUFFER.RECO);
            1,3: USEROUT(REC2,BUFFER.RECO);
            4: BEGIN
                  USEROUT(F4^,BUFFER.RECO);
                  GET(F4)
               END;
            5: BEGIN
                  USEROUT(F5^,BUFFER.RECO);
                  GET(F5)
               END
            END;
            WRITELN(F8,BUFFER.LINE)
         END
      END;
      MONITOR('.')
   END;

PROCEDURE SHSORT(VAR BLOCK:DATAARRAY;NORECS:INTEGER);
   VAR I,J,K,M:INTEGER;
       T:SORTTYPE;
   BEGIN
      M:=1;
      WHILE M<=NORECS DO M:=M+M;
      M:=M-1;
      WHILE M>1 DO
      BEGIN
         M:=M DIV 2;
         FOR I:= M+1 TO NORECS DO
         BEGIN
            K:=I;
            J:=K-M;
            T:=BLOCK[K];
            WHILE J>0 DO
               IF COMPARE(BLOCK[J],T) THEN J:=0
               ELSE BEGIN
                  BLOCK[K]:=BLOCK[J];
                  K:=J;
                  J:=K-M
               END;
            BLOCK[K]:=T
         END
      END
   END;
   
PROCEDURE SORTPHASE;
   BEGIN
      IF TEXTIN THEN SOURCE:=0 ELSE SOURCE:=2;
      CONNECT(SOURCE,SORTIN,OK);
      IF OK THEN BEGIN
         BLOCKSIZE:=RUNLENGTH;
         SBLOCKS:=0;
         GOTONE:=TRUE;
         WHILE OK AND NOT ENDOF(SOURCE) DO
         BEGIN
            SBLOCKS:=SBLOCKS+1;
            WRITE(CHR(7),'Sort',SBLOCKS,' starts');
            NORECS:=0;
            REPEAT
               TAKE;
               IF GOTONE THEN BEGIN
                  NORECS:=NORECS+1;
                  BLOCK[NORECS]:=REC1
               END;
            UNTIL (NORECS=BLOCKSIZE) OR (NOT GOTONE);
            WRITE(CHR(7));
            IF NORECS>0 THEN BEGIN
               SHSORT(BLOCK,NORECS);
               WRITE(CHR(7));
               IF SBLOCKS=1 THEN
                  IF ENDOF(SOURCE) THEN BEGIN
                     IF TEXTOUT THEN SINK:=8 ELSE SINK:=7;
                     CONNECT(SINK,SORTOUT,OK)
                  END ELSE BEGIN
                     SINK:=6;
                     CONNECT(SINK,TEMP1,OK);
                  END;
               NODOTS:=0;
               IF OK THEN FOR NOOUT:=1 TO NORECS DO
               BEGIN
                  REC1:=BLOCK[NOOUT];
                  GIVE
               END;
               WRITELN
            END
         END;
         IF TEXTIN THEN CLOSE(F0) ELSE CLOSE(F2);
         IF OK THEN DISCONNECT(SINK,OK)
      END
   END;
      
PROCEDURE MERGEBLOCKS;
   BEGIN
      SOURCE:=PSOURCE;
      GOTOTHER:=NOT ENDOF(SOURCE);
      SOURCE:=SSOURCE;
      NODOTS:=0;
      REPEAT
         GOTONE:=NOT ENDOF(SOURCE);
         IF GOTOTHER THEN BEGIN
            IF GOTONE THEN
               IF COMPARE(F4^,F5^) THEN SOURCE:=PSOURCE ELSE SOURCE:=SSOURCE
            ELSE SOURCE:=PSOURCE+SSOURCE-SOURCE;
            GOTOTHER:=GOTONE;
            GOTONE:=TRUE
         END;
         IF GOTONE THEN BEGIN
            GIVE;
            RECSLEFT[SOURCE]:=RECSLEFT[SOURCE]-1
         END
      UNTIL NOT GOTONE;
      WRITELN
   END;
   
PROCEDURE MERGEPHASE;
   BEGIN
      MPASS:=0;
      PSOURCE:=4;
      SSOURCE:=5;
      REPEAT
         MPASS:=MPASS+1;
         WRITE(CHR(7),'Merge',MPASS,' starts');
         TEMP:=TEMP1;
         RESET(F4,TEMP1);
         RESET(F5,TEMP1);
         IF SBLOCKS>2 THEN BEGIN
            SINK:=6;
            CONNECT(SINK,TEMP2,OK)
         END ELSE BEGIN
            IF TEXTOUT THEN SINK:=8 ELSE SINK:=7;
            CONNECT(SINK,SORTOUT,OK)
         END;
         IF OK THEN BEGIN
            MBLOCKS:=0;
            REPEAT
               NORECS:=0;
               WHILE (NOT EOF(F5)) AND (NORECS<BLOCKSIZE) DO BEGIN
                  GET(F5);
                  NORECS:=NORECS+1
               END;
               RECSLEFT[4]:=NORECS;
               IF NORECS<BLOCKSIZE THEN RECSLEFT[5]:=0
               ELSE RECSLEFT[5]:=BLOCKSIZE;
               MERGEBLOCKS;
               IF NOT EOF(F5) THEN BEGIN
                  NORECS:=0;
                  WHILE (NOT EOF(F4)) AND (NORECS<BLOCKSIZE) DO BEGIN
                     GET(F4);
                     NORECS:=NORECS+1
                  END
               END;
               SBLOCKS:=SBLOCKS-2;
               MBLOCKS:=MBLOCKS+1;
            UNTIL SBLOCKS<=0;
            TEMP1:=TEMP2;
            TEMP2:=TEMP;
            IF OK THEN DISCONNECT(SINK,OK);
            BLOCKSIZE:=BLOCKSIZE+BLOCKSIZE;
            SBLOCKS:=MBLOCKS
         END;
         CLOSE(F4);
         CLOSE(F5);
         RESET(F4,TEMP);
         CLOSE(F4,PURGE);
      UNTIL (SBLOCKS=1) OR NOT OK
   END;
      
PROCEDURE SORTFILE;
   BEGIN
      WRITELN('Sortfile entered');
      WRITELN;
      REPEAT
         WRITE('Sort which file?');
         READLN(SORTIN)
      UNTIL SORTIN<>'';
      REPEAT
         WRITE('Into which file?');
         READLN(SORTOUT)
      UNTIL SORTOUT<>'';
      WRITE('Which work disk?'); READLN(TEMP);
      WRITELN('Press SPACE or RETURN when ready, ESC to abort');
      REPEAT READ(KEYBOARD,CH) UNTIL CH IN [' ',CHR(27)];
      IF CH<>CHR(27) THEN BEGIN
         IF TEMP<>'' THEN BEGIN
            IF TEMP[1] IN ['0'..'9'] THEN TEMP:=CONCAT('#',TEMP);
            IF TEMP[LENGTH(TEMP)]<>':' THEN TEMP:=CONCAT(TEMP,':')
         END;
         TEMP1:=CONCAT(TEMP,'SORTTEMP1.DATA');
         TEMP2:=CONCAT(TEMP,'SORTTEMP2.DATA');
         TEMP:='';
         IF LENGTH(SORTIN)>5 THEN TEMP:=COPY(SORTIN,LENGTH(SORTIN)-4,5);
         TEXTIN:=(TEMP='.TEXT') OR (TEMP='.text');
         TEMP:='';
         IF LENGTH(SORTOUT)>5 THEN TEMP:=COPY(SORTOUT,LENGTH(SORTOUT)-4,5);
         TEXTOUT:=(TEMP='.TEXT') OR (TEMP='.text');
         IF TEXTIN THEN SOURCE:=0 ELSE SOURCE:=2;
         SORTPHASE;
         IF OK THEN IF SINK=6 THEN MERGEPHASE;
      END;
      WRITELN(CHR(7),'Sortfile ends')
   END;

PROCEDURE MERGE;
   BEGIN
      SOURCE:=PSOURCE;
      GOTONE:=TRUE;
      TAKE;
      GOTOTHER:=GOTONE;
      SOURCE:=SSOURCE;
      NODOTS:=0;
      REPEAT
         TAKE;
         IF GOTOTHER THEN BEGIN
            IF GOTONE THEN
               IF COMPARE(REC1,REC2) THEN SOURCE:=PSOURCE ELSE SOURCE:=SSOURCE
            ELSE SOURCE:=PSOURCE+SSOURCE-SOURCE;
            GOTOTHER:=GOTONE;
            GOTONE:=TRUE
         END;
         IF GOTONE THEN GIVE
      UNTIL NOT GOTONE;
      WRITELN
   END;
   
PROCEDURE MERGEFILES;
   VAR MERGIN1,MERGIN2,MERGOUT:STRING[30];
   BEGIN
      WRITELN('Mergefiles entered');
      WRITELN;
      REPEAT
         WRITE('Merge which file?');
         READLN(MERGIN1)
      UNTIL MERGIN1<>'';
      REPEAT
         WRITE('With which file?');
         READLN(MERGIN2)
      UNTIL MERGIN2<>'';
      REPEAT
         WRITE('Into which file?');
         READLN(MERGOUT)
      UNTIL MERGOUT<>'';
      TEMP:='';
      IF LENGTH(MERGIN1)>5 THEN TEMP:=COPY(MERGIN1,LENGTH(MERGIN1)-4,5);
      TEXTIN:=(TEMP='.TEXT') OR (TEMP='.text');
      TEMP:='';
      IF LENGTH(MERGIN2)>5 THEN TEMP:=COPY(MERGIN1,LENGTH(MERGIN2)-4,5);
      IF TEXTIN<>((TEMP='.TEXT') OR (TEMP='.text')) THEN
         WRITELN('Sorry, your input files must be of same TYPE')
      ELSE BEGIN
         TEMP:='';
         IF LENGTH(MERGOUT)>5 THEN TEMP:=COPY(MERGOUT,LENGTH(MERGOUT)-4,5);
         TEXTOUT:=(TEMP='.TEXT') OR (TEMP='.text');
         IF TEXTIN THEN BEGIN
            PSOURCE:=0;
            SSOURCE:=1;
         END ELSE BEGIN
            PSOURCE:=2;
            SSOURCE:=3;
         END;
         CONNECT(PSOURCE,MERGIN1,EXISTP);
         CONNECT(SSOURCE,MERGIN2,EXISTS);
         IF EXISTP AND EXISTS THEN BEGIN
            IF TEXTOUT THEN SINK:=8 ELSE SINK:=7;
            CONNECT(SINK,MERGOUT,OK);
            IF OK THEN BEGIN
               MERGE;
               DISCONNECT(SINK,OK)
            END;
            IF TEXTIN THEN BEGIN
               CLOSE(F0); CLOSE(F1)
            END ELSE BEGIN
               CLOSE(F2); CLOSE(F3)
            END
         END
      END;
      WRITELN(CHR(7),'Mergefiles ends')
   END;
   
PROCEDURE CHECKFILE;
   VAR CHECKIN:STRING[30];
       CH:CHAR;
   BEGIN
      WRITELN('Checkfile entered');
      WRITELN;
      REPEAT
         WRITE('Check which file?');
         READLN(CHECKIN)
      UNTIL CHECKIN<>'';
      TEMP:='';
      IF LENGTH(CHECKIN)>5 THEN TEMP:=COPY(CHECKIN,LENGTH(CHECKIN)-4,5);
      TEXTIN:=(TEMP='.TEXT') OR (TEMP='.text');
      IF TEXTIN THEN SOURCE:=1 ELSE SOURCE:=3;
      CONNECT(SOURCE,CHECKIN,EXISTS);
      IF EXISTS THEN BEGIN
         GOTOTHER:=FALSE;
         GOTONE:=TRUE;
         NORECS:=0;
         NOOUT:=0;
         NODOTS:=0;
         REPEAT
            TAKE;
            IF GOTONE THEN BEGIN
               CH:='.';
               IF GOTOTHER THEN
                  IF NOT COMPARE(REC1,REC2) THEN
                  BEGIN
                     NOOUT:=NOOUT+1;
                     CH:='*'
                  END;
               NORECS:=NORECS+1;
               MONITOR(CH);
               REC1:=REC2
            END;
            GOTOTHER:=GOTONE
         UNTIL NOT GOTONE;
         WRITELN;
         IF TEXTIN THEN CLOSE(F1) ELSE CLOSE(F3);
         WRITELN('File ',CHECKIN,' holds ',NORECS,' records: ',
            NOOUT,' are out of order');
      END;
      WRITELN(CHR(7),'Checkfile ends')
   END;
   
PROCEDURE ENTERFILER;
   BEGIN
       CHAIN('I="F"'); CHAIN('*SORTMERGE'); QUIT:=TRUE

       (* Remove the above three statements for Version II or if Filer entry
          not required under Version IV.   Substitute the following:

          WRITELN('Filer entry not implemented.'); WRITELN('Sorry!')       *)

   END;
   
BEGIN
   WRITELN; WRITELN;
   WRITELN('-----------------------------------------------------------------');
   WRITELN('ERCC UCSD p-System II-IV Sort/Merge Package Version 1.3 23-Aug-82');
   WRITELN('-----------------------------------------------------------------');
   WRITELN;
   QUIT:=FALSE;
   REPEAT
      MAXL:=SIZEOF(INPUTTYPE)-2;
      WRITELN;
      WRITE('I(nit S(ort M(erge C(heck T(erm F(iler Q(uit: ');
      READ(KEYBOARD,COMMAND);
      IF COMMAND IN ['I','S','M','C','T','F','Q','i','s','m','c','t','f','q']
      THEN CASE COMMAND OF
         'I','i': INITIALISE;
         'S','s': SORTFILE;
         'M','m': MERGEFILES;
         'C','c': CHECKFILE;
         'T','t': TERMINATE;
         'F','f': ENTERFILER;
         'Q','q': QUIT:=TRUE
         END
      ELSE BEGIN
         WRITE(COMMAND);
         READLN;
         WRITELN('Pardon me?')
      END
   UNTIL QUIT
END.


========================================================================================
DOCUMENT :usus Folder:VOLUK04:sort.read.text
========================================================================================

ERCC UCSD p-System II.0-IV.0 SORT/MERGE Package Release 1.3 - 23-Aug-82

     This disk contains the following TEXT files, comprising the source
code (Pascal) and documentation of the ERCC SORT/MERGE Package.

        SORT.DOC.TEXT    - Full user documentation of the Package, for use
                           under versions II.0, II.1 and IV.0 of the UCSD
                           p-System;

        SORT.MERGE.TEXT  - Pascal source of the main program supporting the
                           primary SORT, MERGE and CHECK procedures:
                           configured for use under version IV.0, but with
                           comments indicating modifications required for
                           use under versions II.0 and II.1;

        SORT.DUMUN.TEXT  - Pascal source of the minimal User-provided Unit
                           required in addition to the main program, to the
                           define file and record structures and key comparison
                           specifications of the SORT, MERGE and CHECK
                           procedures, and to define intialisation and
                           termination procedures: suitable for TEXT or
                           FILE OF STRING files, with comments indicating
                           modifications required for other file types;

        SORT.TXTUN.TEXT  - Pascal source of a more generalised User-provided
                           Unit defining file structures and specifications for
                           SORT, MERGE and CHECK operations for TEXT or FILE
                           OF STRING files, for use under version II.0, II.1
                           or IV.0;



========================================================================================
DOCUMENT :usus Folder:VOLUK04:sort.txtun.text
========================================================================================

(*$S++*)
(*$R-*)
(*$V-*)

(* ERCC UCSD p-System II.0-IV.0 SORT/MERGE Package Release 1.3 23-Aug-82 *)

(* Suggested file and key specs for sorting TEXT or FILE OF STRING files *)

UNIT SORTSPEC;

INTERFACE

   CONST RUNLENGTH=172; (* Set smaller if your records are large *)
         MAXNOKEYS=6;   (* Set to number of sorting keys to be defined *)
         MAXRECL=80;    (* Set to max length of line for TEXT files *)
   
   TYPE INPUTTYPE=STRING[MAXRECL];
        SORTTYPE=PACKED RECORD
                    MAINPART: INPUTTYPE;
                    KEYPART: PACKED ARRAY[1..MAXNOKEYS] OF PACKED RECORD
                       CASE KEYTYPE: CHAR OF
                       'I': (IKEY: INTEGER);
                       'R': (RKEY: REAL);
                       'S': ()
                    END
                 END;
        OUTPUTTYPE=INPUTTYPE;
        
   VAR TXTFILE: TEXT; (* Needed locally by PROCEDURE TERMINATE below *)
       DATFILE: FILE OF INPUTTYPE; (* Ditto *)
   
   PROCEDURE INITIALISE;
   PROCEDURE USERIN(INPUTREC: INPUTTYPE; VAR SORTREC: SORTTYPE);
   FUNCTION  COMPARE(SORTREC1, SORTREC2: SORTTYPE): BOOLEAN;
   PROCEDURE USEROUT(SORTREC: SORTTYPE; VAR OUTPUTREC: OUTPUTTYPE);
   PROCEDURE TERMINATE;
   
IMPLEMENTATION
   
   (* Declarations of key specification lists *)
   
   TYPE KEYLIST=1..MAXNOKEYS;
   
   VAR NOOFKEYS: 0..MAXNOKEYS;
       KEYNO: KEYLIST;
       KPOS,KLEN: ARRAY [KEYLIST] OF 1..256;
       KTYP: ARRAY[KEYLIST] OF CHAR;
       KORD: ARRAY[KEYLIST] OF BOOLEAN;
      
   (* ***** Additional PROCEDURES required by PROCEDURE USERIN ***** *)
   
   PROCEDURE STOI(LINE:STRING;FIRST,WIDTH:INTEGER;VAR RESULT:INTEGER;
      VAR ERROR:BOOLEAN);
      (* Decode numeric field of STRING into INTEGER value *)
      VAR NO,SIGN,COL,LAST,DIGIT: INTEGER;
          SYMBOL: CHAR;
      BEGIN
          NO:=0; SIGN:=0; ERROR:=FALSE;
          LAST:=FIRST+WIDTH-1;
          IF LAST>LENGTH(LINE) THEN ERROR:=TRUE ELSE BEGIN
             FOR COL:=FIRST TO LAST DO BEGIN
                SYMBOL:=LINE[COL];
                IF (SYMBOL='+') THEN
                   IF (SIGN=0) THEN SIGN:=1 ELSE ERROR:=TRUE
                ELSE IF (SYMBOL='-') THEN
                   IF (SIGN=0) THEN SIGN:=-1 ELSE ERROR:=TRUE
                ELSE IF SYMBOL IN [' ','0'..'9'] THEN BEGIN
                   IF SYMBOL=' ' THEN DIGIT:=0
                   ELSE BEGIN
                      IF SIGN=0 THEN SIGN:=1;
                      DIGIT:=ORD(SYMBOL)-ORD('0')
                   END;
                   IF (NO>3276) OR ((NO=3276) AND (DIGIT>7)) THEN
                      ERROR:=TRUE
                   ELSE NO:=10*NO+DIGIT
                END ELSE ERROR:=TRUE
             END
          END;
          IF ERROR THEN BEGIN
             WRITELN(CHR(7),'Illegal INTEGER in cols',FIRST,'-',LAST);
             RESULT:=0;
          END ELSE RESULT:=NO*SIGN
       END;
      
   PROCEDURE STOR(LINE:STRING;FIRST,WIDTH:INTEGER;VAR RESULT:REAL;
      VAR ERROR: BOOLEAN);
      (* Decode numeric field of STRING into REAL value *)
      VAR NO: REAL;
          IEXP,PLACES,SIGN,COL,LAST,DIGIT: INTEGER;
          POINT,EXPT: BOOLEAN;
          SYMBOL: CHAR;
      BEGIN
          NO:=0; SIGN:=0; PLACES:=0; POINT:=FALSE; EXPT:=FALSE; ERROR:=FALSE;
          LAST:=FIRST+WIDTH-1;
          IF LAST>LENGTH(LINE) THEN ERROR:=TRUE ELSE BEGIN
             FOR COL:=FIRST TO LAST DO BEGIN
                SYMBOL:=LINE[COL];
                IF SYMBOL='+' THEN
                   IF SIGN=0 THEN SIGN:=1 ELSE ERROR:=TRUE
                ELSE IF SYMBOL='-' THEN
                   IF SIGN=0 THEN SIGN:=-1 ELSE ERROR:=TRUE
                ELSE IF SYMBOL='.' THEN
                   IF POINT THEN ERROR:=TRUE ELSE POINT:=TRUE
                ELSE IF SYMBOL='E' THEN
                   IF EXPT THEN ERROR:=TRUE ELSE BEGIN
                      EXPT:=TRUE;
                      IF COL=LAST THEN ERROR:=TRUE ELSE BEGIN
                         COL:=COL+1;
                         STOI(LINE,COL,LAST+1-COL,IEXP,ERROR);
                         IF (IEXP<-38) OR (IEXP>37) THEN ERROR:=TRUE ELSE
                            PLACES:=TRUNC(IEXP)+PLACES;
                         COL:=LAST
                      END
                   END
                ELSE IF SYMBOL IN [' ','0'..'9'] THEN BEGIN
                   IF SYMBOL=' ' THEN DIGIT:=0
                   ELSE BEGIN
                      IF SIGN=0 THEN SIGN:=1;
                      DIGIT:=ORD(SYMBOL)-ORD('0')
                   END;
                   NO:=10*NO+DIGIT;
                   IF POINT THEN PLACES:=PLACES-1;
                END ELSE ERROR:=TRUE
             END
          END;
          IF ERROR THEN BEGIN
             WRITELN(CHR(7),'Illegal REAL in cols',FIRST,'-',LAST);
             RESULT:=0;
          END ELSE BEGIN
             WHILE PLACES<>0 DO
                IF PLACES>0 THEN BEGIN
                   NO:=NO*10;
                   PLACES:=PLACES-1
                END ELSE BEGIN
                   NO:=NO/10;
                   PLACES:=PLACES+1
                END;
             RESULT:=NO*SIGN
          END
       END;
      
   (* PROCEDURES and FUNCTION required SORT/MERGE Package Main Program *)
   
   PROCEDURE INITIALISE;
      VAR CH: CHAR;
          LINE: STRING;
          ERROR: BOOLEAN;
          NO: INTEGER;
      BEGIN
         WRITELN('Initialise entered');
         WRITELN;
         REPEAT
            WRITE('How many keys?');
            READLN(LINE);
            STOI(LINE,1,LENGTH(LINE),NO,ERROR)
         UNTIL (NOT ERROR) AND (0<=NO) AND (NO<=MAXNOKEYS);
         NOOFKEYS:=NO;
         FOR KEYNO:= 1 TO NOOFKEYS DO BEGIN
            REPEAT
               WRITE('Key',KEYNO,' Position (col no.)?');
               READLN(LINE);
               STOI(LINE,1,LENGTH(LINE),NO,ERROR)
            UNTIL (NOT ERROR) AND (1<=NO) AND (NO<=MAXRECL);
            KPOS[KEYNO]:=NO;
            REPEAT
               WRITE(' Length (cols or bytes)?');
               READLN(LINE);
               STOI(LINE,1,LENGTH(LINE),NO,ERROR)
            UNTIL (NOT ERROR) AND (1<=NO) AND (NO<=MAXRECL);
            KLEN[KEYNO]:=NO;
            WRITE(' Type I)nteger R)eal S)tring?');
            REPEAT READ(KEYBOARD,CH) UNTIL CH IN ['I','R','S','i','r','s'];
            CASE CH OF
            'i','I': CH:='I';
            'r','R': CH:='R';
            's','S': CH:='S'
            END;
            WRITE(CH);
            READLN;
            KTYP[KEYNO]:=CH;
            WRITE(' Order A)scending D)escending?');
            REPEAT READ(KEYBOARD,CH) UNTIL CH IN ['A','a','D','d'];
            WRITE(CH);
            READLN;
            KORD[KEYNO]:=(CH='a') OR (CH='A')
         END;
         WRITELN('Initialise ends')
      END;
   
   PROCEDURE USERIN;
      VAR ERROR: BOOLEAN;
      BEGIN
         ERROR:=FALSE;
         WITH SORTREC DO BEGIN
            MAINPART:=INPUTREC;
            FOR KEYNO:= 1 TO NOOFKEYS DO BEGIN
               CASE KTYP[KEYNO] OF
               'I': STOI(INPUTREC,KPOS[KEYNO],KLEN[KEYNO],KEYPART[KEYNO].IKEY,
                    ERROR);
               'R': STOR(INPUTREC,KPOS[KEYNO],KLEN[KEYNO],KEYPART[KEYNO].RKEY,
                    ERROR);
               'S':
               END;
               IF ERROR THEN BEGIN
                  WRITELN('USERIN Fails - Illegal Key in this record:');
                  WRITELN(INPUTREC)
               END
            END
         END
      END;

   FUNCTION COMPARE;
      VAR S1,S2: STRING;
          I1,I2: INTEGER;
          R1,R2: REAL;
      BEGIN
         COMPARE:=TRUE;
         FOR KEYNO:= 1 TO NOOFKEYS DO BEGIN
            CASE KTYP[KEYNO] OF
            'I': BEGIN
                    I1:=SORTREC1.KEYPART[KEYNO].IKEY;
                    I2:=SORTREC2.KEYPART[KEYNO].IKEY;
                    IF I1<>I2 THEN BEGIN
                       COMPARE:=(I1<I2)=KORD[KEYNO];
                       EXIT(COMPARE)
                    END
                 END;
            'R': BEGIN
                    R1:=SORTREC1.KEYPART[KEYNO].RKEY;
                    R2:=SORTREC2.KEYPART[KEYNO].RKEY;
                    IF R1<>R2 THEN BEGIN
                       COMPARE:=(R1<R2)=KORD[KEYNO];
                       EXIT(COMPARE)
                    END
                 END;
            'S': BEGIN
                    S1:=COPY(SORTREC1.MAINPART,KPOS[KEYNO],KLEN[KEYNO]);
                    S2:=COPY(SORTREC2.MAINPART,KPOS[KEYNO],KLEN[KEYNO]);
                    IF S1<>S2 THEN BEGIN
                       COMPARE:=(S1<S2)=KORD[KEYNO];
                       EXIT(COMPARE)
                    END
                 END
            END
         END
      END;
         
   PROCEDURE USEROUT;
      BEGIN
         OUTPUTREC:=SORTREC.MAINPART
      END;
      
   PROCEDURE TERMINATE;
       VAR FILENAME: STRING[30];
           FTYPE: STRING[5];
           LINE: INPUTTYPE;
           EXISTS: BOOLEAN;
      BEGIN
         WRITELN('Terminate entered'); WRITELN;
         WRITE('List which file?'); READLN(FILENAME);
         FTYPE:='';
         IF LENGTH(FILENAME)>5 THEN FTYPE:=COPY(FILENAME,LENGTH(FILENAME)-4,5);
         IF (FTYPE='.TEXT') OR (FTYPE='.text') THEN BEGIN
            (*$I-*)
            RESET(TXTFILE,FILENAME);
            EXISTS:=IORESULT=0;
            (*$I+*)
            IF EXISTS THEN BEGIN
               WHILE NOT EOF(TXTFILE) DO BEGIN
                  READLN(TXTFILE,LINE);
                  WRITELN(LINE)
               END;
               CLOSE(TXTFILE)
            END
         END ELSE BEGIN
             (*$I-*)
             RESET(DATFILE,FILENAME);
             EXISTS:=IORESULT=0;
             (*$I+*)
             IF EXISTS THEN BEGIN
                WHILE NOT EOF(DATFILE) DO BEGIN
                   LINE:=DATFILE^;
                   GET(DATFILE);
                   WRITELN(LINE)
                END;
                CLOSE(DATFILE)
             END
          END;
          IF NOT EXISTS THEN
             WRITELN('Sorry, cannot find your file ',FILENAME);
          WRITELN(CHR(7),'Terminate ends')
      END;
      
(* Remove the following two lines for use under UCSD Version II.0 *)

BEGIN
   NOOFKEYS:=0 (* Avoids catastrophy if user fails to call INITIALISE *)
END.



========================================================================================
DOCUMENT :usus Folder:VOLUK04:spbssdoc1.text
========================================================================================

                    ***  SPBSSTUFF  ***

          SPBSSTUFF is an Intrinsic Unit of procedures and functions
          designed to ease the problems of error checking in
          conversational style programs.  Including Screenops
          it adds 18 blocks of diskspace to the SYSTEM.LIBRARY.
          
          The INTERFACE section of the Unit declares PR and F to be
          of type 'TEXT' and SETOFCHAR to be of type 'SET OF CHAR'.
          PR is always used to denote PRINTER:.  Therefore any
          programs using SPBSSTUFF must use PR to denote PRINTER:
          unless another channel name is declared.  F is used in
          OpenOldfile & OpenNewfile.  F must be closed when these two
          procedures are called.  This implies that if the user
          whishes two or more text files to be open simultaneously
          OpenNewfile & OpenOldfile can be used only for that file
          denoted by F.
          
          As some of the SPBSSTUFF pocedures use CHAINSTUFF
          & SCREENOPS, these are also declared in the INTERFACE.
          
          The version of Screenops used is a subset of that availabe 
          in USUS UK Vol 2, containing only:  ScclrLine, ScclrScreen,
          ScErasetoEOL.
          
          The example below illustrates how SPBSSTUFF must be 
          incorporated in a program:-
          
          (*$S+,V-*)
          Program Dummy;
          uses chainstuff,screenops,spbsstuff;
          begin 
          .  
          .  
          .  
          end.
          
          
          The compiler option S+ is needed for compilation, and V- is 
          needed to avoid string lengths being checked as they are 
          being passed to and from the main program and SPBSSTUFF.
          
          The contents of SPBSSTUFF are:-
          Procedure PrintLine(x,y:integer;s:string);
          Function GetChar(okchars:setofchar):char;
          Function GetCHoice(options:setofchar):char;
          Procedure Goodbye;
          Procedure GetString(var s:string;maxlen:integer;okchars:setofchar);
          Procedure OpenNewFile (var nameoffile:string;s1,s2:string);          
          Procedure OpenOldFile (var nameoffile:string;s1,s2:string);             
          Procedure GetTextfileName(var s:string;s1,s2:string);
          Procedure IoError(ioresult:integer);
          Procedure WriteIoError(ioresult:integer);
          Procedure IntNum(var num:integer;var good:boolean;s:string);
          Procedure RealNum(var num:real;var good:boolean;s:string);
          Procedure GetRealNo(var num:real;termchars:setofchar);
          Procedure GetIntNo(var num:integer;var ok:boolean;maxlen : 
                           integer;termchars: setofchar);
          Function GetReal(x,y:integer;min,max:real):real;
          Function GetInt(x,y:integer;min,max:integer):integer;
          Procedure CheckPrinter;
          Procedure Continue (x,y:integer);
          Procedure Yes:boolean;
          Procedure Bell (times:integer);
          
          Updated May 1982 to make all procedures & functions
          screen orientated.
          
       Procedure GetString (VAR S:STRING;MAXLEN:INTEGER;OKCHARS:SETOFCHAR)
       ==================================================================


       Local vars      61 words
       ----------
       Code           216 bytes
       ----

       Other routines used     GetChar
       -------------------

       Special features        1.  The variable OKCHARS is of type 
       ----------------        SETOFCHAR which must be declared as a new 
                               type
                                   SETOFCHAR=SET OF CHAR;
                               either in the INTERFACE section of the UNIT or 
                               at the start of the program, whichever is 
                               appropriate.
       
       
       General Description
       -------------------
       
       
       GetString returns the string S entered from the keyboard.  S is
       allowed a maximum of MAXLEN characters.  These characters are read
       individually using GetChar.  Any character which does not belong to
       OKCHARS is not accepted and the bell is rung to warn the user.
       Backspacing is permitted to allow corrections.
       
       
       After MAXLEN characters have been entered, no further characters 
       except BACKSPACE and corresponding replacement characters are
       accepted.
       
       
       The user denotes the end of the string by pressing RETURN.
       
       
       If a null string is read i.e. the RETURN key is pressed first, S 
       retains its value prior to the procedure call.
       
           
       
       Applications
       ------------
       
       
       GetString can be used to read any string being entered from the 
       keyboard.
       
       Procedure IoError (IORESULT:INTEGER)
       ====================================
       
       
       
       
       Local vars     3 words
       ----------
       Code          66 bytes
       ----
       
       Other routines used PrintLine,WriteIoError,Goodbye,Continue
       -------------------
       
       Special features        None
       ----------------
       
       
       
       
       General Description
       -------------------
       
       
       IoError, starting at position (3,18) on the screen, lists a full I/O
       error message.  The fault description itself is obtained from
       WRITEIOERROR.
       
       If IORESULT is greater than 18 and not equal to 64 IoError will
       terminate the program, using GOODBYE
       
       If IORESULT does not exceed 18 or equal 64, the message
       
       'Press <return> to Continue'
       
       is listed on line 23.  When RETURN has been pressed, control is 
       returned to the calling procedure.
       
       
       
       Applications
       ------------
       
       
       IoError in conjunction with the compiler option I-, can be used to 
       describe I/0 errors during program execution without the program  
       necessarily being terminated by the system.
       
Procedure Continue(X,Y:INTEGER)
===============================


Local vars      4 words
----------

Code           68 bytes
----

Other routines used   GetChar
-------------------

Special features       NONE
----------------


General description
-------------------

Continue writes the message

'Press <return> to continue..'

at position x,y on the screen: When <return> is pressed, control is passed to
the next statement in the program.



Applications
------------

Continue enables the user to control the pace at which the program moves from
one section to the next, for example to ensure that error messages do not
disappear too quickly from the screen.
       Function GetCHoice(OPTIONS:SETOFCHAR):CHAR
       ==========================================
       
       
       
       Local vars          22 words
       ----------
       Code               168 bytes
       ----
       Other routines used        GetChar
       -------------------
       Special features           1. The variable OPTIONS is of type 
       ----------------           SETOFCHAR which must be declared as a 
                                  new type
                                          SETOFCHAR=SET OF CHAR;
                                  either in the INTERFACE section of the UNIT 
                                  or at the start of the program, whichever
                                  is appropriate.
                                  
                                  2.  Program text files must hold the
                                  OPTIONS in upper case.  Lower case
                                  responses by the user will automatically be
                                  converted to upper case before being
                                  checked for inclusion in OPTIONS.
                               


       General Description
       -------------------

       
       
       GetCHoice returns a single character selected by the user via the 
       keyboard from a set of single character OPTIONS.  These options will 
       usually be listed on the screen in menu form.
       
       The choice is made by typing the appropriate key followed by RETURN.  
       
       The user can backspace over his choice before pressing RETURN.
       
       Lower and upper case alphabetic characters are treated as equivalent. 
       
       If a character is entered which does not belong to OPTIONS the bell is 
       rung and that character is not accepted.
       


       Applications
       ------------


       GetCHoice can be used whenever the user is asked to select from several
       options.

       Procedure GetRealNo(VAR NUM:REAL;TERMCHARS:SETOFCHAR)
       =====================================================
       
       
       
       
       Local vars     100 words
       ----------
       Code           442 bytes
       ----
       
       Other routines used   GetChar,RealNum
       -------------------
       
       Special features       The variable TERMCHARS is of type SETOFCHAR which
       ----------------       must be declared as a new type
                              SETOFCHAR=SET OF CHAR; either in the INTERFACE
                              section of the UNIT or at the start of the
                              program, whichever is appropriate.
       
       
       General Description
       -------------------
       
       
       GetRealNo gets one real number from the keyboard.
       
       Exponential format is not allowed.
       
       Leading spaces are ignored.
       
       The real number is terminated by any one of the characters belonging 
       to TERMCHARS.
       
       Backspacing to correct errors is possible until a terminating 
       character has been entered.
       
       Illegal characters, e.g.'A', are not accepted, and the bell is rung as 
       a warning.
       
       Characters which would cause illegal format, e.g. a second '+', are 
       not accepted, and the bell is rung as a warning.
       
       A maximum of 21 characters may be entered, excluding leading spaces.
       
       
       
       Applications
       ------------
       
       
       GetRealNo can be used to read a single real number from the keyboard, 
       using any sensible characters as terminators.
       
       Procedure PrintLine(I,J:INTEGER;S:STRING)
       =========================================
       
       
       
       Local vars        46 words
       ----------
       Code              54 bytes
       ----
       
       other routines used       none
       -------------------
       
       Special features          none
       ----------------
       
       
       
       General Description
       -------------------


       PrintLine prints the string S on the screen starting at position 
       (I,J).  If I is greater than 79 the screen is cleared and S starts at 
       position (I-80,J).  
       
       The cursor remains at the end of the string after printing.
       
       
       
       Applications
       ------------
       
       
       PrintLine allows listing of text  at specific locations on the screen.
       
Function OpenOldFile(VAR NAMEOFFILE:STRING;S1,S2:STRING);
=========================================================



Local vars      87
----------
Code            80
----

Other routines used   GetTextfileName,IOERROR.
-------------------

Special features      The variable F of type TEXT is used to denote the
----------------      channel to the specified file. It is assumed that
                      F has been declared earlier in the INTERFACE section
                      of a unit, or as a global variable in the program.



General features
----------------

OpenOldFile, uses GetTextfilename to get a legal filename from the
keyboard. It then checks to see if the file does exist, and if so 
opens the file with a reset command and leaves the file open.  If it
does not exist or there is another IOERROR then the appropriate IOERROR
message is displayed, and the user will be prompted for another filename
until an existing file is opened successfully.


Applications
------------

Can be used wherever a program has to access an existing file.

          
          
          
       Function GetChar(OKCHAR:SETOFCHAR):CHAR
       =======================================
       
       
       
       Local vars       21 words
       ----------
       Code             88 bytes
       ----
       
       Other routines used      NONE
       -------------------
       
       Special features         1. The variable OKCHARS is of type SETOFCHAR 
       ----------------         which must be declared as a new type
                                   SETOFCHAR=SET OF CHAR;
                                either in the INTERFACE section of the UNIT 
                                or at the start of the program, whichever
                                is appropriate.
                                
       
       
       
       General Description
       -------------------


       Immediately it is called GetChar clears the keyboard buffer, then 
       waits for a single character to be typed in from the keyboard.  If
       this character belongs to OKCHARS it is returned as CHAR, and is
       echoed to the screen if it is a 'visible' character.
       Return is not echoed.
       
       
       If the character which is read does not belong to OKCHARS  the bell 
       will ring and the character will not be echoed.  GetChar then waits
       until another character is entered, and the entire process is
       repeated.
       
       
       
       Applications
       ------------
       
       
       GetChar is used in every SPBSSTUFF routine which reads from the 
       keyboard.
       
       
       Procedure GetTextfileName (VAR NAMEOFFILE  STRING; S1,S2:STRING)
       ===================================================
       
       
       
       Local vars      205 words
       ----------
       Code            692 bytes
       ----            
       
       Other routines used Continue,PrintLine, GetString,GetChar
       -------------------
       
       Special features        None
       ----------------
       
       
       
       General Description
       -------------------
       
       
       GetTextfileName gets a text file name from the keyboard.  If the user
       omits 'TEXT', the procedure will automatically append it.  The
       diskname must also be included as part of the file name.  Device
       names, such as #4, are not permitted.
       
       The procedure begins by sending the text
       
       'Insert other disk now if relevant'
       
       to the top line of a cleared screen.  Starting at positions (2,3) and
       (2,5) it then lists the strings S1 and S2.  These strings can be used
       to prompt the user and describe the type of file name needed e.g.
       S1:='ENTER THE DESIGN FILE NAME'.
       
       
       S1 and S2 can be null.  They should not be more than 37 characters as 
       any more characters will appear on the second half of the screen.  No 
       check is made on the lengths of S1 and S2.  They are the default 
       string length.
       
       Illegal file name characters are rejected as they are being typed in 
       (see Apple Pascal Operating System Manual, p30)
       
       
       Illegal names are rejected. The appropriate error message is listed on 
       lines 13 and 15 of the screen.
       
       'Press <return> to Continue'
       
       is listed on line 22.  After RETURN has been pressed GetTextfilenName
       is executed again.
       
       Illegal names are those with two or more colons, disk names with 0 or 
       more than 7 characters, and filenames with 0 or more than 10 
       characters.
       
       
       Applications
       ------------
       
       
       GetTextfileName can be used whenever a file name has to be entered from
       the keyboard.
       
       Procedure RealNum (VAR NUM:REAL;VAR GOOD:BOOLEAN;S:STRING)
       ==========================================================
       
       
       
       Local vars      159 words
       ----------
       Code
       ----            400 bytes
       
       Other routines used     None
       -------------------
       
       Special features        None
       ----------------
       
       
       
       General Description
       -------------------
       
       
       RealNum converts the string S to a real number NUM if this is
       possible.  GOOD is set to 'true if the conversion is successful.
       Otherwise GOOD is set to 'false'.
       
       The conversion will not be successful if S is in exponential format.
       
       
       Leading and trailing spaces (ASCII dec 32) in S are ignored.  the 
       number in S is terminated by the first space following a digit.
       
       
       Conversion to a real number will be unsuccessful if any of the 
       following occur:
       
             1)  S contains characters other than '+','-','.',' ','0'..'9'
       
             2)  '+' or '-' appear in any position except the first 
                 (ignoring leading spaces)
       
             3)  More than one decimal point
       
             4)  Any characters other than 'space' follow the terminating 
                 space
       
       
       
       Applications
       ------------
       
       
       RealNum can be used together with the compiler option I- to read real 
       data without the risk of a program crash should the data contain any 
       errors.  Such data might be read from disk, from the terminal keyboard,
       or from an external device such as an electronic balance. 
       

========================================================================================
DOCUMENT :usus Folder:VOLUK04:spbssdoc2.text
========================================================================================

       Procedure IntNum(VAR NUM:INTEGER;VAR GOOD:BOOLEAN;S:STRING)
       ============================================================
       
       
       
       Local vars      75 words
       ----------
       Code           402 bytes
       ----
       
       
       Other routines used    None
       -------------------
       
       Special features       None
       ----------------
       
       
       
       General Description
       -------------------
       
       
       IntNum converts the string S to the integer NUM if this is possible.
       GOOD is set to 'true' if the conversion is successful.  Otherwise GOOD 
       is set to 'false' and NUM is returned as -32767.
       
       
       Leading and trailing spaces (ASCII dec 32) in S are ignored.  the 
       number in S is assumed to be terminated by the first space following a 
       digit.
       
       Conversion to integer form will be unsuccessful if any of the
       following occur:
       
           1)  S contains characters other than '+','-',' ','0'..'9'
       
           2)  '+'or '-' appear in any position except the first  (ignoring 
               leading spaces)
       
           3)  Any characters other than 'space' follow the terminating space
       
           4)  The value of the converted integer lies outside the range
               (-32767 .. +32767) inclusive.
       
                                                    
       
       Applications
       ------------
       
       
       IntNum can be used together with the compiler option I- to read 
       integer data without the risk of a program crash should the data 
       contain any errors.  Such data might be read from disk, from the 
       terminal keyboard, or from an external device.
       
       
       It is also used in GetInt and GetIntNo where the integer is, in fact, 
       read from the keyboard as a string, then converted to an integer, 
       using IntNum.
       
Function Yes:BOOLEAN;
=====================



Local vars
----------
Code           38 bytes
----

Other routines   GetCHoice
--------------

Special features NONE
----------------



General description
-------------------

Yes returns true if 'y' or 'Y' is entered at the keyboard and false
if 'n' of 'N' is entered.  Will not accept any other characters.



Applications
------------

Can be used whenever a true/false answer is required.

Procedure OpenNewFile(VAR NAMEOFFILE:STRING;S1,S2:STRING);
==========================================================


Local vars     87 words
----------

Code          294 bytes
----

Other routines used    GetTextfileName,Goodbye,PrintLine,
-------------------    Bell,Yes,IoError

Special features       The variable F, of type TEXT is used to 
                       denote the channel to the specified file.
                       It is assummed that F has been declared
                       earlier in the INTERFACE section of a 
                       UNIT.
                       
                       
                       
General description
-------------------

OpenNewFile uses GetTextfileName to get a legal filename from the
keyboard.  It then checks to see if this file already exists, and if 
it does, the message


               'This file already exists!'
               'Do you wish to overwrite it (y/n)?'

appears on lines 11 & 14 respectively.
If the reply is 'N' then the screen is cleared and the user prompted for
another filename.  If the reply is 'Y' then the file is opened with a 
'rewrite' command, and left open (the contents of the original version 
will be lost)

     If the file does not already exist a new file is opened with the 
'rewrite' command and left open.
    
     If there is a fault during the opening of the file, then
appropriate IOERROR message is displayed and the user prompted for 
another filename, until a new file is successfully opened.

     As OpenNewfile uses the text variable f,f must be closed when
OpenNewfile is called.  If this is not the case the message

                'Not closed; attempt to open an open file'
                'Program needs altering to rectify'
                'this problem'
            
will appear and the program will be terminated using Goodbye.




Applications
------------

Can be used in virtually every program when a new file has
to be created.


       Procedure WriteIoError (IORESULT : INTEGER)
       ===========================================
       
       
       
       Local vars     0 words
       ----------   
       Code         972 bytes
       ----
       
       Other routines used     None
       -------------------
       
       Special features        None
       ----------------
       
       
       
       General Description
       -------------------
       
       
       WriteIoError lists the I/O fault description to the current
       cursor position on the screen.  These fault descriptions are given in
       the appropriate UCSD Manuals.
       
       If IORESULT is not in the range 1..18, or 64, the message
       'Report this fault' is listed.
       
       
       
       Applications
       ------------
       
       
       WriteIoError is used in IOERROR to list the formal I/0 error 
       description, and can be incorporated in any procedures which
       fulfill a similar role.
       
       
       Procedure GetIntNo
       
       (VAR NUM:INTEGER;VAR OK:BOOLEAN;MAXLEN:INTEGER TERMCHARS:SETOFCHAR)
       ====================================================================
       
       
       
       
       Local vars       110 words
       ----------
       Code             374 bytes
       ----
       
       Other routines used    GetChar,IntNum
       -------------------
       
       Special features       1. The variable TERMCHARS is of type SETOFCHAR 
       ----------------          which must be declared as a new type
                                         SETCHAR=SET OF CHAR;
                                 either in the INTERFACE section of the UNIT 
                                 or at the start of the program, whichever is 
                                 appropriate.
            
       
       
       General Description
       -------------------
       
       
       GetIntNo returns one integer from the keyboard.  Leading spaces are
       ignored.
       
       The integer is terminated by any one of the charcters in TERMCHARS.    
       
       If the integer entered from the keyboard is a short integer, that is
       in the range (-32767 ..  +32767), OK is set to 'true'.  Otherwise OK
       is set to 'false', and NUM is set to -32767.

       Backspacing to correct errors is permissible until a terminating 
       character has been entered.
       
       The maximum number of digits which a user is allowed to enter from the 
       keyboard, ignoring leading spaces, is MAXLEN.  After MAXLEN characters
       have been entered, the only acceptable characters are TERMCHARS and
       BACKSPACE.
       
       Illegal characters, that is all characters except '+','-',' ',
       '0'..'9',are not accepted, and the bell is rung as a warning.
       Characters which would cause illegal format, e.g.  a second '+', are
       not accepted, and the bell is rung as a warning.
       
       
       Applications
       ------------
       
       
       GetIntNo can be used to read an integer from the keyboard, using any 
       (sensible) terminating characters. A check is made to ensure that 
       the integer entered is not a 'long integer'.
       
Procedure Bell (TIMES:INTEGER);
===============================



Local vars      4 words
----------
Code           74 bytes
----

Other routines used  NONE
-------------------

Special features     NONE
----------------


General Description
-------------------

Bell sends the ASCII code 13 the requested number of times.  This 
rings the bell in the Apple (or external terminal) each time the 
code is sent.


Applications
------------

Obvious.  In general the Computing & Statistics staff at
SCRIP use Bell(3) to give an error warning & Bell(1) to give
an audio prompt that some routine has just been started/
completed.
       Function GetReal (X,X:INTEGER;MIN,MAX:REAL):REAL
       ================================================
       
       
       
       
       Local vars     13 words
       ----------
       Code          258 bytes
       ----
       
       Other routines used GetRealNo,Screenops 
       -------------------
       
       Special features        None
       ----------------
       
       
       
       GENERAL DESCRIPTION
       -------------------
       
       
       GetReal obtains a real number from the keyboard.  The real number must 
       be terminated by a RETURN.  The number entered is echoed to the screen 
       starting at position x,y.
       
       
       If the value of this real number does not lie in the range MIN .. MAX, 
       the bell is rung and at line y+2, & y+3 respectively, the message
       
                 'Error!  min is 
                 'press <return> to try again..'
       
       is listed (similarly for MAX).  The user must then enter another real
       number.  When return is pressed the message & the number entered are
       cleared from the screen & the cursor is returned to position x,y
       waiting for another attempt.  As the function uses GetRealNo, any
       illegal characters or formats will not be accepted.
       
       
       
       APPLICATIONS
       ------------
       
       
       GetReal can be used to read a single real number from the keyboard,  
       Where that real number must lie within a given range.
                
       Procedure Goodbye
       =================
       
       
       Local vars    5 words
       ----------
       code        290 bytes
       ----
       
       Other routines used PrintLine,chainstuff
       -------------------
       
       Special features      1.  Goodbye uses F, of type text, declared
                                 in the interface section of the Unit, 
                                 and will work successfully only if F is 
                                 closed when Goodbye is called.  As 
                                 Goodbye is called by several other 
                                 procedures, particularly I/O checking 
                                 routines, care must be taken to ensure
                                 that F is never left open unnecessarily.
       
       
       
       General Description
       -------------------
       
       
       Goodbye is a elaborate version of the UCSD intrinsic EXIT.
       
       The Statement 'End of program' is listed, on the screen starting at
       position (0,22).
       
       Goodbye then checks to see if SYSTEM.PASCAL is on-line in the boot
       disk drive (#4).If this file is not on-line the bell is rung several
       times and the message 'Put system disc in #4 and press <return>' is
       sent to line 23 of the screen.
       
       If SYSTEM.PASCAL is present Goodbye then checks to see if the boot 
       disc is a 'Turnkey disc' by checking to see if SYSTEM.STARTUP is also 
       on the boot disc.  If the boot disc is a 'turnkey disc' Goodbye then
       looks to see if STARTUP.CODE (*) is present and if it is 
       
       PLEASE PRESS <RETURN> TO CONTINUE
       
       sent to line 23.  When RETURN is pressed,STARTUP.CODE is
       executed,putting the user back into the original program (thus the
       user is never in the Outer Command Level).
       
       If SYSTEM.PASCAL is present and SYSTEM.STARTUP or STARTUP.CODE is not
       then Goodbye leaves the user in the outer command level.
       
       (NOTE:Goodbye only works to its full usefulness if the 'original' 
       system disc is in drive 4. If another system disc is in drive 4 then 
       Goodbye will find SYSTEM.PASCAL (and maybe SYSTEM.STARTUP) and 
       therefore think that the correct disc is in drive 4,but the operating 
       system demands that the disc HAS  to be the disc that the system was 
       booted with, and it will take over from Goodbye and promt the user for 
       the original boot disc)
       
       
       
       
       
       
       
       
       
       
       
       
       
       
       Applications
       ------------
       
       
       Goodbye forces the program to end immediately, and, if the original
       boot disc is in drive 4, returns the user safely to the Outer Command
       Level of the UCSD System unless the boot disc is a 'turnkey disc' in
       which case he user will be left in the startup program (which means
       that the inexperienced user, assuming the programs lead the user,
       needs only to know how to turn the APPLE on and how to read!).
       
       
       (*) Note STARTUP.CODE is a feature used by the Statistics and 
       Computing staff at the Scottish Crop Research Institute 
       (Pentlandfield).  It is used to make development and updating of
       turnkey discs simpler.  Our SYSTEM.STARTUP programs are very short and
       just execute STARTUP.CODE programs, which will usually contain the
       initial MENU.  Also SYSTEM.STARTUP cannot be used as a paramter in 
       SETCHAIN.
       
       
       Function GetInt(X,Y,MIN,MAX:INTEGER):INTEGER
       ========================================
       
       
       
       
       Local vars     10 words
       ----------
       Code          226 bytes
       ----
       
       Other routines used GetIntNo,Screenops 
       -------------------
       
       Special features       
       ----------------
       
       
       
       GENERAL DESCRIPTION
       -------------------
       
       
       GetInt reads an integer from the keyboard.  This integer must be
       terminated by the RETURN key.  The integer is echoed to the screen
       starting at position (x,y).  If this integer lies outside the range
       MIN..MAX, where MIN and MAX must not be long integers, the bell is
       rung and at lines y+2,Y+3 respectively, the message
       
       'Range error min is MIN max is MAX
       Press <return> to try again..'
       
       is listed.  The user must then enter another number.  When RETURN is
       pressed the message and number entered are cleared from the screen and
       the cursor returns to position X,Y waiting for another attempt.  This
       function uses GetIntNo, which protects the user from entering illegal
       characters or formats.
       
       
       APPLICATIONS
       ------------
       
       If the integer entered is a long integer then the value of the integer 
       will be changed to -32767, so -32767 sould never be used as the MIN 
       value in the range.
       

       Procedure CheckPrinter
       ======================
       
       
       
       Local vars          5 words
       ----------
       Code              320 bytes
       ----
       
       Other routines used PrintLine, GetChar.
       
       Special features          1.  The variable PR, of type TEXT, is used to 
       ----------------          denote PRINTER: within Checkprinter. It is
                                 assumed that PR has been declared earlier in 
                                 THE INTERFACE section of a UNIT 
   
       
       
       General Description
       -------------------
       

       CheckPrinter  does three things.
       
       Firstly it sends the folling message to the screen.
       
       'Please check that the printer is
        switched on and is "online"
        Press the spacebar to align the
        printer.
        to start listing press <return>'
        
       Secondly it opens the output file PRINTER:.  Note that this is done 
       with I/O checking off so that if PRINTER: has already been 'opened' in 
       the main program, no error will occur.
       
       Thirdly it moves the paper in the printer forward one line every time 
       the spacebar is pressed.  Thus by holding down both the spacebar and 
       the repeat keys, the paper can be easily be moved to the top of a 
       page.
       
       Program control is returned to the main program once the RETURN key
       is pressed.
       
       
       
       Applications
       ------------
       
       
       CheckPrinter can be used to ensure the printer is online before any
       printing is done.


========================================================================================
DOCUMENT :usus Folder:VOLUK04:spbsstuff.code
========================================================================================

< binary file -- not listed >

========================================================================================
DOCUMENT :usus Folder:VOLUK04:spbsstuff.text
========================================================================================

(*$s+,v-,L printer:*)

(************************************************************************)
(*                                                                      *)
(* program :- spbsstuff (intrinsic unit Procedures and Functions        *)
(*                                                                      *)
(* update  :- May   1982                                                *)
(*                                                                      *)
(************************************************************************)
 
 
Unit SpbsStuff;intrinsic code 25 data 24;

 
interface

uses chainstuff,screenops;

type setofchar=set of char;
var f,pr:text;

Procedure Bell(times:integer);
Procedure Printline(x,y:integer;s:string);
Function GetChar(okchars:setofchar):char;
Function GetCHoice(options:setofchar):char;
Function Yes:boolean;
Procedure Continue(x,y:integer);
Procedure Goodbye;
Procedure GetString(var s:string;maxlen:integer;okchars:setofchar);
Procedure GetTextfileName(var nameoffile:string;s1,s2:string);
Procedure IoError(fault:integer);
Procedure WriteIoError(fault:integer);
Procedure OpenNewFile(var nameoffile:string;s1,s2:string);
Procedure OpenOldFile(var nameoffile:string;s1,s2:string);
Procedure IntNum(var num:integer;var good:boolean;s:string);
Procedure RealNum(var num:real;var good:boolean;s:string);
Procedure GetRealNo(var num:real;termchars:setofchar);
Procedure GetIntNo(var num:integer;var ok:boolean;maxlen : integer;
                 termchars: setofchar);
Function GetReal(x,y:integer;min,max:real):real;
Function GetInt(x,y,min,max:integer):integer;
Procedure CheckPrinter;

implementation
   
(**********************************************************************)

Procedure Bell;

(* rings the buzzer the required number of times *)

var loop2,loop:integer;

begin
for loop:=1 to times do 
begin
  for loop2:=1 to 40 do write('');
  write(chr(7))
end
end;  (* of Bell *)

(**********************************************************************)

Procedure Printline;

(*  prints s on the screen, starting at position x,y.  *)
(*  if x>79 clears screen, and starts at x-80,y        *)

begin
if x>79 then
begin
  ScClrScreen;
  x:=x-80
end;
gotoxy(x,y);
write(s)
end;    (* of Printline *)

(**********************************************************************)
(*  reads one char from the console.              *)
(*  accepts if in okchars and echoes if possible. *)
(*  if not in okchars rings bell and reads again. *)
(*  doesnot echo return                           *)

Function GetChar;

var ch:char;
    good:boolean;
    
begin
unitclear(1);  (*  clear type-ahead buffer *)
repeat
  read(keyboard,ch);
  if eoln(keyboard) then ch:=chr(13);
  good:=ch in okchars;
  if not good then Bell(3)
  else
  if ch in [' '..chr(125)] then write(ch)
until good;
GetChar:=ch
end;    (* of GetChar *)

(**********************************************************************)
(*  gets the choice from a set of single char options  *)
(*  The option set needs to be in UPPER case           *)

Function GetChoice;

var chdum,ch:char;
    good:boolean;
    
begin
unitclear(1);  (*  clear type-ahead buffer *)
repeat
  repeat
    read(keyboard,chdum);
    if chdum in ['a'..'z'] then ch:=chr(ord(chdum)-32)
    else ch:=chdum;
    good:=ch in options;
    if not good then Bell(3)
    else
    if ch in [' '..chr(125)] then write(chdum)
  until good;
  GetChoice:=ch;
  ch:=GetChar([chr(8),chr(13)]);
  if ch=chr(8) then write(chr(8),' ',chr(8))
until ch=chr(13)
end;    (* of GetChoice *)

(**********************************************************************)

Function yes;

(* reads a y/n reply only in either upper or lower case *)

begin
  yes:=GetChoice(['Y','N'])='Y'
end;

(**********************************************************************)

Procedure Continue;

(* prints continue message in required position *)

var ch:char;

begin
  gotoxy(x,y);
  write('Press <return> to continue..');
  ch:=GetChar([chr(13)])
end;

(**********************************************************************)
(*  print 'end of program' at position 0,22  and quit  *)
(* If Turnkey disc will restart at the beginning *)

Procedure Goodbye;

var     nioresult,i:integer;
        ch:char;
        ok:boolean;

begin
ScClrLine(22);
Printline(0,22,'End of program');
repeat
  (*$i-*)
  reset(f,'#4:system.pascal');
  (*$i+*)
  ok:=(ioresult=0);
  if ok then
  begin
    (*$i-*)
    close(f,normal);
    reset(f,'#4:system.startup');
    nioresult:=ioresult;
    if (nioresult=0) then 
    begin
      close(f,normal);
      reset(f,'#4:startup.code');
      nioresult:=ioresult;
      if (nioresult=0) then
      begin
        close(f,normal);
        (*$i+*)
        Continue(0,23);
        setchain('#4:startup');
        exit(program)
      end
    end
  end
  else
  begin
    (*$i+*)
    Bell(6);
    Printline(0,23,'Put system disk in #4 and press <return>');
    if GetChar([chr(13)])=chr(13) then ScClrLine(23)
  end
until ok;
exit(program)
end;    (* of Goodbye *)

(**********************************************************************)
(*  reads, char by char, string s of max length maxlen.   *)
(*  each char must belong to okchars.                     *)
(*  if a nul string is read, s retains its value prior    *)
(*  to the Procedure call.                                *)

Procedure GetString;

var s1:string[1];
    str:string[80];
    
begin
  s1:=' ';
  str:='';
  repeat
    if length(str)=0 then s1[1]:=GetChar(okchars+[chr(13)])
    else
    if length(str)=maxlen then s1[1]:=GetChar([chr(13),chr(8)])
    else
    s1[1]:=GetChar(okchars+[chr(13),chr(8)]);
    if s1[1] in okchars then str:=concat(str,s1)
    else
    if s1[1]=chr(8) then
    begin
      write(chr(8),' ',chr(8));
      delete(str,length(str),1)
    end
  until s1[1]=chr(13);
  if length(str)<>0 then s:=str
end;    (* of GetString *)

(**********************************************************************)
(*  gets text file name. allows only those chars defined by *)
(*  local variable okchars.  .text is added if necessary    *)
(*  checks for bad names (see below).                       *)

Procedure GetTextfileName;

var ok:boolean;
    name:string[23];
    lpdottext,updottext,pc,lfullname,lname:integer;
    okchars:setofchar;
    filename:string;

  
  Procedure txtflerror(error:integer);
  
  (*  prints text file name error, starting at line 12 *)
  
  var s:string;  ch:char;
  
  begin   (* of txtflerror *)
    case error of 
      1: s:='no disk name (no chars before '':'')';
      2: s:='disk name exceeds 7 chars';
      3: s:='no file name (no chars after '':'')';
      4: s:='no '':'' allowed in file name';
      5: s:='file name exceeds 10 chars'
    end;  (* of case *)
    Bell(3);
    Printline(2,12,'fault in text file name');
    Printline(2,15,s);
    Continue(2,22)
  end;    (* of txtflerror *)


begin   (* of GetTextfileName *)
okchars:=['%'..')','+','-'..'<','>','@'..'z','^',chr(97)..chr(122)];
repeat
  repeat
    repeat
      repeat
        repeat
          (*  check at least one char before colon *)
          ok:=true;
          Printline(82,0,'(Insert other disk now if relevant)');
          Printline(2,3,s1);
          Printline(2,5,s2);
          Printline(2,7,'');
          GetString(filename,23,okchars);
          gotoxy(2,8);
          pc:=pos(':',filename);
          if(pc=0)or (pc=1) then
          begin
            ok:=not(ok);
            txtflerror(1)
          end
        until ok;
        (*  check max 7 chars before colon  *)
        if pos(':',filename)>8 then 
        begin
          ok:=not(ok);
          txtflerror(2)
        end
      until ok;
      (*  check at least one char (excluding .text) after colon  *)
      lfullname:=length(filename);
      name:=copy(filename,pc+1,lfullname-pc);
      updottext:=pos('.TEXT',name);
      lpdottext:=pos('.text',name);
      if ((length(name)=0) or (updottext=1) or (lpdottext=1)) then
      begin
        ok:=not ok;
        txtflerror(3)
      end
    until ok;
    (*  check only one colon altogether  *)
    if pos(':',name) <> 0 then
    begin
      ok:=not ok;
      txtflerror(4)
    end
  until ok;
  (*  check max 10 chars (excluding .text) after colon *)
  if ((updottext>0) or (lpdottext>0))  then lname:=length(name)-5
  else
    lname:=length(name);
  if lname>10 then
  begin
    ok:=not ok;
    txtflerror(5)
  end
until ok;
if ((updottext=0) and (lpdottext=0))  then nameoffile:=concat(filename,'.text')
else
nameoffile:=filename
end;    (* GetTextfileName *)

(**********************************************************************)

Procedure writeIoError;

(* writes the appropriate ioerror to the screen *)

begin
if ((fault<=18)or(fault=64)) then
case fault of
  1: write('bad block, parity error');
  2: write('bad device (volume) number');
  3: write('illegal I/O request');
  4: write('data-com timeout');
  5: write('lost device; device is no longer online');
  6: write('lost file, no longer in directory');
  7: write('bad title; illegal file name');
  8: write('no room; insufficient space');
  9: write('no such volume online');
  10:write('no file; no such file on volume');
  11:write('duplicate directory entry');
  12:write('not closed; attempt to open an open file');
  13:write('not open; attempt to access a closed file');
  14:write('bad format; error in reading real or integer');
  15:write('ring buffer overflow');
  16:write('disk is write protected');
  17:write('illegal block number');
  18:write('illegal buffer');
  64:write('device error')
end
else
write('please report this fault')
end;    (* writeIoError *)

(**********************************************************************)
(*  prints IoError starting at position 3,17  *)

Procedure IoError;

begin
  Bell(3);
  Printline(2,18,'i/o error ');
  write(fault);
  gotoxy(2,20);
  writeIoError(fault);
  if ((fault>18) and (fault<>64)) then Goodbye;
  Continue(2,23)
end;    (* of IoError *)

(**********************************************************************)

Procedure OpenNewFile;

(* opens a new file, first checks to see if a file with this name already
  exists, if it does then asks if it is to be overwritten                 *)
  
var openok,goodname:boolean;
    fault:integer;

begin
repeat
  repeat
    goodname:=true;
    GetTextfileName(nameoffile,s1,s2);
    (*$i-*) reset(f,nameoffile); (*$i+*)
    fault:=ioresult;
    if fault=12 then
    begin
      ioerror(fault);
      PrintLine(2,11,'Program needs altering  to recitify');
      PrintLine(2,14,'this problem ');
      close(f,normal);
      goodbye
    end;
    if fault=0 then
    begin
      Bell(3);
      Printline(2,11,'this file already exists!');
      Printline(2,14,'do you wish to overwrite it (y/n) ?');
      goodname:=Yes;
      gotoxy(2,16)
    end;
    (*$i-*) close(f,normal) (*$i+*)
  until goodname;
  (*$i-*) rewrite(f,nameoffile); (*$i+*)
  fault:=ioresult;
  openok:=fault=0;
  if not openok then
  begin
    (*$i-*) close(f,normal); (*$i+*)
     IoError(fault)
  end
until openok
end;

(**********************************************************************)

Procedure OpenOldFile;

(* opens an existing file *)

var fault:integer;

begin
repeat
  GetTextfileName(nameoffile,s1,s2);
  (*$i-*) reset(f,nameoffile); (*$i+*)
  fault:=ioresult;
  (*$i-*) close(f,normal); (*$i+*)
  if fault<>0 then IoError(fault);
until fault=0;
(*$i-*) reset(f,nameoffile); (*$i+*)
end;

(**********************************************************************)
(* gonverts string 's' to short integer num *)
(* good set to true if conversion successful*)

Procedure IntNum;

var ok,neg:boolean;
    okchars:setofchar;
    l:integer[36];
    i,n:integer;
    
begin
good:=false;
n:=length(s);
l:=0;
i:=0;
neg:=false;
ok:=false;
okchars:=['0'..'9'];
num:=0;
if n=0 then
begin
  num:=-32767;
  exit(IntNum)
end;
i:=i+1;
if not (s[i] in okchars) then
begin
  repeat 
    if (s[i]='-') then
    begin
      neg:=true;
      ok:=true
    end
    else
    if (s[i]='+') then ok:=true
    else
    if ((s[i]<>' ') or (i=n)) then
    begin
      num:=-32767;
      exit(IntNum)
    end;
    i:=i+1
  until( ok or (s[i] in okchars))
end;
ok:=true;
repeat
  if (s[i] in okchars) then
  l:=l*10+ord(s[i])-48
  else ok:=false;
  i:=i+1
until ((i-1=n) or not ok);
if i>n then i:=n;
if not ok then
begin
  repeat
    if s[i]<>' ' then 
    begin
      num:=-32767;
      exit(IntNum)
    end;
    i:=i+1
  until (i>n)
end;
if l>32767 then
begin
  num:=-32767;
  exit(IntNum)
end;
good:=true;
str(l,s);
for i:=1 to length(s) do
num:=num*10+ord(s[i])-48;
if neg then num:=-num
end;    (* of IntNum *)

(**********************************************************************)
(* converts string  's'  to real num  *)
(* not valid if string in exp. format *)
(* good set to true if conversion successful *)

Procedure RealNum;

var ok,dec,neg:boolean;
    okchars:setofchar;
    l:integer[36];
    dnum,i,n:integer;
    s1,s2:string;
     
begin
good:=false;
n:=length(s);
dnum:=0;
dec:=false;
l:=0;
i:=0;
neg:=false;
ok:=false;
okchars:=['0'..'9','.'];
num:=0.0;
if n=0 then exit(RealNum);
i:=i+1;
if not (s[i] in okchars) then
begin
  repeat
    if (s[i]='-') then
    begin
      neg:=true;
      ok:=true
    end
    else
    if(s[i]='+') then ok:=true
    else
    if((s[i]<>' ')or(i=n)) then exit(RealNum);
    i:=i+1
  until (ok or (s[i] in okchars))
end;
ok:=true;
repeat
  if (s[i] in okchars) then
  begin
    if s[i]<>'.' then
    begin
      num:=num*10.0 + ord(s[i])-48.0;
      if dec then dnum:=dnum+1
    end
    else
    begin
      if not dec then dec:=true
      else
      exit(RealNum);
    end
  end
  else
  ok:=false;
  i:=i+1
until ((i-1=n) or not ok);
if i>n then i:=n;
if not ok then
repeat
  if s[i]<>' ' then exit(RealNum);
  i:=i+1
until (i>n);
if dnum>0 then
for i:=1 to dnum do
num:=num/10;
if neg then num:=-num;
good:=true
end;    (* of RealNum *)

(**********************************************************************)
(* gets one real no from console *)
(* exp. format not allowed *)
(* leading spaces ignored *)
(* terminating character(s) defined by user in termchars *)

Procedure GetRealNo;

var s :string[36];
    ok:boolean;
    okchars:setofchar;
    maxlen,i,n,k:integer;
    s1:string[1];
    str:string[80];

begin
s1:=' ';
maxlen:=21;
okchars:=['0'..'9','.'];
str:='';
repeat
  if length(str)=0 then 
  begin
    s1[1]:=GetChar(okchars+['+','-',' ']);
    if s1[1]=' ' then str:=''
  end
  else
  if ((str[1] in ['+','-'])and(maxlen=(length(str)))) then 
  s1[1]:=GetChar(termchars+[chr(8)])
  else
  if ((not(str[1] in ['+','-']))and(maxlen=(length(str)-1))) then 
  s1[1]:=GetChar(termchars+[chr(8)])
  else
  if str[length(str)] in ['0'..'9'] then
  s1[1]:=GetChar(okchars+termchars+[chr(8)])
  else
  s1[1]:=GetChar(okchars+[chr(8)]);
  if s1[1] in ['0'..'9','+','-','.'] then 
  str:=concat(str,s1)
  else
  if s1[1]=chr(8) then
  begin
    write(chr(8),' ',chr(8));
    delete(str,length(str),1)
  end;
  if pos('.',str)>0 then 
  okchars:=['0'..'9']
  else 
  okchars:=['0'..'9','.'];
until (str<>'')and(s1[1] in termchars);
RealNum(num,ok,str)
end;    (* of GetRealNo *)

(**********************************************************************)
(* gets one integer from console *)
(* leading spaces ignored *)
(* terminating character(s) defined by user in termchars *)

Procedure GetIntNo;

var s :string[36];
    l :integer[36];
    okchars:setofchar;
    i,n,k:integer;
    s1:string[1];
    str:string[80];

begin
s1:=' ';
okchars:=['0'..'9'];
str:='';
repeat
  if length(str)=0 then 
  begin
    s1[1]:=GetChar(okchars+['+','-',' ']);
    if s1[1]=' ' then str:=''
  end
  else
  if str[length(str)] in okchars then
  begin
    if ((str[1] in okchars)and(maxlen=(length(str)))) then 
    s1[1]:=GetChar(termchars+[chr(8)])
    else
    if ((not(str[1] in okchars))and(maxlen=(length(str)-1))) then 
    s1[1]:=GetChar(termchars+[chr(8)])
    else
    s1[1]:=GetChar(okchars+termchars+[chr(8)])
  end
  else
  s1[1]:=GetChar(okchars+[chr(8)]);
  if s1[1] in ['0'..'9','+','-'] then 
  str:=concat(str,s1)
  else
  if s1[1]=chr(8) then
  begin
    write(chr(8),' ',chr(8));
    delete(str,length(str),1)
  end
until (str<>'')and(s1[1] in termchars);
IntNum(num,ok,str)
end;    (* of GetIntNo *)

(**********************************************************************)
(* gets one real no from console *)
(* leading spaces ignoed *)
(* 'ret' is only valid terminator *)

Function  GetReal;

var ok:boolean;
    num:real;
    ch:char;

begin
repeat
  ok:=true;
  gotoxy(x,y);
  GetRealNo(num,[chr(13)]);
  if (num<min)or(num>max) then ok:=false;
  if not ok then
  begin
    Bell(3);
    gotoxy(2,y+2);
    write('error! ');
    if (num<min) then write('min is ',min:12:6)
    else write('max is ',max:12:6);
    gotoxy(2,y+3);
    write('press <return> to try again..');
    ch:=GetChar([chr(13)]);
    SCClrLine(y+3); SCClrLine(y+2); SCErasetoEOL(x,y)
  end
until ok;
GetReal:=num
end;    (* of GetReal *)

(**********************************************************************)
(* get one integer from console *)
(* 'ret' is only valid terminator *)
(* checks that integer lies in range min..max *)

Function  GetInt;

var ok:boolean;
    n:integer;
    ch:char;

begin
repeat
gotoxy(x,y);
GetIntNo(n,ok,5,[chr(13)]);
if ok then if ((n<min) or (n>max)) then ok:=false;
if not ok then
begin
  Bell(3);
  gotoxy(2,y+2);
  write('Range error min is ',min,' max is ',max);
  gotoxy(2,y+3);
  write('Press <return> to try again..');
  ch:=GetChar([chr(13)]);
  SCClrLine(y+3); SCClrLine(y+2); SCErasetoEOL(x,y)
end
until ok;
GetInt:=n
end;    (* of GetInt *)

(**********************************************************************)
(* check the printer*)

Procedure CheckPrinter; 
var ok:boolean;
    string1:string[1];

begin   (* sends the message to the screen. *)
string1:=' ';
Printline(82,5,'Please check that the printer is');
Printline(2,7,'switched on and is "online"');
Printline(2,10,'Press the spacebar to align the');
Printline(2,12,'printer.');
Printline(2,17,'To start listing press <return>..');
(*$i-*)
rewrite(pr,'printer:');    (* opens the output file printer with i/o 
                           checking off                           *)
(*$i+*)
repeat
  string1[1]:=GetChar([chr(13),chr(32)]);
  if (string1[1]=chr(32)) then
  begin
     write(chr(8));
     writeln(pr)
  end;
until (string1[1]=chr(13))
end;    (* of CheckPrinter *)

begin (* dummy main *)

end.


========================================================================================
DOCUMENT :usus Folder:VOLUK04:voluk4.doc.text
========================================================================================

                            USUS Library Volume UK4
                       An APL Interpreter and other stuff
                             Submitted by USUS(UK)

UKVOL4:
APL.TEXT          32  The APL Interpreter
APLPARSE1.TEXT    18    an include file
APLPARSE2.TEXT    66     ditto
APLPROCS.TEXT     34     ditto
APLPARSE3.TEXT     6     ditto
APLHEAP.TEXT      12     ditto
APLINIT.TEXT      16     ditto
APLCHERS.TEXT      6     ditto
APLPARSE0.TEXT    16     ditto
SORT.DOC.TEXT     42  Documentation of the Sort/Merge Utility
SORT.MERGE.TEXT   26  The main Sort/Merge program
SORT.READ.TEXT     6  Some more notes on the Sort/Merge files
SORT.DUMUN.TEXT    8  A example of the required user-supplied for Sort/Merge
SORT.TXTUN.TEXT   18  A more general example of SORT.DUMUN.TEXT
SPBSSTUFF.TEXT    40  A unit full of useful goodies
SPBSSDOC1.TEXT    32    Documentation for SPBSSTUFF
SPBSSDOC2.TEXT    32    Documentation for SPBSSTUFF
SPBSSTUFF.CODE    16  A code file for IV.0 of SBBSSTUFF
CONTENTS.TEXT     10  The UK's file of the contents of this disk, there's
                        more detail in this one about this disk.
VOLUK4.DOC.TEXT    6  You're reading it.
__________________________________________________________________________

Please transfer the text below to a disk label if you copy this volume.

    USUS Volume UK4 -***- USUS Software Library
                         
   For not-for-profit use by USUS members only.
  May be used and distributed only according to 
      stated policy and the author's wishes.



This volume was assembled by USUS(UK) from material collected by
their Library committee.
__________________________________________________________________________



DTCCatTextDocsRecursive

Recursive Text File Concatenator 1.0 [18 September 2000]
Written by David T. Craig

Processing document "Jefferson Computer Museum - UCS" [TEXT/ttxt] ...
Processing FOLDER   "usus Folder" ...
Processing document ":usus Folder:readme.doc.txt" [TEXT/MSWD] ...
Processing FOLDER   ":usus Folder:VOL01" ...
Processing document ":usus Folder:VOL01:catalog1.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL01:combine.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL01:cpm.doc.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL01:cpmcopy.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL01:crc16.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL01:crt.i.o.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL01:diskread.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL01:format.doc.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL01:format.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL01:format1.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL01:format2.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL01:getcpm.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL01:getcpm2.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL01:gotcha.doc.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL01:initvar.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL01:inoutready.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL01:introductn.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL01:l.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL01:modem.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL01:modem1.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL01:pretty.doc.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL01:pretty.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL01:readcpm.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL01:rwcpm.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL01:simp.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL01:typeset.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL01:units.doc.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL01:volume1.text" [TEXT/ttxt] ...
Processing FOLDER   ":usus Folder:VOL03" ...
Processing document ":usus Folder:VOL03:blackjack.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL03:catalog.3.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL03:chase.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL03:debts.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL03:othell1.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL03:othell2.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL03:othellinit.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL03:othello.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL03:policy.doc.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL03:requests.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL03:snoopy.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL03:store.data" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL03:universal.text" [TEXT/ttxt] ...
Processing FOLDER   ":usus Folder:VOL04" ...
Processing document ":usus Folder:VOL04:catalog.4.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL04:compare.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL04:compress.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL04:dbbuilder.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL04:dbunit.1.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL04:dbunit.2.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL04:dbunit.3.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL04:dbunit.4.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL04:dbunit.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL04:index.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL04:kb.dbdemo.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL04:kb.scunit.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL04:kb.starter.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL04:kb.testdb" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL04:teach.wumpus" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL04:usus.news.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL04:volume.4.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL04:wump.cave0.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL04:wump.cave1.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL04:wump.cave2.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL04:wump.cave3.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL04:wump.cave4.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL04:wump.cave5.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL04:wumpus.text" [TEXT/ttxt] ...
Processing FOLDER   ":usus Folder:VOL05" ...
Processing document ":usus Folder:VOL05:addrs.doc.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL05:catalog.5.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL05:crtinput.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL05:dir.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL05:diskread.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL05:fmt.1.5.code" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL05:fmt.2.0.code" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL05:fmt.examp.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL05:getnumber.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL05:getsort.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL05:hexdecoct.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL05:id2id.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL05:makemasks.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL05:monaco.doc.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL05:peek.poke.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL05:quicksort.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL05:read.diskr.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL05:read.fmt.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL05:screencntl.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL05:sp.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL05:struct.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL05:unit.good.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL05:update.text" [TEXT/ttxt] ...
Processing FOLDER   ":usus Folder:VOL06" ...
Processing document ":usus Folder:VOL06:banner.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL06:baud.a.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL06:catalog.6.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL06:cts.a.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL06:dialer.a.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL06:dtonedet.a.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL06:dtron.a.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL06:fmt.64mask.data" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL06:fmt.64menu.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL06:fmt.mask.data" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL06:fmt.menu.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL06:fmt.newdoc.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL06:format.1.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL06:format.2.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL06:format.3.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL06:format.4.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL06:format.5.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL06:format.6.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL06:format.doc.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL06:format.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL06:hangup.a.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL06:kbstat.a.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL06:modemini.a.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL06:mread.a.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL06:mrecstat.a.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL06:mwrite.a.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL06:ptp-files.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL06:ptp-inst.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL06:ptp-use.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL06:ptp.bush.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL06:ri.a.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL06:ringing.a.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL06:sh.a.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL06:sysname.text" [TEXT/ttxt] ...
Processing FOLDER   ":usus Folder:VOL07" ...
Processing document ":usus Folder:VOL07:catalog.7.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL07:fastread.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL07:keyhit.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL07:map-a.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL07:map-b.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL07:map.doc.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL07:map.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL07:proc.ref1.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL07:proc.ref2.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL07:prx.doc.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL07:prxref.ini.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL07:prxref.opt.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL07:prxref.pfi.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL07:prxref.tbl.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL07:prxref.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL07:prxref.utl.text" [TEXT/ttxt] ...
Processing FOLDER   ":usus Folder:VOL08" ...
Processing document ":usus Folder:VOL08:archiver.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL08:catalog.8.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL08:chain.1.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL08:chain.2.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL08:chain.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL08:copyblocks.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL08:crmblev1.2.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL08:d.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL08:disksort.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL08:error.data.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL08:exhalev2.1.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL08:fast.seek.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL08:fileunit.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL08:global.ii0.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL08:global.iii.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL08:linecount.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL08:lisp.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL08:lister.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL08:mailer.doc.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL08:mailer.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL08:modemv2.2.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL08:muldiv.z80.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL08:perusev4.6.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL08:recover.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL08:rem.term.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL08:rem.unit.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL08:screen.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL08:screenunit.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL08:units.doc.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL08:volume.8.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL08:writerv7.2.text" [TEXT/ttxt] ...
Processing FOLDER   ":usus Folder:VOL09" ...
Processing document ":usus Folder:VOL09:adv.doc.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL09:adv.miscinfo" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL09:adv.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL09:advinit.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL09:advs1.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL09:advs10.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL09:advs11.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL09:advs2.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL09:advs3.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL09:advs4.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL09:advs5.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL09:advs6.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL09:advs7.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL09:advs8.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL09:advs9.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL09:advsubs.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL09:advverb.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL09:castles.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL09:catalog.9.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL09:spacewar.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL09:star.part1.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL09:star.part2.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL09:star.part3.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL09:startrek.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL09:volume.9.text" [TEXT/ttxt] ...
Processing FOLDER   ":usus Folder:VOL10" ...
Processing document ":usus Folder:VOL10:benchmark.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL10:benchmark1.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL10:btre.file.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL10:btre.find1.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL10:btre.find2.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL10:btree.data" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL10:btree.dclr.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL10:btree.del1.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL10:btree.del2.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL10:btree.doit.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL10:btree.get.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL10:btree.init.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL10:btree.prnt.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL10:btree.std.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL10:catalog.1.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL10:catalog.2.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL10:catalog.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL10:kruskal.1.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL10:kruskal.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL10:new.bfs.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL10:person.data" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL10:vol10.doc.text" [TEXT/ttxt] ...
Processing FOLDER   ":usus Folder:VOL11" ...
Processing document ":usus Folder:VOL11:bjack.1.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL11:blackjack.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL11:chase.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL11:contents.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL11:mail.doc.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL11:mail.e.g.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL11:mail.form.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL11:mail.info.data" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL11:mail.init.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL11:mail.lett.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL11:mail.read.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL11:mail.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL11:mail1.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL11:mail2a.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL11:mail2b.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL11:mail3.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL11:mail4.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL11:mail5.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL11:mail6.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL11:mail7.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL11:mail8.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL11:mail9.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL11:mailiniteg.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL11:screenopsa.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL11:screenopsx.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL11:vol11.doc.text" [TEXT/ttxt] ...
Processing FOLDER   ":usus Folder:VOL12" ...
Processing document ":usus Folder:VOL12:analyze.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL12:augment.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL12:bench.byte.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL12:bench.pcw.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL12:bench.swap.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL12:bench.usus.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL12:contents.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL12:cproc.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL12:disk_copy.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL12:help.disk.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL12:help.keys.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL12:help.off.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL12:help.util.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL12:lmformat.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL12:make.page.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL12:new.page.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL12:new.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL12:off.doc.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL12:off.info.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL12:off.read.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL12:off.start.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL12:offload.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL12:param.info.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL12:print.heap.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL12:print.mem.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL12:r.analyze.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL12:startup.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL12:vol12.doc.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL12:vols.smac" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL12:w.doc.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL12:w.impln.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL12:w.io.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL12:w.segs.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL12:wfiler.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL12:windows.text" [TEXT/ttxt] ...
Processing FOLDER   ":usus Folder:VOL13" ...
Processing document ":usus Folder:VOL13:declare.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL13:defalt_doc.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL13:dopage.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL13:dot_doc.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL13:errordata" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL13:err_doc.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL13:fit.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL13:howto_doc.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL13:initc.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL13:intro_doc.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL13:main.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL13:pdate.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL13:readln.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL13:readnu.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL13:runon_doc.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL13:scredit.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL13:scrgen.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL13:spec_doc.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL13:startup.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL13:sysgen.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL13:taxcalc.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL13:taxedit.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL13:taxnames.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL13:taxprint.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL13:taxrw.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL13:taxstart.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL13:taxtable.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL13:tech_doc.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL13:types.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL13:vol13.doc.text" [TEXT/ttxt] ...
Processing FOLDER   ":usus Folder:VOL14" ...
Processing document ":usus Folder:VOL14:8080conv.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL14:banner.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL14:bondystuff.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL14:calendar.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL14:compfile.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL14:copfile.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL14:copver.asm.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL14:copvol.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL14:crosses.gpat" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL14:dayofwk.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL14:default.gpat" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL14:fastread.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL14:game.assem.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL14:game.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL14:game1.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL14:hexdump.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL14:home_loan.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL14:kbstat.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL14:listinfo.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL14:look.up.table" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL14:refer.inc.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL14:reference.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL14:reform.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL14:roman.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL14:scanner.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL14:sorts1.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL14:sorts2.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL14:sorts3.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL14:sorts4.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL14:sparse.gpat" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL14:srccom.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL14:stock.data.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL14:stock.doc.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL14:stock.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL14:table.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL14:vol14.doc.text" [TEXT/ttxt] ...
Processing FOLDER   ":usus Folder:VOL15" ...
Processing document ":usus Folder:VOL15:a.___.remu.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL15:clr_break.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL15:comm.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL15:contents.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL15:hsm.uinc1.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL15:hsm.uinc2.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL15:hsm.uroot.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL15:iounit.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL15:remtalk.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL15:remunit.l3.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL15:set_break.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL15:smtremv5.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL15:std.unit.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL15:teletalker.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL15:term.emul.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL15:term.init.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL15:term.log.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL15:term.main.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL15:term.util.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL15:tomus3.a.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL15:tomus3.c1.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL15:tomus4.c2.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL15:vol15.doc.text" [TEXT/ttxt] ...
Processing FOLDER   ":usus Folder:VOL16" ...
Processing document ":usus Folder:VOL16:8.inch.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL16:add.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL16:apple.labl.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL16:ase.header.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL16:basproc.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL16:basproc2.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL16:bdebug.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL16:bdoc1.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL16:bdoc2.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL16:bdoc3.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL16:bdriver.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL16:bhkeep.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL16:bintern.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL16:bio.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL16:bmain.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL16:bunit.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL16:checkbook.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL16:crtinput.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL16:getnumber.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL16:horton.doc.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL16:inv.doc.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL16:inv.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL16:invcs.mask.data" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL16:issue.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL16:p.inc.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL16:p.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL16:report.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL16:usus.inv.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL16:vol16.doc.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL16:z80.seek.text" [TEXT/ttxt] ...
Processing FOLDER   ":usus Folder:VOL17" ...
Processing document ":usus Folder:VOL17:booter.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL17:comp.a.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL17:comp.b.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL17:comp.c.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL17:comp.d.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL17:comp.e.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL17:comp.f.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL17:filer.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL17:globals.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL17:linker.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL17:system.a.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL17:system.b.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL17:vol17.doc.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL17:xfer.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL17:yaloe.text" [TEXT/ttxt] ...
Processing FOLDER   ":usus Folder:VOL18" ...
Processing document ":usus Folder:VOL18:8queens.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL18:ancest.s.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL18:bench.usus.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL18:benchmarks.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL18:black.doc1.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL18:black.doc2.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL18:blackbox.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL18:bondy_form.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL18:compkiller.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL18:debug.a.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL18:debug.b.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL18:intrinsics.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL18:life.inc.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL18:life.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL18:long_int.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL18:numberio.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL18:odmscu.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL18:primes.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL18:pwrof2.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL18:quicksort.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL18:qur.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL18:report.doc.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL18:reportform.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL18:segmap.1.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL18:segmap.2.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL18:segmasher.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL18:sieve.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL18:sort2.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL18:sortunit.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL18:stars.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL18:tele.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL18:vol18.doc.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL18:whet.doc.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL18:whetstone.text" [TEXT/ttxt] ...
Processing FOLDER   ":usus Folder:VOL19" ...
Processing document ":usus Folder:VOL19:2k.key.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL19:booter.code" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL19:dec.index.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL19:eis.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL19:lp11.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL19:macros.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL19:mainop.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL19:make_i.3.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL19:modem.pas.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL19:patch.cont.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL19:patches.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL19:procop.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL19:pvm.mac.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL19:rx11.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL19:setup.code" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL19:system.interp" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL19:system.pascal" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL19:traps.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL19:vol19.doc.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL19:xfer.code" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL19:zapram.text" [TEXT/ttxt] ...
Processing FOLDER   ":usus Folder:VOL20" ...
Processing document ":usus Folder:VOL20:autopsy.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL20:base.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL20:bios.const.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL20:bios.data.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL20:bios.disks.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL20:bios.phone.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL20:bios.serpt.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL20:boot.write.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL20:bootmaker.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL20:bootr-genr.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL20:e.boot.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL20:e.load.bios" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL20:e.load.boot" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL20:ebios-genr.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL20:ebios.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL20:eboot-genr.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL20:escort.doc.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL20:fastread.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL20:fmt-genr.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL20:formatter.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL20:h19util.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL20:home_loan.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL20:lwrcase.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL20:number2.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL20:othello.1.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL20:othello.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL20:screen.h19.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL20:screen.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL20:sigfig.19.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL20:sxfr.svcs.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL20:trans-genr.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL20:transportr.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL20:unlpatch.1.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL20:unlpatch.2.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL20:unlpch.doc.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL20:uprcase.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL20:vol20.doc.text" [TEXT/ttxt] ...
Processing FOLDER   ":usus Folder:VOL22" ...
Processing document ":usus Folder:VOL22:contour.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL22:curve_fit.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL22:distrib.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL22:fact_stuff.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL22:func.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL22:graph.doc.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL22:graphics.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL22:histogram.data" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL22:histogram.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL22:ivp.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL22:plotter.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL22:polar.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL22:post.doc.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL22:post_entry.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL22:real_input.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL22:review.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL22:scrn_stuff.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL22:sines.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL22:traverse.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL22:triangle.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL22:vol22.doc.text" [TEXT/ttxt] ...
Processing FOLDER   ":usus Folder:VOL23" ...
Processing document ":usus Folder:VOL23:df.docum.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL23:df.iv.0.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL23:df.iv.1.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL23:dict.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL23:iodoc.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL23:iotest.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL23:iounit.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL23:rnddoc.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL23:rndtest.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL23:spelldoc.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL23:speller.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL23:stargame.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL23:vol23.doc.text" [TEXT/ttxt] ...
Processing FOLDER   ":usus Folder:VOL24" ...
Processing document ":usus Folder:VOL24:adv.miscinfo" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL24:advx.doc.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL24:advx.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL24:advx1.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL24:advx10.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL24:advx11.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL24:advx2.code" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL24:advx2.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL24:advx3.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL24:advx4.code" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL24:advx4.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL24:advx5.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL24:advx6.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL24:advx7.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL24:advx8.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL24:advx9.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL24:advxcons.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL24:advxinit.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL24:advxinit2.code" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL24:advxinit4.code" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL24:advxsegs.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL24:advxsubs.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL24:advxverb.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL24:vol24.doc.text" [TEXT/ttxt] ...
Processing FOLDER   ":usus Folder:VOL25" ...
Processing document ":usus Folder:VOL25:readme.1st.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL25:sd.define.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL25:sh.calc.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL25:sh.display.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL25:sh.field.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL25:sh.init.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL25:sh.save.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL25:sh.screen.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL25:ud.copy.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL25:ud.list.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL25:ud.maint.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL25:ud.sort.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL25:ud.ude.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL25:ud.udelst.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL25:vol25.doc.text" [TEXT/ttxt] ...
Processing FOLDER   ":usus Folder:VOL26" ...
Processing document ":usus Folder:VOL26:readme.1st.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL26:sd_define.code" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL26:sh.screen.code" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL26:sh_screen.unit" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL26:ud.intrdoc.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL26:ud.sort.code" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL26:ude.1.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL26:ude.2.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL26:ude.3.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL26:ude.4.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL26:ude.5.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL26:ude.6.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL26:ud_copy.code" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL26:ud_list.code" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL26:ud_list.scrn" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL26:ud_maint.code" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL26:ud_sort.code" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL26:ud_sort.scrn" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL26:ud_ude.code" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL26:userlib.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL26:vol26.doc.text" [TEXT/ttxt] ...
Processing FOLDER   ":usus Folder:VOL27" ...
Processing document ":usus Folder:VOL27:ff.basics1.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL27:ff.basics2.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL27:ff.basics3.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL27:ff.copy1.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL27:ff.copy2.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL27:ff.data1.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL27:ff.data2.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL27:ff.data3.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL27:ff.data4.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL27:ff.data5.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL27:ff.forms1.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL27:ff.forms2.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL27:ff.forms3.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL27:ff.forms4.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL27:ff.forms5.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL27:ff.freefrm.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL27:ff.misc1.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL27:ff.misc2.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL27:readme.1st.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL27:vol27.doc.text" [TEXT/ttxt] ...
Processing FOLDER   ":usus Folder:VOL28" ...
Processing document ":usus Folder:VOL28:ff.2word.code" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL28:ff.4word.code" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL28:ff.a.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL28:ff.b.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL28:ff.c.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL28:ff.d.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL28:ff.e.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL28:ff.f.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL28:ff.g.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL28:ff.h.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL28:ff.i.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL28:ff.j.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL28:ff.k.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL28:readme.1st.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL28:vol28.doc.text" [TEXT/ttxt] ...
Processing FOLDER   ":usus Folder:VOL29" ...
Processing document ":usus Folder:VOL29:convdoc.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL29:convers.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL29:conv_test.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL29:draw4a.1.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL29:draw4a.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL29:draw8a.1.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL29:draw8a.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL29:drawdn.doc.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL29:install.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL29:osmisc_ii0.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL29:osmisc_iv.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL29:scrnop_ii0.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL29:terminal.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL29:textio_ii0.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL29:textio_iv.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL29:vol29.doc.text" [TEXT/ttxt] ...
Processing FOLDER   ":usus Folder:VOL2A" ...
Processing document ":usus Folder:VOL2A:512.doc.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL2A:acoustic.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL2A:bootasm.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL2A:bootcpm.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL2A:catalog.2.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL2A:cpmio.doc.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL2A:dchayes.io.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL2A:delete.lf.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL2A:dfoco.doc.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL2A:h14.driver.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL2A:h19.doc.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL2A:h19.gotoxy" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL2A:h19.miscinfo" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL2A:hazel.miscinfo" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL2A:hexout.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL2A:kbstat.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL2A:linecountr.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL2A:movram.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL2A:new.gotoxy.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL2A:pe1100.gotoxy" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL2A:peruse.pg.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL2A:policy.doc.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL2A:prime1.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL2A:prime2.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL2A:ptp.doc.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL2A:ptp.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL2A:punch.tape.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL2A:randombyte.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL2A:read.tape.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL2A:shellmsort.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL2A:smartremot.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL2A:timing.doc.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL2A:tvi912c.gotoxy" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL2A:update.doc.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL2A:vol.2b.doc.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL2A:volume.2.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL2A:writer.doc.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOL2A:writer.text" [TEXT/ttxt] ...
Processing FOLDER   ":usus Folder:VOLUK03" ...
Processing document ":usus Folder:VOLUK03:ada.code" [TEXT/ttxt] ...
Processing document ":usus Folder:VOLUK03:ada.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOLUK03:adadoc.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOLUK03:adatest.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOLUK03:coint.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOLUK03:contents.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOLUK03:filecheck.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOLUK03:gendat.code" [TEXT/ttxt] ...
Processing document ":usus Folder:VOLUK03:gendat.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOLUK03:lainit.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOLUK03:lanext.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOLUK03:luerror.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOLUK03:luinit.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOLUK03:newadatest.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOLUK03:parser.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOLUK03:stget.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOLUK03:textdat.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOLUK03:types.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOLUK03:voluk3.doc.text" [TEXT/ttxt] ...
Processing FOLDER   ":usus Folder:VOLUK04" ...
Processing document ":usus Folder:VOLUK04:apl.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOLUK04:aplchers.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOLUK04:aplheap.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOLUK04:aplinit.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOLUK04:aplparse0.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOLUK04:aplparse1.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOLUK04:aplparse2.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOLUK04:aplparse3.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOLUK04:aplprocs.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOLUK04:contents.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOLUK04:sort.doc.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOLUK04:sort.dumun.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOLUK04:sort.merge.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOLUK04:sort.read.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOLUK04:sort.txtun.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOLUK04:spbssdoc1.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOLUK04:spbssdoc2.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOLUK04:spbsstuff.code" [TEXT/ttxt] ...
Processing document ":usus Folder:VOLUK04:spbsstuff.text" [TEXT/ttxt] ...
Processing document ":usus Folder:VOLUK04:voluk4.doc.text" [TEXT/ttxt] ...

Text documents have been concatenated to document "BigTextDocument"

That's all, Folks!
